El truco de la distribución provincial

Mismo truco que en Andalucía, pero con referencia del 23J: si en 2023 ERC sacó en Barcelona un 6,5 veces su media nacional, asumo que ese desvío se mantiene. Formalmente:

y luego normalizo dentro de cada provincia. El que tenga una idea mejor, que lo comente en el blog o me escriba.

ref13 |>
  filter(provincia == "Granada", ratio > 0) |>
  select(partido, votos, pct_prov, pct_nac, ratio) |>
  arrange(desc(pct_prov)) |>
  mutate(across(where(is.double), \(x) round(x, 2)))
#> # A tibble: 6 × 5
#>   partido  votos pct_prov pct_nac ratio
#>   <chr>    <dbl>    <dbl>   <dbl> <dbl>
#> 1 PP      185996    37.3    33.3   1.12
#> 2 PSOE    165862    33.2    31.9   1.04
#> 3 VOX      81080    16.3    12.5   1.3 
#> 4 SUMAR    58567    11.7    12.4   0.94
#> 5 SALF     20674     6.02    4.62  1.3 
#> 6 RESTO     7283     1.46    2.48  0.59

granada <- prov_datos |> filter(codigo_provincia == 18)

set.seed(6137)
d <- gtools::rdirichlet(5, granada$alpha13[[1]])
ratios <- t(granada$ratio13[[1]] * t(d) / granada$pct23[[1]])

tibble(partido = fams13, ratio_23j = granada$ratio13[[1]]) |>
  bind_cols(as_tibble(t(ratios), .name_repair = \(x) {
    paste0("muestra_", 1:5)
  })) |>
  filter(ratio_23j > 0) |>
  mutate(across(where(is.double), \(x) round(x, 2)))
#> # A tibble: 6 × 7
#>   partido ratio_23j muestra_1 muestra_2 muestra_3 muestra_4 muestra_5
#>   <chr>       <dbl>     <dbl>     <dbl>     <dbl>     <dbl>     <dbl>
#> 1 PP           1.12      1.02      1.15      1.21      1.11      1.18
#> 2 PSOE         1.04      1.12      1.06      1.04      1.01      1.11
#> 3 VOX          1.3       1         0.98      1.22      1.39      1.3 
#> 4 SUMAR        0.94      1.2       1.14      0.84      1.05      0.66
#> 5 SALF         1.3       1.35      1.26      1.16      1.09      1.23
#> 6 RESTO        0.59      1         0.7       0.58      0.5       0.52

ruido_ratio <- function(prov, partido = "PP", n = 5000) {
  pd <- prov_datos |>
    filter(
      codigo_provincia == prov_ref$codigo_provincia[prov_ref$provincia == prov]
    )
  i <- match(partido, fams13)
  d <- gtools::rdirichlet(n, pd$alpha13[[1]])
  r <- pd$ratio13[[1]][i] * d[, i] / pd$pct23[[1]][i]
  tibble(
    provincia = prov,
    diputados = pd$escanos,
    votantes_equivalentes = sum(pd$alpha13[[1]]),
    ratio_23j = pd$ratio13[[1]][i],
    media = mean(r),
    sd = sd(r)
  )
}

set.seed(6137)
bind_rows(ruido_ratio("Granada"), ruido_ratio("Soria")) |>
  mutate(across(where(is.double), \(x) round(x, 2)))
#> # A tibble: 2 × 6
#>   provincia diputados votantes_equivalentes ratio_23j media    sd
#>   <chr>         <dbl>                 <dbl>     <dbl> <dbl> <dbl>
#> 1 Granada           7                 519.       1.12  1.12  0.07
#> 2 Soria             2                  51.6      1.12  1.12  0.2

¿Cuánto se mueve la distribución provincial?

La Dirichlet simula que no me fío del recuento de 2023, como si Granada fuera una encuesta con su margen de error. Pero eso fue lo que pasó de verdad: el fenómeno que querríamos modelar es el cambio de distribución provincial entre unas elecciones y otras.

¿Está calibrado ese ruido?

Más abajo hice un backtest nacional, que no es más que utilizar las encuestas previas a las elecciones pasadas, y ver si con la aproximación con la Dirichlet los intervalos de estimación de voto y de escaños a nivel estatal son del 90%.

Para saber si a nivel provincial pasa lo mismo, procedemos igual y vemos si esos intervalos tienen cobertura del 90% teórico o no.

Como tenemos 5 elecciones anteriores x partidos con encuestas x 52 provincias salen sobre unas 936 celdas. En cada celda miro si el intervalo contiene el verdadero valor. La cobertura del 90% implicaría que en el 90% de esas celdas el intervalo contuviera al verdadero valor.

Ejemplo. Granada, 23J, PP: la simulación, que parte del ratio del 10N, le daba un IC90 de [32,4; 38,5] y sacó un 37,0. Dentro.

Lleida, 23J, PSOE: le daba [17,1; 20,4] y sacó un 29,5. Fuera por mucho. Y no es casualidad: entre el 10N y el 23J el PSC se movió en bloque en Cataluña mientras el PSOE bajaba a nivel nacional. En 2023, el PSOE (PSC) subió mucho, podríamos llamarlo efecto PSC.

mult <- ratios[[i]] * dir_m[[i]][k, ] / q23_prov[[i]]
v <- c(tracked[k, con_datos] * mult, otros_list[[prov_i[i]]])
v <- v / sum(v)   # <- este reparto provincial es lo que ahora se guarda

La cuenta global, partido por partido:

prov_celdas <- read_csv(
  here::here("2026/10/backtest_prov_celdas.csv"),
  show_col_types = FALSE
)

cobertura_de <- function(celdas) {
  con_z <- celdas |>
    filter(!ref_ratio_cero) |>
    mutate(z = (real - mediana) / ((q95 - q05) / (2 * qnorm(0.95))))
  bind_rows(
    con_z |>
      group_by(familia) |> # familia == partido , reminiscencias del primer código
      summarise(
        celdas = n(),
        cobertura = mean(dentro),
        factor_ruido = sd(z),
        .groups = "drop"
      ),
    con_z |>
      summarise(
        familia = "TOTAL",
        celdas = n(),
        cobertura = mean(dentro),
        factor_ruido = sd(z),
        .groups = "drop"
      )
  )
}

cobertura_de(prov_celdas) |>
  rename(partido = familia) |>
  mutate(across(where(is.numeric), \(x) round(x, 2)))
#> # A tibble: 5 × 4
#>   partido celdas cobertura factor_ruido
#>   <chr>    <dbl>     <dbl>        <dbl>
#> 1 PP         255      0.73         1.6 
#> 2 PSOE       260      0.7          1.99
#> 3 SUMAR      259      0.59         2.39
#> 4 VOX        138      0.56         2.38
#> 5 TOTAL      912      0.66         2.09

Mis intervalos prometen un 90% y cumplen un 66%. El factor_ruido lo mide: cuántas veces habría que multiplicar el ruido para que el intervalo cumpliera lo que promete. En conjunto, unas dos veces: la distribución provincial real se mueve entre elecciones el doble de lo que la Dirichlet admite. Y el problema es de anchura, no de centro: el real cae por debajo del intervalo en un 20% de las celdas y por encima en un 16%.

¿Y por elección?

prov_celdas |>
  filter(!ref_ratio_cero) |>
  group_by(eleccion) |>
  summarise(cobertura = mean(dentro), .groups = "drop") |>
  mutate(across(where(is.numeric), \(x) round(x, 2)))
#> # A tibble: 5 × 2
#>   eleccion cobertura
#>   <chr>        <dbl>
#> 1 10n           0.8 
#> 2 20d           0.49
#> 3 23j           0.63
#> 4 26j           0.7 
#> 5 28a           0.62

El 10N, repetición de la anterior, sale al 80%, lo mejor de la lista: con la geografía casi congelada, el ruido actual basta. En las transiciones frescas (20D 49%, 28A 62%, 23J 63%) se cae muy por debajo. La Dirichlet estaba calibrada, sin que yo lo supiera, para el caso más fácil.

Los dos efectos: comunidad y provincia

Lo de la aproximación de la Dirichlet era bastante compadre, se queda corta para los cambios que hubo en la realidad.

Como tenemos datos de elecciones pasadas, podemos intentar medir como ha cambiado la distribución provincial. Algunas elecciones se celebraron con pocos meses de diferencia y, como era de esperar, los ratios provinciales cambiaron poco. Pero las otras sí sirven para ver cuánto se mueve en cada provincia cada partido.

Pero el efecto no es solo por provincia, a veces el cambio se da en toda una comunidad, como la subida del PSC en Cataluña en 2023, y otras veces el cambio puede ser en alguna provincia concreta sin relación con la comunidad.

Con lo cual, dos efectos: uno por comunidad, cuyo resultado sufren todas sus provincias a la vez, y otro por provincia. Los llamo (comunidad) y (provincia). Y la idea es estimarlo a partir de los datos de elecciones anteriores.

Es importante ver el cambio de ratio, es decir cuánto más o cuánto menos se vota un partido en una provincia respecto a toda España, para separar el aumento de voto a un partido (que esto lo mide el modelo), respecto a la composición provincial de como se reparte, que es justo lo que queremos ver en este apartado

bf(
  dlr ~ 0 + partido + repeticion + (0 + partido || codigo_ccaa),
  sigma ~ 0 + celda_sigma    # celda = partido × {fresca, repetición}
)

El posterior de los dos efectos, por partido:

tau_brms <- read_csv(
  here::here("2026/10/tau_shock_brms.csv"),
  show_col_types = FALSE
) |>
  rename(partido = familia)

tau_brms |>
  mutate(
    across(where(is.numeric), \(x) round(x, 3)),
    `tau_c` = str_c(tau_c_med, " [", tau_c_ic05, ", ", tau_c_ic95, "]"),
    `tau_p` = str_c(tau_p_med, " [", tau_p_ic05, ", ", tau_p_ic95, "]")
  ) |>
  select(partido, `tau_c`, `tau_p`)
#> # A tibble: 4 × 3
#>   partido tau_c               tau_p               
#>   <chr>   <chr>               <chr>               
#> 1 PP      0.04 [0.026, 0.06]  0.171 [0.153, 0.193]
#> 2 PSOE    0.023 [0.01, 0.04]  0.154 [0.137, 0.173]
#> 3 SUMAR   0.057 [0.03, 0.095] 0.16 [0.143, 0.181] 
#> 4 VOX     0.124 [0.09, 0.172] 0.195 [0.162, 0.234]

De la posterior saco un par de apuntes

• El τ no depende apenas del tamaño de la provincia; la correlación de |Δ log r| con los votos provinciales va de −0,3 a 0. Eso desmiente el escalado de la Dirichlet, que daba una desviación de 0,06 en Granada y de 0,01 en Madrid por el mero hecho de tener más votantes.

• El efecto de comunidad sale pequeño en PP (0,04) y PSOE (0,02) y grande en VOX (0,12). El PP se mueve provincia a provincia; VOX, en bloque por comunidad.

Un aviso sobre SUMAR, que conviene tener a la vista: parte de su Δ log r no es geografía, es recomposición de candidaturas. En el ciclo 2015–2016 las confluencias (En Comú, En Marea, Compromís-Podemos) e IU concurrieron por separado en el 20D y juntas como Unidos Podemos en el 26J; en el 23J Sumar integró a Compromís, Más Madrid y otros, que en 2019 habían concurrido por separado (Más País, Más Compromís).

Su τ sale por ahí algo inflado y, no por casualidad, es el peor calibrado de los cuatro: factor de ruido 1,23 frente al 0,7–1,0 del resto de partidos. Una parte de su desviación no es por cambio de distribución provincial, sino por la composición de la coalición en el pasado.

Los efectos entran en la simulación

En cada muestra, el ratio del partido en la provincia pasa de a

O sea, el ratio de 2023 tras sumar los dos efectos en escala logarítmica y exponenciar el resultado. Al tener dos efectos, comunidad y provincia hay que normalizar de alguna forma para que no se den efectos raros.

Un ejemplo con dos provincias: A pesa el 60% de los votos, B el 40%, y los ratios de referencia valen 1,0 en las dos, así que el nacional implícito es el que toca. Un draw da exp(η+ε) = 1,10 en la comunidad de A y 0,95 en la de B. La media ponderada es 0,6·1,10 + 0,4·0,95 = 1,04: sin más, la geografía habría dado al partido un +4% de voto nacional, por encima de lo que ya decidió la capa de error. Dividiendo cada ratio entre 1,04 (A queda en 1,058, B en 0,913), la media vuelve a 1,00 y el nacional se conserva: solo mueve voto entre provincias.

comp_var <- read_csv(
  here::here("2026/10/backtest_prov_comparacion.csv"),
  show_col_types = FALSE
) |>
  rename(partido = familia)

# helpers para las cifras en línea del texto
cob_de <- function(vari, part = "TOTAL") {
  100 * comp_var$cobertura[comp_var$variante == vari & comp_var$partido == part]
}
fac_de <- function(vari, part = "TOTAL") {
  comp_var$factor_ruido[comp_var$variante == vari & comp_var$partido == part]
}
# números en línea con coma decimal (convención del texto)
num_es <- function(x, d = 2) {
  format(round(x, d), decimal.mark = ",", trim = TRUE)
}
vox_tau_p <- tau_brms |>
  filter(partido == "VOX") |>
  transmute(
    s = str_c(
      format(round(tau_p_med, 3), decimal.mark = ","),
      " [",
      format(round(tau_p_ic05, 3), decimal.mark = ","),
      "; ",
      format(round(tau_p_ic95, 3), decimal.mark = ","),
      "]"
    )
  ) |>
  pull(s)

# diagnóstico de doble conteo: la Dirichlet superpuesta al shock (con los
# draws brms)
masdir <- read_csv(
  here::here("2026/10/backtest_prov_celdas_shock_mas_dir.csv"),
  show_col_types = FALSE
) |>
  filter(!ref_ratio_cero) |>
  summarise(cobertura = mean(dentro), ancho = mean(q95 - q05))

comp_var |>
  filter(partido == "TOTAL" | variante != "dirichlet (baseline)") |>
  select(-celdas) |>
  mutate(across(where(is.numeric), \(x) round(x, 2))) |>
  arrange(variante, partido)
#> # A tibble: 11 × 5
#>    partido cobertura ancho factor_ruido variante            
#>    <chr>       <dbl> <dbl>        <dbl> <chr>               
#>  1 TOTAL        0.66  5.67         2.09 dirichlet (baseline)
#>  2 PP           0.96 14.6          0.73 shock brms (draws)  
#>  3 PSOE         0.95 12.9          0.83 shock brms (draws)  
#>  4 SUMAR        0.9   9.66         1.23 shock brms (draws)  
#>  5 TOTAL        0.94 12.0          0.97 shock brms (draws)  
#>  6 VOX          0.93  9.97         1.02 shock brms (draws)  
#>  7 PP           0.95 13.5          0.78 shock puntual       
#>  8 PSOE         0.94 11.8          0.91 shock puntual       
#>  9 SUMAR        0.9   9.21         1.3  shock puntual       
#> 10 TOTAL        0.92 10.9          1.08 shock puntual       
#> 11 VOX          0.86  7.62         1.35 shock puntual

Tres conclusiones, por este orden:

1. Calibra: del 66% al 94% de cobertura, con el factor de ruido en 0,97. Y corrige justo lo que quedó mal con los τ puntuales: VOX pasa del 86% al 93%. Su τ_p posterior (0,195 [0,162; 0,234]) mezcla escenarios de deriva baja y alta, y la mezcla cubre.
2. La Dirichlet sobra: superponerla al shock apenas mueve nada (93,9% → 94,2%, el ancho ni se entera). Su varianza es despreciable junto a la del shock. La sustitución es limpia: el divisor de 1.000 y su escalado desaparecen, sustituidos por dos efectos por partido que salen de la historia.
3. El límite es el efecto PSC: los tres fallos catalanes del PSOE en el 23J siguen fuera incluso con este modelo. La deriva catalana de 2023 fue más grande. Para afinar eso hace falta información de comunidad actual, no historia, que serían encuestas a nivel de comunidad autónoma.

loto_res <- read_csv(
  here::here("2026/10/backtest_prov_loto_resumen.csv"),
  show_col_types = FALSE
)

# cobertura in-sample por elección (el 20D solo tiene la variante oos)
cob_in <- function(e) {
  v <- if (e == "20d") "in-sample (oos)" else "in-sample"
  100 * loto_res$cobertura[loto_res$eleccion == e & loto_res$variante == v]
}

loto_res |>
  mutate(
    eleccion = recode(
      eleccion,
      `20d` = "20D-2015",
      `26j` = "26J-2016",
      `28a` = "28A-2019",
      `10n` = "10N-2019",
      `23j` = "23J-2023"
    ),
    variante = recode(
      variante,
      `in-sample` = "in-sample",
      `in-sample (oos)` = "in-sample (fuera de muestra)",
      `loto` = "LOTO"
    ),
    cobertura = scales::percent(cobertura, 1),
    ancho_medio = round(ancho_medio, 1)
  ) |>
  rename(
    Elección = eleccion,
    Variante = variante,
    Celdas = celdas,
    Cobertura = cobertura,
    `Ancho medio IC90` = ancho_medio
  )
#> # A tibble: 9 × 5
#>   Elección Variante                     Celdas Cobertura `Ancho medio IC90`
#>   <chr>    <chr>                         <dbl> <chr>                  <dbl>
#> 1 20D-2015 in-sample (fuera de muestra)    154 84%                     12.7
#> 2 26J-2016 LOTO                            155 99%                     13.1
#> 3 26J-2016 in-sample                       155 99%                     13.2
#> 4 28A-2019 LOTO                            189 90%                     11.5
#> 5 28A-2019 in-sample                       189 90%                     11.2
#> 6 10N-2019 LOTO                            207 99%                     11.2
#> 7 10N-2019 in-sample                       207 99%                     11.5
#> 8 23J-2023 LOTO                            207 95%                     11.7
#> 9 23J-2023 in-sample                       207 96%                     11.8

read_csv(
  here::here("2026/10/tau_regionales.csv"),
  show_col_types = FALSE
) |>
  rename(partido = familia) |>
  select(partido, tau_p, tau_c, tau_total, fuente) |>
  mutate(across(where(is.numeric), \(x) round(x, 3)))
#> # A tibble: 7 × 5
#>   partido  tau_p tau_c tau_total fuente                  
#>   <chr>    <dbl> <dbl>     <dbl> <chr>                   
#> 1 BNG      0.106 0         0.106 estimado                
#> 2 CC       0.09  0         0.09  estimado                
#> 3 EH Bildu 0.107 0         0.107 estimado                
#> 4 ERC      0.068 0.161     0.175 estimado                
#> 5 Junts    0.048 0.107     0.118 estimado                
#> 6 PNV      0.067 0         0.067 estimado                
#> 7 UPN      0.115 0         0.115 heredado (RMS del resto)

El error histórico de las encuestas

En este apartado es donde tengo bastantes dudas de lo que he hecho. Creo que necesita ser más trabajado. La idea es que puede que las encuestas hayan subestimado o sobreestimado a algún partido en particular de forma sistemática, y corregir en cierta forma ese sesgo.

Para cada elección pasada, comparo el resultado real con la media de las encuestas cuyo trabajo de campo terminó en los últimos días de campaña: 124 encuestas de las cinco últimas generales, sacadas de los anexos de sondeos de Wikipedia (con su fecha de fin de campo, que en esas tablas viene en rangos tipo “15–19 Abr”) y congeladas en errores_encuestas_historicas.csv. Quedan fuera los sondeos internos de partidos que también publican los anexos: no son estimaciones públicas. Para el PSOE sale esto:

errores_hist <- read_csv(
  here::here("2026/10/errores_encuestas_historicas.csv"),
  show_col_types = FALSE
)

etiquetas <- c(
  `20d` = "20D-2015",
  `26j` = "26J-2016",
  `28a` = "28A-2019",
  `10n` = "10N-2019",
  `23j` = "23J-2023"
)

errores_hist |>
  group_by(eleccion) |>
  summarise(encuesta = mean(PSOE), error = mean(e_PSOE), .groups = "drop") |>
  mutate(real = encuesta + error) |>
  arrange(match(eleccion, names(etiquetas))) |>
  mutate(eleccion = etiquetas[eleccion]) |>
  relocate(eleccion, encuesta, real, error) |>
  mutate(across(where(is.numeric), \(x) round(x, 2))) |>
  rename(Elección = eleccion, Encuestas = encuesta, Real = real, Error = error)
#> # A tibble: 5 × 4
#>   Elección Encuestas  Real Error
#>   <chr>        <dbl> <dbl> <dbl>
#> 1 20D-2015      21.1  22.0  0.94
#> 2 26J-2016      21.2  22.6  1.37
#> 3 28A-2019      28.8  28.7 -0.09
#> 4 10N-2019      27.1  28    0.89
#> 5 23J-2023      28.2  31.7  3.49

Positivo en cuatro de las cinco (el 28A-2019 queda en un ±0). Por lo que he visto, de los cuatro partidos principales, el único cuyo sesgo es consistente es el PSOE (+1,3 puntos: positivo en 4 de 5 elecciones, y sigue en +1,3 si excluyo el 26J, que solo tiene 2 encuestas). Pero con cinco elecciones la media muestral de ese sesgo es una estimación ruidosa, y lo compruebo con un leave-one-out: aplicada fuera de muestra, la corrección completa no mejora la predicción. El 28A paga la factura, con sesgo real ~0 y corrección de +1,7 estimada sin él. Así que la aplico encogida a la mitad (+0,7): la evidencia apunta a que el sesgo existe, pero cinco elecciones no bastan para fijar su tamaño. Y el backtest de más abajo, con sus 18 celdas, no distingue entre corregir todo, la mitad o nada; me quedo con la mitad como compromiso.

Para PP, VOX y Sumar el mu cambia de signo según qué elecciones entren, así que su μ va a 0. La capa funciona así: a cada muestra del posterior se le suma un error muestreado de una normal multivariante con media +0,7 para el PSOE y 0 para el resto y una desviación típica por partido de 1,3 a 2,6 puntos, que es cuánto se equivocan las encuestas en conjunto con cada uno. La única correlación que lleva es PP–VOX a +0,5: cuando las encuestas se pasan con el bloque del PP, se pasan también con VOX, como ocurrió en las tres elecciones con VOX (la correlación empírica es +0,92 y con n = 3 la encogí). El resto de correlaciones es inestable con 5 elecciones y va a 0. Es la conclusión contraria de la que puse a mano en Andalucía: el trasvase de voto útil PP–VOX es dinámica de campaña que el modelo ya captura con las pendientes temporales, y esto va sobre otra cosa, cómo se equivocan las encuestas el día de la votación.

Tras sumar el error, el vector completo se reescala para que siga sumando 100: cada partido cede en proporción a su tamaño. El BLOQUE no carga con el residual (en la primera versión sí: absorbía todo el error de los grandes, incluida la corrección del PSOE, sin que ningún dato diga que los regionales compensen al PSOE). Recibe en cambio un shock propio , supuesto explícito: la historia no puede calibrarlo, allí el bloque es el residual de los grandes por construcción. SALF se queda fuera: no existía antes de 2024 y no tiene historia.

# la capa de error tal como vive en simular_escanos.R
# (la fila del BLOQUE es el supuesto propio, no sale de la calibración)
tibble(partido = names(error_mu), mu = error_mu, sigma = error_sigma) |>
  add_row(partido = "BLOQUE", mu = 0, sigma = 1.5)
#> # A tibble: 6 × 3
#>   partido    mu sigma
#>   <chr>   <dbl> <dbl>
#> 1 PP       0     2.57
#> 2 PSOE     0.66  1.32
#> 3 VOX      0     1.29
#> 4 SUMAR    0     1.89
#> 5 SALF     0     0   
#> 6 BLOQUE   0     1.5

Sobre el impacto: esta incertidumbre no solo ensancha los intervalos (los duplica: el IC90 de PP+VOX pasa de 16 a 30 escaños), también desplaza la estimación: el PSOE gana escaños y la probabilidad de mayoría de PP+VOX baja del 100,0% de los posteriors a secas al 98,0%. Es una corrección estimada con solo 5 elecciones: mejor que nada, peor que calibrar por casa, que sigue pendiente. En el código vive en extraer_shares13(con_error = TRUE); la validación del 23J va sin ella.

El umbral del 3% y las trampas del agregado

Un par de detalles

• El umbral del 3% se aplica por provincia antes de D’Hondt. Con provincias de 3-5 escaños, el umbral efectivo es mucho mayor que el legal: un partido con el 10% en Soria puede quedarse sin nada. (Matiz legal: los blancos cuentan para el umbral y aquí no se simulan; ~0,5%, despreciable.)
• El RESTO (CUP, PACMA, etc.) como categoría agregada gana escaños fantasma: D’Hondt con el agregado le regala diputados que en la realidad ninguna de sus componentes conseguiría. Solución: sus votos van a no representados

Validación: reproducir el 23J

Para ver que el mecanismo de asignación de escaños funciona bien, lo aplico a los datos del 23J

Le doy a la simulación los porcentajes nacionales reales del 23J y sus ratios de referencia, sin ruido, y debe reproducir los escaños oficiales:

v23 <- sim_validacion_23j()

tibble(
  partido = names(v23),
  simulado = v23,
  oficial_23j = c(137, 121, 33, 31, 0, 7, 7, 5, 6, 1, 1, 1, 0)
)
#> # A tibble: 13 × 3
#>    partido  simulado oficial_23j
#>    <chr>       <dbl>       <dbl>
#>  1 PP            137         137
#>  2 PSOE          121         121
#>  3 VOX            33          33
#>  4 SUMAR          31          31
#>  5 SALF            0           0
#>  6 Junts           7           7
#>  7 ERC             7           7
#>  8 PNV             5           5
#>  9 EH Bildu        6           6
#> 10 BNG             1           1
#> 11 CC              1           1
#> 12 UPN             1           1
#> 13 RESTO           0           0

La simulación

Vamos ya con la simulación final. La función simular tiene como argumentos por defecto.

simular(n_draws = 2000, time_obj = time_eleccion, con_ruido = TRUE, modo_ruido = "shock", con_error = TRUE, umbral = 0.03, resto_compite = FALSE, sigma_bloque = 1.5, cor_bloque = 0, t_sigma_df = NULL)

Y lo que hace es: cada muestra del posterior (voto nacional del modelo 1 + composición del bloque del modelo 2) recibe el error histórico de las encuestas, se distribuye por provincias con los dos efectos (comunidad y provincia) de más arriba, se le aplica el umbral del 3% y D’Hondt provincia a provincia. El modo_ruido = "dirichlet" conserva el divisor de 1.000, por si alguien quiere comparar. 6.000 muestras en unos segundos:

# semilla fija: las cifras de la lectura deben ser reproducibles entre renders
set.seed(7382)
sim <- simular(n_draws = 6000)
#> Fuera (sin n publicado): 1 encuestas — InvyMark 
#> Fuera (casas_fuera: CIS, ElectoPanel ): 17 encuestas

# IC 90% por partido
resumen_escanos(sim, width = 0.9) |>
  mutate(across(where(is.numeric), \(x) round(x, 1)))
#> # A tibble: 13 × 7
#>    partido  escanos .lower .upper .width .point .interval
#>    <chr>      <dbl>  <dbl>  <dbl>  <dbl> <chr>  <chr>    
#>  1 PP           130  113      145    0.9 median qi       
#>  2 PSOE         106   92.9    121    0.9 median qi       
#>  3 VOX           66   55       78    0.9 median qi       
#>  4 SUMAR         18    6       32    0.9 median qi       
#>  5 ERC            9    7       13    0.9 median qi       
#>  6 EH Bildu       7    5        9    0.9 median qi       
#>  7 Junts          5    3        8    0.9 median qi       
#>  8 PNV            5    3        6    0.9 median qi       
#>  9 BNG            2    1        5    0.9 median qi       
#> 10 CC             1    1        3    0.9 median qi       
#> 11 RESTO          0    0        0    0.9 median qi       
#> 12 SALF           0    0        0    0.9 median qi       
#> 13 UPN            0    0        1    0.9 median qi

colores_esc <- c(
  "PP" = "#005999",
  "PSOE" = "#FF0126",
  "VOX" = "#51962A",
  "SUMAR" = "#A00B85",
  "ERC" = "#F5A21D",
  "Junts" = "#00E0D1",
  "EH Bildu" = "#00A56D",
  "PNV" = "#008141",
  "BNG" = "#B5C9E4",
  "CC" = "#D44A20",
  "UPN" = "#1B4A9B",
  "SALF" = "#00C3B6",
  "RESTO" = "grey70"
)

sim$draws |>
  pivot_longer(-.draw, names_to = "partido", values_to = "escanos") |>
  ggplot(aes(x = escanos, y = fct_reorder(partido, escanos), fill = partido)) +
  # escaños: enteros con muchos empates; el histograma evita el warning del
  # bandwidth (bw.SJ no encuentra escala en muestras tan discretas) y es más
  # honesto con datos de conteo. normalize = "groups" escala cada partido a su
  # fila: sin él, la altura se normaliza con la densidad máxima global (SALF,
  # con rango 0-1) y los partidos grandes quedan invisibles
  stat_halfeye(
    density = "histogram",
    # bins alineados con los enteros: sin esto, bins no enteros dejan huecos
    # y "dientes" que no son del reparto D'Hondt sino del histograma
    breaks = ggdist::breaks_fixed(width = 1),
    align = ggdist::align_center(at = 0),
    normalize = "groups",
    .width = c(0.5, 0.9),
    alpha = 0.8
  ) +
  # etiqueta con la mediana de cada partido
  stat_summary(
    fun = median,
    geom = "label",
    aes(label = after_stat(x), fill = NULL),
    size = 3,
    fill = "white"
  ) +
  scale_fill_manual(values = colores_esc, guide = "none") +
  geom_vline(xintercept = 176, linetype = "dashed", color = "red") +
  labs(
    title = "Escaños estimados para el 29 de noviembre de 2026",
    subtitle = "6.000 muestras del meta-análisis + error de encuestas + shock provincial + umbral 3% + D'Hondt",
    x = "Escaños",
    y = NULL
  )

prob_mayorias(sim) |>
  mutate(prob = scales::percent(prob, accuracy = 0.1))
#> # A tibble: 3 × 2
#>   escenario        prob 
#>   <chr>            <chr>
#> 1 PP solo >= 176   0.0% 
#> 2 PP + VOX >= 176  97.7%
#> 3 izquierda >= 176 1.8%

# valores para el texto (se recalculan en cada render)
p_derecha <- prob_mayorias(sim) |>
  filter(escenario == "PP + VOX >= 176") |>
  pull(prob)
p_izquierda <- prob_mayorias(sim) |>
  filter(escenario == "izquierda >= 176") |>
  pull(prob)
mediana_derecha <- median(sim$draws$PP + sim$draws$VOX)
gap_pp <- 176 - median(sim$draws$PP)

La lectura: con las encuestas con trabajo de campo desde julio, PP + Vox tendrían la mayoría con probabilidad 97,7% (mediana de 196 escaños para la suma) y el PP solo se queda a 46 escaños de la mayoría.

Es la capa de error histórico la que baja esa probabilidad del ~100% que daban los posteriors a secas: si las encuestas se vuelven a equivocar como en las últimas cinco elecciones, el margen ya no sobra. Nada de esto es una predicción: es una fotografía de lo que dicen las encuestas disponibles, con toda la incertidumbre que el modelo es capaz de cuantificar y que iremos añadiendo encuestas entre ahora y el día E.

¿De dónde sale la incertidumbre?

simular() trae interruptores para apagar cada capa (con_error para el error histórico, con_ruido y modo_ruido para el ruido provincial, que por defecto son los dos efectos y traen la Dirichlet jubilada de vuelta si se les llama), así que se puede medir cuánto aporta cada una. Cinco escenarios, 4.000 muestras cada uno, mirando siempre PP + VOX:

# res_var se calcula en el chunk oculto de la sección del error histórico
res_var |>
  mutate(
    # el porcentaje primero: si el across redondeara antes, un 98.9% pasaría
    # por round(…, 1) = 1 y saldría un "100.0%" falso
    p_mayoria = scales::percent(p_mayoria, 0.1),
    across(where(is.numeric), \(x) round(x, 1))
  )
#> # A tibble: 5 × 5
#>   escenario                         mediana    sd ic90_ancho p_mayoria
#>   <chr>                               <dbl> <dbl>      <dbl> <chr>    
#> 1 solo posteriors                       198   4.6         16 100.0%   
#> 2 + error histórico                     197   9.3         30 99.2%    
#> 3 + shock provincial                    198   5.5         17 100.0%   
#> 4 + Dirichlet provincial (jubilada)     199   5.3         18 100.0%   
#> 5 todo (lo del post)                    196   9.8         32 98.0%

La capa de error histórico es, con diferencia, la que más ensancha todo: la desviación típica de PP + VOX se dobla (de 4,6 a 9,3 escaños) y el IC90 pasa de 16 a 30. El ruido provincial por sí solo aporta bastante menos: con el shock, el IC90 va de 16 a 17; con la Dirichlet jubilada, de 16 a 18. Puede parecer poco, y lo es, aunque el shock mueva el voto provincial el triple: el ruido independiente se cancela entre provincias al sumarlas, y lo que no se cancela, el componente de comunidad, es pequeño frente a la capa de error nacional. Encima del error histórico, el shock suma 2 escaños al IC90 (30 → 32). Dos lecturas más: la mediana baja de 198 a 197, que es la corrección al PSOE cobrándose escaños a la derecha, y la probabilidad de mayoría apenas se mueve (del 100,0% de los posteriors a secas al 98,0% con todas las capas, la fila «todo» de la tabla; la diferencia con el 97,7% de la lectura final es ruido de Monte Carlo: aquí 4.000 muestras, allí 6.000). Con las encuestas de julio-octubre el colchón sobre los 176 es de 20 escaños, y lo que la capa de error hace sobre todo es avisar de que ese colchón puede quedarse en la mitad.

Un apunte sobre esa capa dominante: sus σ salen de solo 5 elecciones y están estimados con ruido (el IC95 de una sd con n = 5 va de 0,6× a 2,9× el valor estimado) y la versión plug-in los trata como si se conocieran con exactitud. Si en cada muestra se muestrea el propio σ de su posterior (lo mismo que pedirle al error una t de Student con 4 gl, colas más gordas) el IC90 de PP + VOX pasa de ~33 a ~41 escaños y la probabilidad de mayoría de la derecha baja del ~98% al ~95%. Los σ̂ son estables entre elecciones (lo de arriba) y el backtest de más abajo va por ahí: con t₄ su cobertura se va al 100% con IC90 de ~33 escaños (cubre de más), mientras el plug-in se queda en un 83-94%, compatible con el 90% nominal. Así que t₄ vive en simular(t_sigma_df = 4) como sensibilidad, no como default.

El backtest: ¿y si lo hubiera hecho antes?

En la validación de como hubiera salido en el 23J lo que se comprueba es que el mecanismo de asignar escaños funciona, dadas unas proporciones por partido en cada provincia. Pero para ver si el modelo predice bien, una forma de hacerlo es irte a elecciones pasadas, ver las encuestas y aplicar el mismo mecanismo que hemos hecho, es decir, estimar el % de voto provincial con la asunción de que los ratios de reparto por partido en cada provincia son similares a las elecciones anteriores de las que se quiere estimar.

Para eso he hecho un backtest (backtest_pipeline.R). En el script se usa al igual que antes la fantástica librería infoelectoral

La idea es sencilla. Para cada una de las cinco últimas generales me pongo en el día de la votación y hago lo que habría hecho entonces, solo con lo que se sabía en ese momento:

• Encuestas: las de la última semana de campaña, las mismas de errores_encuestas_historicas.csv. Son 12 en el 20D, 2 en el 26J (campaña corta) y 20, 30 y 60 en el resto.
• Agregado: Hago media simple con bootstrap de casas, no el modelo jerárquico del post. Lo que quiero probar es la capa de error y el paso de voto a escaños, no el modelo 1.
• Capa de error: el sesgo del PSOE se calcula sin la elección que estoy probando (leave-one-out). Si no, sería hacer trampa.
• Geografía: los ratios salen de la elección anterior, no de la propia. Usar la propia sería darle la respuesta al simulador.
• Ruido provincial: el shock de producción (los dos efectos con los τ del posterior de brms), no la Dirichlet jubilada. Con la Dirichlet las cifras agregadas salen casi iguales: a nivel nacional el ruido provincial se cancela; donde se nota de verdad es en el reparto provincial, que es lo que valida la revalidación de más arriba.

Umbral del 3% y D’Hondt, como en producción.

# el backtest completo (baja 10 elecciones de infoelectoral y corre 2.000
# muestras por elección) vive en backtest_pipeline.R; aquí leo sus salidas
# congeladas. Configuración: geografía de la elección anterior, mu encogido
# a la mitad, semilla fija en el script
esc_bt <- read_csv(
  here::here("2026/10/backtest_escanos.csv"),
  show_col_types = FALSE
)
vot_bt <- read_csv(
  here::here("2026/10/backtest_votos.csv"),
  show_col_types = FALSE
)

# para las cifras en línea del texto
peor_esc <- esc_bt |>
  mutate(e = abs(mediana - real)) |>
  slice_max(e, n = 1)

bind_rows(
  vot_bt |> mutate(tipo = "voto"),
  esc_bt |> mutate(tipo = "escaños")
) |>
  group_by(tipo) |>
  summarise(
    celdas = n(),
    cobertura = mean(dentro),
    ancho_medio_ic90 = mean(q95 - q05),
    error_mediano = median(abs(mediana - real))
  ) |>
  mutate(across(where(is.numeric), \(x) round(x, 2)))
#> # A tibble: 2 × 5
#>   tipo    celdas cobertura ancho_medio_ic90 error_mediano
#>   <chr>    <dbl>     <dbl>            <dbl>         <dbl>
#> 1 escaños     18      0.94            26.0           7   
#> 2 voto        18      0.83             5.51          1.27

¿Qué sale? Pues bastante bien:

• La cobertura de los intervalos al 90% es del 94% en escaños (17 de 18) y del 83% en voto (15 de 18).
• El error mediano es de 7 escaños y 1,3 puntos.
• El peor caso es el 26J-2016, la elección con menos encuestas: al SUMAR —Unidos Podemos entonces— le doy 88 escaños y sacó 71.

read_csv(
  here::here("2026/10/backtest_resumen.csv"),
  show_col_types = FALSE
) |>
  filter(tipo == "P(derecha)") |>
  select(
    Elección = eleccion,
    Encuestas = n_encuestas,
    `PP+VOX real` = real_derecha,
    `P(PP+VOX >= 176)` = p_derecha_176
  ) |>
  mutate(`P(PP+VOX >= 176)` = scales::percent(`P(PP+VOX >= 176)`, 0.1))
#> # A tibble: 5 × 4
#>   Elección Encuestas `PP+VOX real` `P(PP+VOX >= 176)`
#>   <chr>        <dbl>         <dbl> <chr>             
#> 1 20d             12           121 0.0%              
#> 2 26j              2           135 0.0%              
#> 3 28a             20            90 0.0%              
#> 4 10n             30           141 0.0%              
#> 5 23j             60           170 0.0%

Ojo, esto es sólo un ejercicio de que más o menos la maquinaria funciona, que dados porcentajes nacionales de voto (en las encuestas), el mecanismo de asignar a provincias, tomando prestada la distribución de las anteriores elecciones y la asignación de escaños, funciona. Eso no asegura que las encuestas actuales acierten, pueden pasar cientos de cosas.

Y en bloques

El bloque de investidura de 2023 (los grupos que apoyaron a Sánchez) contra la derecha: si las encuestas no se mueven, la repetición de la aritmética de la anterior legislatura no llega.

Si pensáis en otras alianzas, simplemente hay que cambiar las sumas aquí, o si al final se presenta el frente amplio habría que sumar los porcentajes de voto antes de hacer el modelo 1, además, que puede haber un efecto sinérgico de que al ir unidos aumente su % de voto más que simplemente sumar el de cada partido por separado. Si al final se presentan conjuntamente, las encuestas subsiguientes podrían recoger ese efecto.

bloques(sim$draws) |>
  mutate(
    # aquí la derecha lleva a UPN: es el bloque con el que gobernaría, y UPN
    # (1 escaño) se integra con el PP en Navarra
    derecha = PP + VOX + UPN,
    investidura = PSOE + SUMAR + ERC + Junts + `EH Bildu` + PNV + BNG + CC
  ) |>
  select(.draw, derecha, investidura) |>
  pivot_longer(-.draw, names_to = "bloque", values_to = "escanos") |>
  mutate(bloque = fct_relevel(bloque, "derecha", "investidura")) |>
  ggplot(aes(x = escanos, y = bloque, fill = bloque)) +
  stat_halfeye(
    density = "histogram",
    breaks = ggdist::breaks_fixed(width = 2),
    align = ggdist::align_center(at = 0),
    normalize = "groups",
    .width = c(0.5, 0.9),
    alpha = 0.8
  ) +
  # etiqueta con la mediana de cada bloque
  stat_summary(
    fun = median,
    geom = "label",
    aes(label = after_stat(x), fill = NULL),
    size = 3,
    fill = "white"
  ) +
  scale_fill_manual(
    values = c(derecha = "#005999", investidura = "#A00B85"),
    guide = "none"
  ) +
  geom_vline(xintercept = 176, linetype = "dashed", color = "red") +
  labs(
    title = "Bloque de la derecha y bloque de investidura",
    subtitle = "Derecha = PP + VOX + UPN · Investidura = PSOE + SUMAR + ERC + Junts + EH Bildu + PNV + BNG + CC (los grupos de 2023)",
    x = "Escaños",
    y = NULL
  )

La arquitectura en cascada

Vale, si tuviera datos de estimaciones de partidos regionales en la mayoría de las encuestas podría plantearme un modelo multinomial con 13 categorías (los 5 grandes + SALF + 7 regionales + resto). Pero como no es así, propongo hacer dos modelos en cascada.

• Modelo 1: multinomial de 6 categorías: PP, PSOE, VOX, SUMAR (= Sumar + Podemos), SALF y BLOQUE (todo lo demás). Entran todas las encuestas que reportan los 6 principales.
• Modelo 2 (la composición): multinomial condicional de 8 subceldas dentro del BLOQUE: Junts, ERC, PNV, EH Bildu, BNG, CC, UPN y RESTO. Solo entran las encuestas completas.

En la simulación, cada muestra del posterior del modelo 1 fija el tamaño del BLOQUE y se reparte con la composición del modelo 2.

Resultado: 13 valores que suman 100 con la distribución conservada.

Para el modelo 1 he quitado encuestas del CIS (su cocina electoral es muy distinta y se necesitaría corregir el sesgo por recuerdo de voto que el CIS decidió no hacerlo) y las de ElectoPanel (que sí se utilizan para el modelo 2 por ser de las pocas que dan estimaciones de partidos regionales). Otra decisión que he tomado es considerar solo las encuestas desde el 1 de julio de 2026 en adelante

# las cifras del texto salen de las mismas funciones que alimentan el
# ajuste: se actualizan solas cuando entren encuestas nuevas
source(here::here("2026/10/ajustar_meta.R"))

dat_g <- prep_grande()
#> Fuera (sin n publicado): 1 encuestas — InvyMark 
#> Fuera (casas_fuera: CIS, ElectoPanel ): 17 encuestas
dat_b <- prep_bloque()

n_enc_m1 <- nrow(dat_g)
n_casas_m1 <- n_distinct(dat_g$encuestadora)
n_enc_m2 <- nrow(dat_b)
n_casas_m2 <- n_distinct(dat_b$encuestadora)
# peso de ElectoPanel en los votos del bloque del modelo 2
pct_ep_m2 <- sum(dat_b$bloque_votos[dat_b$encuestadora == "ElectoPanel"]) /
  sum(dat_b$bloque_votos)

cat("Modelo 1:", n_enc_m1, "encuestas,", n_casas_m1, "casas\n")
#> Modelo 1: 28 encuestas, 14 casas
cat("Modelo 2:", n_enc_m2, "encuestas,", n_casas_m2, "casas\n")
#> Modelo 2: 97 encuestas, 10 casas

Update (a 12/10/2026): el modelo 1 se ajusta con 28 encuestas de 14 casas, tras quitar el CIS, ElectoPanel y las encuestas sin tamaño muestral publicado. Conforme se vayan acercando las fechas de las elecciones iré añadiendo más (el script de descarga está preparado para eso).

El encaje de los dos modelos, con un ejemplo de juguete

La parte menos obvia del invento es cómo se pegan los dos modelos, aunque en realidad es sencilla.

Qué entrena el modelo 2. Es un multinomial condicional: el trials de su fórmula no es la muestra completa de la encuesta, sino los votos totales del BLOQUE en esa encuesta. Por ejemplo, una encuesta con n = 1.000 y un bloque del 11% entra al modelo 2 como 110 votos repartidos en 8 celdas:

# una encuesta con n = 1.000 y BLOQUE = 11% entra al modelo 2 así:
encuesta <- c(
  ERC = 42,
  Junts = 18,
  PNV = 13,
  EH_Bildu = 15,
  BNG = 8,
  CC = 5,
  UPN = 2,
  RESTO = 7
)
sum(encuesta) # <- el trials del modelo 2: los votos del bloque, no la muestra
#> [1] 110

El modelo 2 ni sabe ni le importa cuánto pesa el bloque: solo aprende en qué proporción se reparte dentro de él (y cómo deriva con el tiempo). El peso del bloque lo estima el modelo 1, que ve muchas más encuestas. Una muestra del modelo 2 es, a efectos prácticos, un vector de proporciones condicionales como este:

c2 <- encuesta / sum(encuesta)
round(c2, 2)
#>      ERC    Junts      PNV EH_Bildu      BNG       CC      UPN    RESTO 
#>     0.38     0.16     0.12     0.14     0.07     0.05     0.02     0.06

Cómo se pegan. En la simulación, cada muestra del modelo 1 aporta el tamaño del BLOQUE y una muestra del modelo 2 aporta su composición interna. Se multiplican y punto:

# una muestra (inventada) del modelo 1: los 6 grandes
d1 <- c(
  PP = 32.6,
  PSOE = 27.1,
  VOX = 19.2,
  SUMAR = 8.0,
  SALF = 1.8,
  BLOQUE = 11.3
)

bloque <- unname(d1["BLOQUE"])
draw13 <- c(d1[1:5], bloque * c2)
round(draw13, 1)
#>       PP     PSOE      VOX    SUMAR     SALF      ERC    Junts      PNV 
#>     32.6     27.1     19.2      8.0      1.8      4.3      1.8      1.3 
#> EH_Bildu      BNG       CC      UPN    RESTO 
#>      1.5      0.8      0.5      0.2      0.7
sum(draw13)
#> [1] 100

Las muestras de los dos modelos se generan por separado y se emparejan por índice: se asume que el tamaño del bloque y su composición interna no están correlacionadas. Un modelo único de 13 categorías las acoplaría si en la realidad lo estuvieran, pero es justo lo que no podemos ajustar: solo pocas encuestas reportan las 13 categorías y casi todas de la misma casa (electopanel). Hacerlo en dos modelos divide el problema en 2, puede que no sea lo más estadísticamente correcto, pero es práctico.

Estimación para el día de las elecciones

Evaluamos el modelo en el time de la fecha electoral con los efectos casa en su media (re_formula = NA): lo que el modelo sabe decir es dónde estaría la media de las encuestadoras ese día, y la distancia hasta el resultado real la pone la capa de error histórico de la segunda parte.

Podríamos haber considerado que el día de las elecciones era como una encuesta más hecha por una empresa nueva, y habríamos usado allow_new_levels, pero añadiría incertidumbre. Poniendo re_formula = NA asumimos que el sesgo de unas empresas se compensan con las de otras. Puede no ser así, pero para eso habría que analizar el error histórico por empresa (que no hago), en la segunda parte vemos error histórico de las encuestas en general.

time_e <- as.numeric(as.Date("2026-11-29") - as.Date("2026-07-01"))

estimaciones <- tibble(
  time = time_e,
  n = 1
) |>
  add_epred_draws(mod_g, ndraws = 4000, re_formula = NA) |>
  rename(partido = .category, estim = .epred) |>
  ungroup() |>
  mutate(estim = estim * 100)

est_nac <- estimaciones |>
  group_by(partido) |>
  summarise(
    mediana = median(estim),
    ic90_low = quantile(estim, 0.05),
    ic90_high = quantile(estim, 0.95)
  ) |>
  mutate(across(mediana:ic90_high, \(x) round(x, 2)))

# para las cifras en línea del texto
f_est <- function(partido) {
  d <- est_nac |> filter(partido == .env$partido)
  str_c(
    format(round(d$mediana, 1), nsmall = 1),
    " [",
    format(round(d$ic90_low, 1), nsmall = 1),
    ", ",
    format(round(d$ic90_high, 1), nsmall = 1),
    "]"
  )
}

est_nac
#> # A tibble: 6 × 4
#>   partido mediana ic90_low ic90_high
#>   <fct>     <dbl>    <dbl>     <dbl>
#> 1 PP        32.1     30.9      33.3 
#> 2 PSOE      26.4     25.2      27.6 
#> 3 VOX       19.4     18.3      20.6 
#> 4 SUMAR      8.94     8.16      9.84
#> 5 SALF       1.57     1.26      1.93
#> 6 BLOQUE    11.6     10.7      12.6

Esta tabla es el resultado de la primera parte (en el PP 32.1 [30.9, 33.3] y el PSOE 26.4 [25.2, 27.6] va el grueso de la historia): son los porcentajes que entran, muestra a muestra, en la simulación de escaños de la segunda parte. Como siempre que se agregan encuestas, la media de las encuestadoras no tiene por qué ser el resultado real; de eso se ocupa la capa de error de la segunda parte.

colores <- c(
  "PP" = "#005999",
  "PSOE" = "#FF0126",
  "VOX" = "#51962A",
  "SUMAR" = "#A00B85",
  "SALF" = "#00C3B6",
  "BLOQUE" = "grey50"
)

# me quito el "OTROS"
estimaciones |>
  filter(partido != "BLOQUE") |>
  ggplot(aes(x = estim, fill = partido)) +
  geom_density(alpha = 0.5) +
  scale_fill_manual(values = colores) +
  labs(
    title = "Meta-análisis generales 2026. Estimación día de las elecciones",
    subtitle = paste0(
      "Modelo 1: ",
      nrow(mod_g$data),
      " encuestas, ",
      n_distinct(mod_g$data$encuestadora),
      " casas, ventana jul-oct 2026"
    ),
    x = "Porcentaje estimado",
    y = "Densidad"
  )

El ajuste del modelo 2

El modelo 2 es un multinomial condicional de las 8 subceldas del BLOQUE (Junts, ERC, PNV, EH Bildu, BNG, CC, UPN y RESTO), con trials igual a los votos totales del bloque de cada encuesta, no a su muestra completa: solo aprende cómo se reparte dentro del bloque. Lleva la misma familia de priors que el modelo 1 (Normal(0, 2) en log-odds, Exponential(1) para las sd), pero dos diferencias importantes:

• No lleva efecto casa: en su ventana (desde junio de 2025) hay 10 casas que reportan los 7 regionales (el relleno con objetivo176 las pasó de 7 a 10), pero ElectoPanel concentra el 63% del peso. Un efecto aleatorio con niveles tan desbalanceados sería ruido, no información; la composición se modela como tendencia temporal común. El CIS, con sus regionales ahora disponibles vía objetivo176, sigue fuera: sus muestras enormes llevarían el 32% del peso y su metodología (recuerdo de voto) es la misma que motivó sacarlo del modelo 1.
• La ventana es larga (jun 2025 →) a diferencia del modelo 1 (jul 2026 →): con pocas encuestas en tres meses no hay de dónde colgar una tendencia, así que de momento le dejamos el histórico.

mod_b <- ajustar_bloque(refit = TRUE)
#> Running MCMC with 4 parallel chains...
#> Chain 2 finished in 21.5 seconds.
#> Chain 4 finished in 21.9 seconds.
#> Chain 3 finished in 22.4 seconds.
#> Chain 1 finished in 23.2 seconds.
#> 
#> All 4 chains finished successfully.
#> Mean chain execution time: 22.3 seconds.
#> Total execution time: 23.2 seconds.
formula(mod_b)
#> cell_counts | trials(bloque) ~ time

s_b <- summary(mod_b)
as.data.frame(s_b$fixed) |>
  tibble::rownames_to_column("param") |>
  select(param, Estimate, Est.Error, Rhat, Bulk_ESS, Tail_ESS) |>
  mutate(across(where(is.numeric), \(x) round(x, 3)))
#>                  param Estimate Est.Error  Rhat  Bulk_ESS  Tail_ESS
#> 1      muERC_Intercept    0.397     0.125 1.000  5875.325  7528.261
#> 2      muPNV_Intercept   -0.294     0.150 1.001  6022.301  8641.477
#> 3  muEHBildu_Intercept   -0.028     0.139 1.000  5119.782  7834.319
#> 4      muBNG_Intercept   -0.397     0.154 1.000  6217.005  8007.716
#> 5       muCC_Intercept   -1.046     0.192 1.001  6975.747  9256.678
#> 6      muUPN_Intercept   -3.322     0.498 1.000  9978.178  8298.107
#> 7    muRESTO_Intercept    1.025     0.114 1.001  5188.370  6856.598
#> 8           muERC_time    0.001     0.001 1.000 15961.843 10130.250
#> 9           muPNV_time    0.000     0.001 1.000 13370.075 10030.893
#> 10      muEHBildu_time    0.001     0.001 1.000 15020.182 10236.925
#> 11          muBNG_time    0.001     0.001 1.000 14018.365 10311.795
#> 12           muCC_time    0.001     0.001 1.000 15024.091  9974.537
#> 13          muUPN_time    0.001     0.002 1.001 14535.204  8121.613
#> 14        muRESTO_time    0.001     0.000 1.000 14816.538 10308.177

Ojo a la parametrización: la primera subcelda, Junts, es la referencia del multinomial, así que los coeficientes son log-odds de cada regional frente a Junts y las pendientes de time describen cómo cambia ese reparto interno con el tiempo.

No se llega a tener datos de todas las combinaciones

Si cruzo comunidad, sexo, edad y estudios salen 19 × 2 × 7 × 3 = 798 combinaciones posibles o celdas, para entendernos. Veamos cuántas personas hay en cada celda con datos.

En esta primera parte agrupo los partidos regionales dentro de OTROS y me quedo con cinco categorías. Para ver qué hace un modelo multinivel no hacen falta más, y los gráficos se leen mejor:

dat_dem <- dat |>
  mutate(voto = fct_other(voto, keep = voto5_lv[-5], other_level = "OTROS"))

count(dat_dem, voto)
#> # A tibble: 5 × 2
#>   voto      n
#>   <fct> <int>
#> 1 PP      804
#> 2 PSOE    889
#> 3 VOX     452
#> 4 SUMAR   333
#> 5 OTROS   650

celdas_dem <- dat_dem |>
  count(ccaa, sexo, edad, edu, voto) |>
  pivot_wider(names_from = voto, values_from = n, values_fill = 0)

celdas_dem$y <- as.matrix(celdas_dem[, voto5_lv])
celdas_dem$n <- rowSums(celdas_dem$y)

nrow(celdas_dem)
#> [1] 544

table(cut(celdas_dem$n, c(0, 1, 2, 3, 5, 10, Inf)))
#> 
#>    (0,1]    (1,2]    (2,3]    (3,5]   (5,10] (10,Inf] 
#>      134       96       70       75       94       75

Solo 544 de las 798 celdas tienen alguna entrevista. De esas, 230 tienen una o dos personas. Estimar la intención de voto celda a celda, con su proporción bruta, no tiene sentido. Hay que ajustar un modelo que use información de unas celdas para otras.

Por comunidad pasa lo mismo

n_ccaa <- dat |> count(ccaa, name = "n_ccaa") |> arrange(n_ccaa)
n_ccaa
#> # A tibble: 19 × 2
#>    ccaa                 n_ccaa
#>    <fct>                 <int>
#>  1 Ceuta                    16
#>  2 Melilla                  17
#>  3 Navarra                  61
#>  4 Cantabria                71
#>  5 Extremadura              73
#>  6 La Rioja                 75
#>  7 Aragón                   77
#>  8 Asturias                 78
#>  9 Baleares                 83
#> 10 Murcia                   88
#> 11 País Vasco              133
#> 12 Castilla-La Mancha      134
#> 13 Canarias                148
#> 14 Castilla y León         156
#> 15 Galicia                 176
#> 16 Comunitat Valenciana    300
#> 17 Madrid                  450
#> 18 Cataluña                458
#> 19 Andalucía               534

Ceuta y Melilla tienen 16 y 17 entrevistas. Andalucía, 534.

Dos modelos

Do modelos multinomiales con las mismas variables. Lo único que cambia es cómo tratan las variables categóricas.

• Efectos fijos (nnet::multinom): cada comunidad tiene su coeficiente y se estima solo con sus datos. Es lo que se conoce como no pooling.
• Multinivel (brms): los coeficientes de comunidad, edad y estudios salen de una distribución normal común, con su desviación típica estimada. Es el partial pooling.

mod_fe <- multinom(
  voto ~ sexo + edad + edu + ccaa,
  data = dat_dem,
  trace = FALSE,
  maxit = 500
)

El modelo multinivel se ajusta sobre los datos agregados por celda, con trials(n). Da lo mismo que ajustarlo sobre cada persona y es mucho más rápido. Ver post antiguo

# Las mismas priors para cada partido (cada uno es un "mu" respecto al PP)
priors_multinom <- function(partidos) {
  Reduce(
    `+`,
    lapply(paste0("mu", partidos[-1]), function(dp) {
      prior_string("normal(0, 1.5)", class = "Intercept", dpar = dp) +
        prior_string("normal(0, 1)", class = "b", dpar = dp) +
        prior_string("exponential(1)", class = "sd", dpar = dp)
    })
  )
}

priors_dem <- priors_multinom(voto5_lv)
priors_dem
#>           prior     class coef group resp    dpar nlpar   lb   ub tag source
#>  normal(0, 1.5) Intercept                  muPSOE       <NA> <NA>       user
#>    normal(0, 1)         b                  muPSOE       <NA> <NA>       user
#>  exponential(1)        sd                  muPSOE       <NA> <NA>       user
#>  normal(0, 1.5) Intercept                   muVOX       <NA> <NA>       user
#>    normal(0, 1)         b                   muVOX       <NA> <NA>       user
#>  exponential(1)        sd                   muVOX       <NA> <NA>       user
#>  normal(0, 1.5) Intercept                 muSUMAR       <NA> <NA>       user
#>    normal(0, 1)         b                 muSUMAR       <NA> <NA>       user
#>  exponential(1)        sd                 muSUMAR       <NA> <NA>       user
#>  normal(0, 1.5) Intercept                 muOTROS       <NA> <NA>       user
#>    normal(0, 1)         b                 muOTROS       <NA> <NA>       user
#>  exponential(1)        sd                 muOTROS       <NA> <NA>       user

mod_dem <- brm(
  y | trials(n) ~ sexo + (1 | edad) + (1 | edu) + (1 | ccaa),
  data = celdas_dem,
  family = multinomial(),
  prior = priors_dem,
  chains = 4,
  cores = 4,
  iter = 2000,
  refresh = 0,
  silent = 2,
  control = list(adapt_delta = 0.95),
  backend = "cmdstanr",
  seed = 2026,
  file = file.path(dir_datos, "mod_sin_rec")
)

La categoría de referencia es el PP. Así que cada partido tiene su propio conjunto de coeficientes, en escala logit respecto al PP.

El efecto de cada comunidad

Veamos el coeficiente de cada comunidad en los dos modelos. En el de efectos fijos los coeficientes van respecto a Andalucía, así que los centro restando su mediana para que sean comparables con los efectos aleatorios del multinivel, que ya están centrados en 0.

coef_fe <- coef(mod_fe)[, grep("^ccaa", colnames(coef(mod_fe)))]
coef_fe <- cbind(ccaaAndalucía = 0, coef_fe) # Andalucía es la referencia
colnames(coef_fe) <- sub("^ccaa", "", colnames(coef_fe))

efectos_fe <- as_tibble(coef_fe, rownames = "partido") |>
  pivot_longer(-partido, names_to = "ccaa", values_to = "efecto") |>
  group_by(partido) |>
  mutate(efecto = efecto - median(efecto), modelo = "efectos fijos") |>
  ungroup()

re_ccaa <- ranef(mod_dem)$ccaa
efectos_ml <- map_dfr(voto5_lv[-1], function(p) {
  tibble(
    partido = p,
    ccaa = rownames(re_ccaa),
    efecto = re_ccaa[, "Estimate", paste0("mu", p, "_Intercept")],
    modelo = "multinivel"
  )
})

efectos <- bind_rows(efectos_fe, efectos_ml) |>
  left_join(n_ccaa |> mutate(ccaa = as.character(ccaa)), by = "ccaa") |>
  mutate(partido = factor(partido, levels = voto5_lv[-1]))

efectos |>
  filter(ccaa %in% c("Ceuta", "Melilla")) |>
  select(ccaa, partido, modelo, efecto) |>
  pivot_wider(names_from = modelo, values_from = efecto)
#> # A tibble: 8 × 4
#>   ccaa    partido `efectos fijos` multinivel
#>   <chr>   <fct>             <dbl>      <dbl>
#> 1 Ceuta   PSOE            -1.06      -0.189 
#> 2 Melilla PSOE             0          0.0462
#> 3 Ceuta   VOX              1.33       0.0943
#> 4 Melilla VOX             -0.770     -0.0175
#> 5 Ceuta   SUMAR           -0.0236    -0.0549
#> 6 Melilla SUMAR           -9.81      -0.150 
#> 7 Ceuta   OTROS            0.841      0.175 
#> 8 Melilla OTROS           -0.726     -0.316

En Melilla no hay ningún votante de SUMAR entre sus 17 entrevistas. El modelo de efectos fijos hace lo que le pedimos: busca el coeficiente que mejor ajusta esos datos. Y el que mejor ajusta un 0 es “menos infinito”. Se queda en −9,8 porque el optimizador se para. El multinivel no se cree que un 0 de 17 signifique que en Melilla nadie vota a SUMAR, y deja el efecto cerca de 0.

Ceuta tiene el problema contrario: 7 de sus 16 entrevistados votarían a VOX. Con efectos fijos, su efecto en VOX es 1,33. El multinivel lo deja en 0,09.

Lo vemos para todas las comunidades, ordenadas por tamaño muestral. Recorto el eje horizontal para que no se coma el gráfico el valor de Melilla.

efectos |>
  mutate(ccaa = fct_reorder(ccaa, n_ccaa)) |>
  ggplot(aes(x = efecto, y = ccaa, color = modelo)) +
  geom_vline(xintercept = 0, linetype = "dashed", color = "grey50") +
  geom_line(aes(group = ccaa), color = "grey70") +
  geom_point(size = 2) +
  facet_wrap(~partido, nrow = 1) +
  coord_cartesian(xlim = c(-2.2, 2.2)) +
  scale_color_manual(
    values = c("efectos fijos" = "firebrick", "multinivel" = "steelblue")
  ) +
  labs(
    x = "Efecto de la comunidad (logit respecto al PP, centrado)",
    y = NULL,
    color = NULL,
    title = "Efecto de cada comunidad en los dos modelos",
    subtitle = "Ordenadas de menos (abajo) a más entrevistas (arriba)"
  ) +
  theme_minimal() +
  theme(legend.position = "top")

Los puntos azules están más cerca del 0 que los rojos. Eso es el partial pooling, también llamado shrinkage o contracción: cada efecto de comunidad se acerca a la media de todas. Y no todas se acercan lo mismo. En el gráfico las comunidades con pocas entrevistas se quedan casi en el 0. Arriba, Cataluña y País Vasco mantienen buena parte de su efecto en OTROS, donde están ERC, Junts, PNV y Bildu.

Llamamos contracción a 1 − efecto multinivel / efecto fijos. Vale 0 si el multinivel deja el efecto como está y 1 si lo lleva a 0. Para los efectos fijos mayores de 0,2 en valor absoluto; con efectos casi nulos el cociente no significa nada.

efectos |>
  select(ccaa, partido, modelo, efecto, n_ccaa) |>
  pivot_wider(names_from = modelo, values_from = efecto) |>
  filter(abs(`efectos fijos`) > 0.2) |>
  mutate(
    contraccion = 1 - multinivel / `efectos fijos`,
    entrevistas = cut(
      n_ccaa,
      c(0, 20, 100, 200, Inf),
      labels = c("≤ 20", "21-100", "101-200", "> 200")
    )
  ) |>
  group_by(entrevistas) |>
  summarise(
    contraccion_mediana = median(contraccion),
    n_efectos = n()
  ) |>
  gt() |>
  cols_label(
    entrevistas = "Entrevistas en la comunidad",
    contraccion_mediana = "Contracción mediana",
    n_efectos = "Nº de efectos"
  ) |>
  fmt_percent(contraccion_mediana, decimals = 0, locale = "es") |>
  cols_align("center", -entrevistas)

Cuantas menos entrevistas, más contracción: casi un 90 % en Ceuta y Melilla, y la mitad en las comunidades con más de 200 entrevistas. El modelo decide cuánto contraer cada efecto con dos cosas:

1. Cuántos datos tiene la comunidad. Con pocas entrevistas, su estimación propia es poco fiable y el modelo se fía más de la media.
2. Cuánto varían las comunidades entre sí. Es la desviación típica de los efectos de comunidad, y también la estima el modelo.

VarCorr(mod_dem)$ccaa$sd |> round(2)
#>                   Estimate Est.Error Q2.5 Q97.5
#> muPSOE_Intercept      0.26      0.07 0.14  0.43
#> muVOX_Intercept       0.13      0.09 0.01  0.33
#> muSUMAR_Intercept     0.29      0.11 0.10  0.53
#> muOTROS_Intercept     0.71      0.14 0.49  1.04

En OTROS la desviación típica es la mayor, 0,71. Las comunidades difieren de verdad en el voto a partidos regionales, y el modelo deja que se separen más.

Y en una celda concreta

Al final lo que vamos a usar son predicciones por celda. Tomo dos celdas de Ceuta en las que no hay ninguna entrevista:

nd <- tibble(
  ccaa = c("Ceuta", "Ceuta"),
  sexo = c("H", "M"),
  edad = c("65+", "25-34"),
  edu = c("baja", "media"),
  n = 1
) |>
  mutate(
    ccaa = factor(ccaa, levels = levels(dat$ccaa)),
    sexo = factor(sexo, levels = levels(dat$sexo)),
    edad = factor(edad, levels = levels(dat$edad)),
    edu = factor(edu, levels = levels(dat$edu))
  )

nd
#> # A tibble: 2 × 5
#>   ccaa  sexo  edad  edu       n
#>   <fct> <fct> <fct> <fct> <dbl>
#> 1 Ceuta H     65+   baja      1
#> 2 Ceuta M     25-34 media     1

# ¿Hay alguien en estas celdas?
dat |> semi_join(nd, by = c("ccaa", "sexo", "edad", "edu")) |> nrow()
#> [1] 0

Ninguna de las dos tiene datos, pero los dos modelos pueden predecir. Combinan lo que saben de cada sexo, cada tramo de edad, cada nivel de estudios y de la gente de Ceuta.

pred_fe <- predict(mod_fe, newdata = nd, type = "probs")
pred_ml <- apply(posterior_epred(mod_dem, newdata = nd), c(2, 3), mean)

nombre_celda <- c(
  "Ceuta · hombre · 65+ · estudios bajos",
  "Ceuta · mujer · 25-34 · estudios medios"
)

bind_rows(
  as_tibble(pred_fe) |> mutate(celda = nombre_celda, modelo = "efectos fijos"),
  as_tibble(pred_ml) |> mutate(celda = nombre_celda, modelo = "multinivel")
) |>
  arrange(celda) |>
  mutate(across(all_of(voto5_lv), ~ 100 * .x)) |>
  gt(groupname_col = "celda", rowname_col = "modelo") |>
  tab_spanner("% de voto predicho", columns = all_of(voto5_lv)) |>
  fmt_number(all_of(voto5_lv), decimals = 1, locale = "es") |>
  tab_style(
    style = cell_text(weight = "bold"),
    locations = cells_body(columns = c(VOX, SUMAR))
  )

Las diferencias son grandes. El modelo de efectos fijos se cree del todo los 7 votantes de VOX de 16 entrevistas, y le da a VOX un 35 % en la primera celda y un 59 % en la segunda. El multinivel lo modera: VOX baja al 12 % y al 27 %.

¿Cuál está bien? No lo sabemos, porque en esas celdas no hay nadie. Pero un 59 % de VOX en una celda sin datos, sacado de 16 entrevistas de toda Ceuta, no es creíble.

Cuando sumemos cientos de celdas en la postestratificación, esos ceros y esos extremos se acumulan. Por eso la M de MRP es multinivel.

¿Y el recuerdo de voto?

El modelo que voy a usar para la estimación final sí lleva el recuerdo de voto. Hay dos razones:

1. Es, con diferencia, la variable que más explica la intención de voto actual.
2. Solo se puede postestratificar por las variables que están en el modelo. Si el modelo no usa el recuerdo, corregir en la población cuánta gente votó a cada partido en 2023 no cambia nada en la estimación.

La segunda razón es la importante para lo que viene: la encuesta del CIS tiene el recuerdo de voto bastante desviado respecto a lo que salió en las urnas.

Entonces, ¿qué hago?

El modelo multinivel ya usa sexo, edad, estudios, comunidad y recuerdo. Así que, si la encuesta tiene demasiada gente con estudios altos o demasiados votantes del PSOE, el modelo no se equivoca por eso al predecir en cada celda. El problema está en cuánto pesa cada celda al sumar.

Ese peso tiene que salir de la población, no de la encuesta. Y es lo que hace la P de MRP: multiplicar la predicción de cada celda por cuánta gente hay en esa celda en la población real. Para eso hace falta saber cuánta gente hay en cada combinación de comunidad, sexo, edad, estudios y recuerdo. Esa tabla no la publica nadie. Solo tenemos las tablas por separado que acabamos de ver, y con ellas la vamos a construir mediante raking.

Raking con dos variables

Antes de ir a las cinco dimensiones, lo veo con dos: estudios y recuerdo. Parto de la tabla cruzada de la encuesta, que llamo semilla:

library(mipfp)

semilla_2d <- xtabs(~ edu + rec, cis)
semilla_2d
#>        rec
#> edu      PP PSOE VOX SUMAR ERC JUNTS BILDU PNV BNG CCA OTROS ABST NO_PODIA
#>   baja  107  206  40    43   8     3     2   0   2   1    26  114       10
#>   media 168  233  81    97  14    11     9   7   5   3    41  107       89
#>   alta  608  745 228   346  54    33    36  17  24   8   205  279        8

Y tengo los dos marginales de la población, que es lo que la tabla tiene que cumplir:

obj_edu <- xtabs(N ~ edu, tg$edu_sexo_ccaa)
obj_rec <- xtabs(N ~ rec, tg$rec_ccaa)

obj_edu
#> edu
#>     baja    media     alta 
#> 15638656  8598849 12592200
obj_rec
#> rec
#>       PP     PSOE      VOX    SUMAR      ERC    JUNTS    BILDU      PNV 
#>  8093469  7762316  3034117  3014755   462890   392609   333321   275859 
#>      BNG      CCA    OTROS     ABST NO_PODIA 
#>   152348   114707  1107831 10396976  1688507

El IPF hace algo muy sencillo:

1. Reescala las filas de la semilla para que sumen el marginal de estudios.
2. Reescala las columnas para que sumen el marginal de recuerdo. Al hacerlo, las filas dejan de cuadrar un poco.
3. Repite los pasos 1 y 2 hasta que filas y columnas cuadran a la vez.

Con mipfp::Ipfp le paso la semilla, qué dimensiones tiene cada objetivo y los objetivos. Trabajo en proporciones y luego multiplico por el total, porque Ipfp exige que todos los objetivos sumen exactamente lo mismo y los redondeos dan problemas.

ipf_2d <- Ipfp(
  seed = semilla_2d / sum(semilla_2d),
  target.list = list(1, 2), # dimensión 1 = edu, dimensión 2 = rec
  target.data = list(obj_edu / sum(obj_edu), obj_rec / sum(obj_rec)),
  tol = 1e-10
)

tabla_2d <- ipf_2d$x.hat * sum(obj_rec)
round(tabla_2d / 1000) # en miles de personas
#>        rec
#> edu       PP PSOE  VOX SUMAR  ERC JUNTS BILDU  PNV  BNG  CCA OTROS ABST
#>   baja  3060 3707 1079   902  159    89    55    0   36   32   361 5769
#>   media 1718 1499  782   728   99   117    89  120   33   34   204 1936
#>   alta  3315 2556 1173  1384  205   187   189  156   83   49   543 2692
#>        rec
#> edu     NO_PODIA
#>   baja       389
#>   media     1240
#>   alta        59

La tabla ya suma por filas lo que dice la EPA y por columnas lo que dicen las urnas. ¿Qué se queda de la encuesta? La asociación entre las dos variables. Lo veo con la razón de odds (odds ratio) de votar al PP frente al PSOE entre estudios altos y bajos:

odds_ratio <- function(t) {
  (t["alta", "PP"] * t["baja", "PSOE"]) / (t["alta", "PSOE"] * t["baja", "PP"])
}

c(semilla = odds_ratio(semilla_2d), raking = odds_ratio(tabla_2d))
#>  semilla   raking 
#> 1.571197 1.571197

Es exactamente la misma. El raking cambia los totales y respeta las asociaciones que había en la semilla. Esa es su hipótesis de fondo: la estructura de la encuesta es buena, lo que falla son las proporciones. Lo que no está en ningún marginal, como la relación entre estudios y recuerdo, lo pone la encuesta.

Raking con cinco variables

Con las cinco variables la idea es la misma, pero la semilla tiene 19 × 2 × 7 × 3 × 13 = 10.374 celdas, y la encuesta tiene 4.018 entrevistas:

semilla_enc <- xtabs(~ ccaa + sexo + edad + edu + rec, cis)
dn <- dimnames(semilla_enc)

mean(semilla_enc == 0)
#> [1] 0.835936

El 84 % de las celdas de la semilla están vacías. Y el IPF solo multiplica: una celda que empieza a 0 se queda a 0. Si uso la encuesta tal cual, la tabla dirá que en la población no hay nadie en esas celdas, y casi todas tienen gente. Así que mezclo la encuesta con una tabla uniforme, a partes iguales:

alpha <- 0.5
semilla <- alpha *
  array(1, dim(semilla_enc), dn) /
  length(semilla_enc) +
  (1 - alpha) * semilla_enc / sum(semilla_enc)

Hay celdas que sí tienen que valer 0: son los ceros estructurales. Hay dos tipos:

1. Por edad. Quien tiene hoy 18-20 años no pudo votar el 23-J, así que su recuerdo es siempre NO_PODIA. Y quien tiene más de 20 años no puede estar en NO_PODIA.
2. Por territorio. Nadie pudo votar a ERC fuera de Cataluña, ni al BNG fuera de Galicia.

Los pongo a mano y el IPF los respeta:

i18 <- which(dn$edad == "18-20")
inp <- which(dn$rec == "NO_PODIA")

semilla[,, i18, , -inp] <- 0 # 18-20 con cualquier recuerdo que no sea NO_PODIA
semilla[,, -i18, , inp] <- 0 # NO_PODIA con más de 20 años

# AC no existe en el recuerdo, así que solo los partidos que sí están en rec
for (p in intersect(names(territorio), dn$rec)) {
  semilla[!dn$ccaa %in% territorio[[p]], , , , p] <- 0 # partido fuera de su comunidad
}

mean(semilla == 0)
#> [1] 0.5691151

Ahora los objetivos. En el ejemplo de dos variables eran marginales de una sola variable. Aquí no: las fuentes publican tablas cruzadas, y eso es oro para el IPF. El INE da la población por sexo y edad y comunidad, no cada variable por separado. Así que los objetivos son tablas conjuntas de tres y dos variables:

t1 <- xtabs(N ~ ccaa + sexo + edad, tg$sexo_edad_ccaa) # ECP
t2 <- xtabs(N ~ ccaa + sexo + edu, tg$edu_sexo_ccaa) # EPA
t3 <- xtabs(N ~ ccaa + rec, tg$rec_ccaa) # 23-J

dim(t1)
#> [1] 19  2  7
dim(t2)
#> [1] 19  2  3
dim(t3)
#> [1] 19 13

t1 es un array de 19 × 2 × 7: para cada comunidad, una tabla de sexo por edad. Por ejemplo, Madrid, en miles de personas:

round(t1["Madrid", , ] / 1000)
#>     edad
#> sexo 18-20 21-24 25-34 35-44 45-54 55-64 65+
#>    H   106   146   390   402   479   393 492
#>    M   102   143   396   419   507   437 683

t2 es lo mismo con estudios en lugar de edad:

round(t2["Madrid", , ] / 1000)
#>     edu
#> sexo baja media alta
#>    H  805   574 1035
#>    M  922   671 1089

Y t3 es el recuerdo de voto de cada comunidad:

round(t3["Madrid", ] / 1000)
#>       PP     PSOE      VOX    SUMAR      ERC    JUNTS    BILDU      PNV 
#>     1444      994      500      551        0        0        0        0 
#>      BNG      CCA    OTROS     ABST NO_PODIA 
#>        0        0      106     1253      247

Cuanta más información conjunta dan las fuentes, menos tiene que inventar el raking. Con cinco variables hay diez pares posibles. Para cada par, la relación entre las dos variables sale de una fuente real o, si ningún objetivo las cruza, de la semilla, es decir, de la encuesta:

Seis de los diez pares los fijan fuentes oficiales. Los otros cuatro los pone la encuesta. Si encontrara una fuente con, por ejemplo, estudios por edad, la añadiría como cuarto objetivo y la encuesta tendría que poner un par menos.

Al llamar a Ipfp le digo qué dimensiones de la semilla toca cada objetivo. El orden de las dimensiones de la semilla es ccaa (1), sexo (2), edad (3), edu (4) y rec (5):

ipf <- Ipfp(
  seed = semilla / sum(semilla),
  target.list = list(
    c(1, 2, 3), # t1: ccaa, sexo, edad
    c(1, 2, 4), # t2: ccaa, sexo, edu
    c(1, 5) # t3: ccaa, rec
  ),
  target.data = list(t1 / sum(t1), t2 / sum(t2), t3 / sum(t3)),
  iter = 1000,
  tol = 1e-10
)

length(ipf$evol.stp.crit) # iteraciones
#> [1] 13

tabla <- ipf$x.hat * sum(tg$total_ccaa$total)
dim(tabla)
#> [1] 19  2  7  3 13

Compruebo que la tabla cumple los marginales. Por ejemplo, el de recuerdo:

tibble(
  rec = dn$rec,
  objetivo = as.numeric(apply(t3, 2, sum)),
  tabla = as.numeric(apply(tabla, 5, sum))
) |>
  gt(rowname_col = "rec") |>
  cols_label(objetivo = "Objetivo (23-J)", tabla = "Tabla sintética") |>
  tab_spanner("Personas", columns = c(objetivo, tabla)) |>
  fmt_number(decimals = 0, locale = "es")

Cuadra. Esta es la tabla de postestratificación sintética: la población estimada de cada una de las 10.374 celdas. “Sintética” porque no la ha medido nadie, la he fabricado con tres tablas reales y la estructura de la encuesta.

Para usarla con el modelo la paso a data frame, con una fila por celda, y quito las celdas a 0, que son los ceros estructurales:

post <- as.data.frame.table(tabla, responseName = "N") |>
  filter(N > 1e-6) |>
  mutate(n = 1)

nrow(post)
#> [1] 4470
head(post)
#>        ccaa sexo  edad  edu rec        N n
#> 1 Andalucía    H 21-24 baja  PP 7688.767 1
#> 2    Aragón    H 21-24 baja  PP 2220.426 1
#> 3  Asturias    H 21-24 baja  PP 2344.072 1
#> 4  Baleares    H 21-24 baja  PP 1334.045 1
#> 5  Canarias    H 21-24 baja  PP 1895.940 1
#> 6 Cantabria    H 21-24 baja  PP 1449.799 1

Quedan 4.470 celdas con población. Las 5.904 que faltan son los ceros estructurales. Cada fila es una celda y N es cuánta gente hay en ella. La columna n = 1 la necesita brms para predecir, porque el modelo tiene trials(n): con n = 1 la predicción es una probabilidad por partido.

El modelo completo

Ahora sí, el modelo lleva el recuerdo de voto y los doce partidos. Es el mismo modelo multinivel de la primera parte con dos efectos aleatorios más, (1 | rec) y (1 | ccaa:rec), y ajustado sobre las celdas de las cinco variables.

Primero agrego la encuesta por celda:

celdas_enc <- dat |>
  count(ccaa, sexo, edad, edu, rec, voto) |>
  pivot_wider(names_from = voto, values_from = n, values_fill = 0)

celdas_enc$y <- as.matrix(celdas_enc[, voto_lv])
celdas_enc$n <- rowSums(celdas_enc$y)

Aquí hay un detalle que conviene ver despacio. y no es una columna normal: es una matriz metida dentro de una columna del data frame. Tiene una fila por celda y una columna por partido:

class(celdas_enc$y)
#> [1] "matrix" "array"
dim(celdas_enc$y)
#> [1] 1442   12
head(celdas_enc$y)
#>      PP PSOE VOX SUMAR ERC JUNTS AC BILDU PNV BNG CCA OTROS
#> [1,]  0    0   1     0   0     0  0     0   0   0   0     0
#> [2,]  1    0   1     0   0     0  0     0   0   0   0     0
#> [3,]  0    0   0     0   0     0  0     0   0   0   0     1
#> [4,]  0    0   1     0   0     0  0     0   0   0   0     0
#> [5,]  2    0   0     0   0     0  0     0   0   0   0     1
#> [6,]  0    0   0     0   0     0  0     0   0   0   0     1

Si imprimo el data frame, y aparece como un bloque de columnas y[,"PP"], [,"PSOE"], etc.:

celdas_enc |>
  select(ccaa, sexo, edad, edu, rec, y, n) |>
  arrange(desc(n))
#> # A tibble: 1,442 × 7
#>    ccaa      sexo  edad  edu   rec   y[,"PP"] [,"PSOE"] [,"VOX"]     n
#>    <fct>     <fct> <fct> <fct> <fct>    <int>     <int>    <int> <dbl>
#>  1 Andalucía M     45-54 alta  PP          16         0        4    20
#>  2 Andalucía M     55-64 alta  PP          17         0        0    17
#>  3 Madrid    M     45-54 alta  PP          15         0        2    17
#>  4 Madrid    M     65+   baja  PSOE         2        15        0    17
#>  5 Andalucía M     55-64 alta  PSOE         1        13        0    15
#>  6 Andalucía M     35-44 alta  PP           9         0        3    14
#>  7 Cataluña  M     65+   alta  PSOE         0        12        0    14
#>  8 Madrid    H     35-44 alta  PP          11         0        2    14
#>  9 Madrid    H     55-64 alta  PP          12         1        1    14
#> 10 Andalucía M     65+   alta  PSOE         0        11        1    13
#> # ℹ 1,432 more rows
#> # ℹ 1 more variable: y[4:12] <int>

Lo veo mejor en una tabla interactiva. Las columnas en azul son la matriz y: cuántas personas de la celda votarían a cada partido. n es su suma, el total de entrevistas de la celda:

celdas_enc_dt <- celdas_enc |>
  select(ccaa, sexo, edad, edu, rec) |>
  bind_cols(
    as_tibble(celdas_enc$y) |> rename_with(~ paste0('y[, "', .x, '"]')),
    n = celdas_enc$n
  ) |>
  arrange(desc(n))

DT::datatable(
  celdas_enc_dt,
  rownames = FALSE,
  filter = "top",
  options = list(pageLength = 10, scrollX = TRUE)
) |>
  DT::formatStyle(
    columns = paste0('y[, "', voto_lv, '"]'),
    backgroundColor = "#dbe9f6"
  )

Esa es la forma que pide brms para un modelo multinomial con datos agregados. En la fórmula, y | trials(n) significa: en cada celda hay n personas, y y dice cuántas eligen cada categoría. Es la versión multinomial de la binomial con éxitos | trials(n).

Queda un detalle: los partidos regionales. Si ajusto el modelo tal cual, el modelo ve que en 18 comunidades nadie vota a ERC y lo trata como información: el efecto de comunidad de ERC tiene una media muy negativa, y el partial pooling acerca Cataluña a esa media. Es decir, subestimaría a ERC justo donde se presenta.

Pero esos ceros no son información sobre ERC, son ceros estructurales. Los meto en el modelo con un offset: para cada partido regional, una columna que vale 0 en las comunidades donde se presenta y −20 en las demás. Se suma al predictor lineal de ese partido, así que fuera de su territorio su probabilidad queda multiplicada por . Es decir, prácticamente cero. Luego veremos que no siempre, y cómo se arregla.

con_offsets <- function(d) {
  for (p in names(territorio)) {
    d[[paste0("off_", p)]] <- ifelse(d$ccaa %in% territorio[[p]], 0, -20)
  }
  d
}

celdas_enc <- con_offsets(celdas_enc)

celdas_enc |>
  filter(ccaa %in% c("Cataluña", "Andalucía")) |>
  distinct(ccaa, across(starts_with("off_")))
#> # A tibble: 2 × 8
#>   ccaa      off_ERC off_JUNTS off_AC off_BILDU off_PNV off_BNG off_CCA
#>   <fct>       <dbl>     <dbl>  <dbl>     <dbl>   <dbl>   <dbl>   <dbl>
#> 1 Andalucía     -20       -20    -20       -20     -20     -20     -20
#> 2 Cataluña        0         0      0       -20     -20     -20     -20

Otro detalle: la interacción entre comunidad y recuerdo. Con efectos solo aditivos, el efecto de comunidad sube o baja un partido por igual en todos los grupos de recuerdo. Así que el modelo aplicaría en todas partes las transferencias de voto nacionales: cuántos votantes del PSOE en 2023 se van ahora al PP, cuántos abstencionistas se van a VOX… Y eso no es igual en Cataluña que en Madrid. En la encuesta, solo el 2,7 % de los votantes catalanes del PSOE en 2023 votaría ahora al PP, frente al 6,8 % en el conjunto de España.

Por eso añado (1 | ccaa:rec): un efecto aleatorio para cada combinación de comunidad y recuerdo. Con partial pooling, como en la primera parte: donde hay datos (146 votantes catalanes del PSOE), el modelo se acerca a lo que dice la encuesta local. Donde no los hay, se queda cerca del patrón nacional.

brms permite una fórmula distinta para cada partido (cada mu). Todos llevan los mismos efectos, y los regionales además su offset:

f_comun <- "sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec)"

f_partidos <- lapply(voto_lv[-1], function(p) {
  offset <- if (p %in% names(territorio)) {
    paste0(" + offset(off_", p, ")")
  } else {
    ""
  }
  as.formula(paste0("mu", p, " ~ ", f_comun, offset))
})

formula_mrp <- do.call(
  bf,
  c(list(as.formula(paste("y | trials(n) ~", f_comun))), f_partidos)
)
formula_mrp
#> y | trials(n) ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec) 
#> muPSOE ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec)
#> muVOX ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec)
#> muSUMAR ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec)
#> muERC ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec) + offset(off_ERC)
#> muJUNTS ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec) + offset(off_JUNTS)
#> muAC ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec) + offset(off_AC)
#> muBILDU ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec) + offset(off_BILDU)
#> muPNV ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec) + offset(off_PNV)
#> muBNG ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec) + offset(off_BNG)
#> muCCA ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec) + offset(off_CCA)
#> muOTROS ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa) + (1 | ccaa:rec)

mod <- brm(
  formula_mrp,
  data = celdas_enc,
  family = multinomial(),
  prior = priors_multinom(voto_lv),
  chains = 4,
  cores = 4,
  iter = 2000,
  refresh = 0,
  silent = 2,
  control = list(adapt_delta = 0.95),
  backend = "cmdstanr",
  seed = 2026,
  file = file.path(dir_datos, "mod_mrp")
)

Una celda de la tabla

Tomo la primera fila de la tabla de postestratificación:

post[1, ]
#>        ccaa sexo  edad  edu rec        N n
#> 1 Andalucía    H 21-24 baja  PP 7688.767 1

Es una celda: hombres de Andalucía, de 21 a 24 años, con estudios bajos, que votaron al PP en el 23-J. Según la tabla sintética hay unas 7.689 personas así. Eso es su .

El modelo toma de esa fila las variables ccaa, sexo, edad, edu y rec, y predice la probabilidad de votar a cada partido. Pero no da una sola predicción. Es un modelo bayesiano, así que tengo 4.000 muestras de la posterior (4 cadenas × 1.000 iteraciones). Me quedo con 500, que bastan:

post <- con_offsets(post) # la tabla también necesita los offsets

set.seed(2026)
# Algunas combinaciones comunidad x recuerdo no tienen ninguna entrevista
# (p. ej., Melilla_ABST). Su efecto sale de la distribución común.
ep <- posterior_epred(
  mod,
  newdata = post,
  ndraws = 500,
  allow_new_levels = TRUE
)

dim(ep)
#> [1]  500 4470   12

ep es un array de tres dimensiones:

1. 500 draws de la posterior.
2. 4.470 celdas, una por fila de post.
3. 12 partidos.

Antes de seguir, los ceros estructurales. El offset deja la probabilidad de cada partido regional fuera de su territorio en casi 0, pero no siempre en 0 exacto. Fuera de Cataluña ningún dato informa del efecto de comunidad de ERC, así que el modelo lo saca de la distribución común. En algún draw ese efecto sale tan grande que compensa el −20 del offset:

mascara <- sapply(voto_lv, function(p) {
  if (p %in% names(territorio)) {
    as.numeric(post$ccaa %in% territorio[[p]])
  } else {
    rep(1, nrow(post))
  }
})

# Probabilidad máxima de cada partido regional fuera de su territorio
fuga <- apply(ep, c(2, 3), max) * (1 - mascara)
round(apply(fuga[, names(territorio)], 2, max), 4)
#>    ERC  JUNTS     AC  BILDU    PNV    BNG    CCA 
#> 0.0779 0.0422 0.0241 0.0147 0.0007 0.3095 0.0397

Así que en cada draw pongo esas probabilidades a 0 exacto y renormalizo cada celda para que siga sumando 1:

for (d in seq_len(dim(ep)[1])) {
  ep[d, , ] <- ep[d, , ] * mascara
  ep[d, , ] <- ep[d, , ] / rowSums(ep[d, , ])
}

max(apply(ep, c(2, 3), max) * (1 - mascara))
#> [1] 0

Las cinco primeras muestras para la primera celda:

round(ep[1:5, 1, ], 3)
#>         PP  PSOE   VOX SUMAR ERC JUNTS AC BILDU PNV BNG CCA OTROS
#> [1,] 0.661 0.002 0.253     0   0     0  0     0   0   0   0 0.084
#> [2,] 0.734 0.000 0.205     0   0     0  0     0   0   0   0 0.061
#> [3,] 0.738 0.002 0.201     0   0     0  0     0   0   0   0 0.059
#> [4,] 0.641 0.003 0.279     0   0     0  0     0   0   0   0 0.076
#> [5,] 0.661 0.001 0.292     0   0     0  0     0   0   0   0 0.046

Cada fila es una muestra de la posterior, y suma 1. Todas dicen lo mismo con pequeñas diferencias: esta gente vota mayoritariamente al PP, con una parte que se va a VOX. Esa variación entre filas es la incertidumbre del modelo sobre esta celda. La media de las 500 es la de esta celda:

theta_1 <- colMeans(ep[, 1, ])
round(theta_1, 3)
#>    PP  PSOE   VOX SUMAR   ERC JUNTS    AC BILDU   PNV   BNG   CCA OTROS 
#> 0.721 0.002 0.208 0.001 0.000 0.000 0.000 0.000 0.000 0.000 0.000 0.068

La P a mano

Ahora multiplico por la de la celda. Así obtengo cuántas personas de esa celda votarían a cada partido:

round(theta_1 * post$N[1])
#>    PP  PSOE   VOX SUMAR   ERC JUNTS    AC BILDU   PNV   BNG   CCA OTROS 
#>  5546    15  1598     7     0     0     0     0     0     0     0   523

De los 7.689 hombres jóvenes andaluces con estudios bajos que votaron al PP, unos 5.500 lo seguirían votando y unos 1.600 se irían a VOX. Los partidos regionales salen con 0 exacto: en Andalucía no se presentan.

La postestratificación es hacer esto en las 4.470 celdas, sumar y dividir entre la población total. Para un solo draw, el primero:

votantes_draw1 <- colSums(ep[1, , ] * post$N) # suma de N_j * theta_j
round(votantes_draw1)
#>      PP    PSOE     VOX   SUMAR     ERC   JUNTS      AC   BILDU     PNV     BNG 
#> 9899439 8726196 5767531 3355908  715631  217418  138452  648580  266497  278009 
#>     CCA   OTROS 
#>  104916 6711126

round(100 * votantes_draw1 / sum(post$N), 1)
#>    PP  PSOE   VOX SUMAR   ERC JUNTS    AC BILDU   PNV   BNG   CCA OTROS 
#>  26.9  23.7  15.7   9.1   1.9   0.6   0.4   1.8   0.7   0.8   0.3  18.2

ep[1, , ] es una matriz de 4.470 celdas × 12 partidos. Al multiplicarla por post$N, cada fila se multiplica por la población de su celda. colSums suma por partido. Esa es exactamente la fórmula .

Y para tener la incertidumbre, repito lo mismo en cada uno de los 500 draws:

mrp_draws_todos <- apply(ep, 1, function(p) {
  colSums(p * post$N) / sum(post$N)
}) |>
  t()

dim(mrp_draws_todos)
#> [1] 500  12

est_todos <- tibble(
  partido = voto_lv,
  mrp = 100 * colMeans(mrp_draws_todos),
  q05 = 100 * apply(mrp_draws_todos, 2, quantile, 0.05),
  q95 = 100 * apply(mrp_draws_todos, 2, quantile, 0.95)
)

est_todos |> mutate(across(-partido, ~ round(.x, 1)))
#> # A tibble: 12 × 4
#>    partido   mrp   q05   q95
#>    <chr>   <dbl> <dbl> <dbl>
#>  1 PP       26.7  25.1  28.2
#>  2 PSOE     24.2  22.8  25.7
#>  3 VOX      16.8  15.2  18.6
#>  4 SUMAR     8.6   7.7   9.7
#>  5 ERC       1.8   1.4   2.2
#>  6 JUNTS     1     0.7   1.3
#>  7 AC        0.3   0.1   0.5
#>  8 BILDU     1.4   1.2   1.8
#>  9 PNV       0.9   0.6   1.3
#> 10 BNG       0.6   0.5   0.8
#> 11 CCA       0.2   0.1   0.4
#> 12 OTROS    17.4  15.6  19.1

Eso ya es MRP: 500 estimaciones de la intención de voto en toda la población, de las que saco la media y un intervalo al 90 %. Pero lleva un supuesto escondido que conviene sacar a la luz.

¿Quién va a votar?

La fórmula supone que todo el electorado vota. Y es la intención de quienes declaran un voto válido. Así que estoy suponiendo que en cada celda vota todo el mundo, y con la misma intención que quien contesta.

Donde más se nota es en quienes se abstuvieron en 2023. Lo veo en Cataluña: cuántos puntos de PP y de VOX aporta cada grupo de recuerdo a la estimación de la comunidad.

theta_media <- apply(ep, c(2, 3), mean) # theta de cada celda (media de los draws)
i_cat <- post$ccaa == "Cataluña"

post[i_cat, ] |>
  mutate(
    pp = theta_media[i_cat, "PP"] * N,
    vox = theta_media[i_cat, "VOX"] * N
  ) |>
  group_by(rec) |>
  summarise(N = sum(N), pp = sum(pp), vox = sum(vox)) |>
  mutate(
    peso = 100 * N / sum(N),
    puntos_pp = 100 * pp / sum(N),
    puntos_vox = 100 * vox / sum(N)
  ) |>
  filter(peso > 0.5) |>
  select(rec, peso, puntos_pp, puntos_vox) |>
  gt(rowname_col = "rec") |>
  cols_label(
    peso = "% del electorado",
    puntos_pp = "Puntos de PP",
    puntos_vox = "Puntos de VOX"
  ) |>
  fmt_number(decimals = 1, locale = "es") |>
  tab_style(
    style = cell_fill(color = "#fde0dd"),
    locations = cells_body(rows = rec == "ABST")
  )

Los abstencionistas de 2023 son un tercio del electorado catalán, y la fórmula los cuenta enteros como votantes. Aportan más puntos al PP (6,1) que los propios votantes del PP en 2023 (5,9), y más a VOX (5,3) que los votantes de VOX (3,5). No es que voten mal: es que la mayoría de ellos no va a votar.

Hace falta una T en el MRP: un modelo de participación. La encuesta pregunta la probabilidad de ir a votar, de 0 a 10 (PROBVOTO). Me quedo con quien dice 10, “con toda seguridad iría a votar”:

cis |>
  filter(!is.na(vota_seguro)) |>
  group_by(rec) |>
  summarise(entrevistas = n(), seguro = mean(vota_seguro)) |>
  gt(rowname_col = "rec") |>
  cols_label(entrevistas = "Entrevistas", seguro = "Seguro que vota") |>
  fmt_percent(seguro, decimals = 0, locale = "es") |>
  fmt_number(entrevistas, decimals = 0, locale = "es")

Entre quienes votaron en 2023 a PP, PSOE, VOX o SUMAR, lo dice entre el 84 % y el 90 %. Entre los abstencionistas, el 38 %. Con esa variable ajusto otro modelo multinivel, binomial, con las mismas variables y sobre las 4.018 entrevistas, no solo las de voto válido:

celdas_part <- cis |>
  filter(!is.na(vota_seguro)) |>
  group_by(ccaa, sexo, edad, edu, rec) |>
  summarise(vota = sum(vota_seguro), n = n(), .groups = "drop")

mod_part <- brm(
  vota | trials(n) ~ sexo + (1 | edad) + (1 | edu) + (1 | rec) + (1 | ccaa),
  data = celdas_part,
  family = binomial(),
  prior = prior(normal(0, 1.5), class = "Intercept") +
    prior(normal(0, 1), class = "b") +
    prior(exponential(1), class = "sd"),
  chains = 4,
  cores = 4,
  iter = 2000,
  refresh = 0,
  silent = 2,
  backend = "cmdstanr",
  seed = 2026,
  file = file.path(dir_datos, "mod_participacion")
)

set.seed(2026)
t_draws <- posterior_epred(mod_part, newdata = post, ndraws = 500)
dim(t_draws)
#> [1]  500 4470

t_draws tiene la probabilidad de votar de cada celda en cada draw: 500 × 4.470. La calibro al 70,4 % de participación del 23-J entre residentes, desplazando el intercepto en escala logit en cada draw. Aquí apenas cambia nada (sin calibrar sale un 70,3 %), porque la postestratificación por recuerdo ya corrige casi todo el exceso de participación de la encuesta; con otra encuesta podría no ser así.

rec_pob <- tg$rec_ccaa |>
  group_by(rec) |>
  summarise(N = sum(N))

participacion_23j <- with(
  rec_pob,
  sum(N[!rec %in% c("ABST", "NO_PODIA")]) / sum(N[rec != "NO_PODIA"])
)

c(
  objetivo = participacion_23j,
  sin_calibrar = sum(colMeans(t_draws) * post$N) / sum(post$N)
)
#>     objetivo sin_calibrar 
#>    0.7041371    0.7025981

calibra <- function(p, N, objetivo) {
  f <- function(delta) sum(N * plogis(qlogis(p) + delta)) / sum(N) - objetivo
  delta <- uniroot(f, c(-10, 10))$root
  plogis(qlogis(p) + delta)
}

t_cal <- t(apply(t_draws, 1, calibra, N = post$N, objetivo = participacion_23j))

# Participación calibrada por recuerdo de voto
post |>
  mutate(t = colMeans(t_cal)) |>
  group_by(rec) |>
  summarise(participacion = sum(t * N) / sum(N)) |>
  gt(rowname_col = "rec") |>
  fmt_percent(participacion, decimals = 0, locale = "es")

Ahora la postestratificación pondera cada celda por los que votan, , y no por todos los que hay:

En código es lo mismo de antes con otros pesos, y en cada draw uso su propia :

w <- sweep(t_cal, 2, post$N, "*") # draws x celdas: N_j * t_j

mrp_draws <- sapply(seq_len(nrow(w)), function(d) {
  colSums(ep[d, , ] * w[d, ]) / sum(w[d, ])
}) |>
  t()

est_mrp <- tibble(
  partido = voto_lv,
  mrp = 100 * colMeans(mrp_draws),
  q05 = 100 * apply(mrp_draws, 2, quantile, 0.05),
  q95 = 100 * apply(mrp_draws, 2, quantile, 0.95)
)

est_todos |>
  select(partido, todos = mrp) |>
  left_join(est_mrp |> select(partido, votan = mrp), by = "partido") |>
  mutate(diferencia = votan - todos) |>
  gt(rowname_col = "partido") |>
  cols_label(
    todos = "Si votara todo el mundo",
    votan = "Con participación",
    diferencia = "Diferencia"
  ) |>
  fmt_number(decimals = 1, locale = "es")

Con la participación, OTROS baja más de 3 puntos. Los abstencionistas de 2023 que ahora dicen que votarían eligen mucho OTROS, pero solo votan en un 38 %. El PP sube 2 puntos y el PSOE algo más de 1, porque sus votantes de 2023 son los que más repiten.

A partir de aquí, todas las estimaciones usan el modelo de participación.

¿Cuánto cambia?

Lo comparo con la intención de voto bruta de la encuesta, con la ponderada con los pesos del CIS y con la estimación que publicó el CIS para este barómetro:

# Estimación del CIS (página 3 de 3577_Estimacion.pdf), agrupada como aquí:
# SUMAR = SUMAR + Podemos; OTROS = SALF + UPN + otros partidos + en blanco
cis_publicado <- c(
  PP = 25.5,
  PSOE = 31.0,
  VOX = 16.6,
  SUMAR = 5.7 + 3.7,
  ERC = 2.5,
  JUNTS = 0.7,
  AC = NA, # el CIS la incluye en "Otros partidos"
  BILDU = 1.3,
  PNV = 0.7,
  BNG = 0.7,
  CCA = 0.2,
  OTROS = 1.8 + 0.1 + 8.6 + 1.0
)

comparacion <- est_mrp |>
  mutate(
    bruto = as.numeric(100 * prop.table(table(dat$voto))[partido]),
    pesos_cis = as.numeric(
      100 * tapply(dat$peso, dat$voto, sum)[partido] / sum(dat$peso)
    ),
    cis_publicado = cis_publicado[partido]
  ) |>
  select(partido, bruto, pesos_cis, mrp, q05, q95, cis_publicado)

comparacion |>
  mutate(partido = if_else(partido == "SUMAR", "SUMAR y aliados", partido)) |>
  gt(rowname_col = "partido") |>
  cols_merge(c(q05, q95), pattern = "{1} – {2}") |>
  cols_label(
    bruto = "Bruto",
    pesos_cis = "Pesos CIS",
    mrp = "MRP",
    q05 = "Intervalo 90 %",
    cis_publicado = "CIS publicado"
  ) |>
  tab_spanner("% sobre voto válido", columns = everything()) |>
  fmt_number(decimals = 1, locale = "es") |>
  sub_missing(missing_text = "—") |>
  tab_style(
    style = list(cell_text(weight = "bold"), cell_fill(color = "#fde0dd")),
    locations = cells_body(columns = mrp)
  )