Explaining restrictions

Code 
library(tidyverse)
library(tidybayes)
library(modelsummary)
library(marginaleffects)
library(scales)
library(glue)
library(ggtext)
library(patchwork)
library(ggh4x)
library(tinytable)
library(targets)

tar_config_set(
  store = here::here("_targets"),
  script = here::here("_targets.R")
)

tar_load(c(m_restrictions, m_tbl_restrictions))

invisible(list2env(tar_read(graphic_functions), .GlobalEnv))
invisible(list2env(tar_read(diagnostic_functions), .GlobalEnv))
invisible(list2env(tar_read(helper_functions), .GlobalEnv))
invisible(list2env(tar_read(modelsummary_functions), .GlobalEnv))

set_annotation_fonts()

Model details

Formal model specification

\[ \begin{aligned} &\ \mathrlap{\textbf{Model of outcome level $i$ across week $t$}} \\ \text{Outcome}_{it_j} \sim&\ \operatorname{Ordered\ logit}(\phi_{it_j}, \alpha_k) \\[0.75em] &\ \textbf{Distribution parameters} \\ \phi_{it} =&\ \beta_0 + \beta_1\ \text{PanBack (binary)}_{it} + \beta_2\ \text{Derogation in effect}_{it} + \\ &\ \beta_3\ [\text{PanBack (binary)}_{it} \times \text{Derogation in effect}_{it}] + \\ &\ \beta_4\ \text{New cases}_{it}\ + \beta_5\ \text{Cumulative cases}_{it}\ + \\ &\ \beta_6\ \text{New deaths}_{it}\ + \beta_7\ \text{Cumulative deaths}_{it}\ + \\ &\ \beta_8\ \text{Rule of law index}_{it}\ + \beta_9\ \text{Week number}_{it} \\[0.75em] &\ \textbf{Priors} \\ \beta_{0 \dots 9} \sim&\ \operatorname{Student\ t}(\nu = 1, \mu = 0, \sigma = 3) \\ \alpha_k \sim&\ \mathcal{N}(0, 1) \end{aligned} \]

Priors

Code 
ggplot() +
  stat_function(
    geom = "area",
    fun = ~extraDistr::dlst(., df = 1, mu = 0, sigma = 3),
    fill = clrs[2]
  ) +
  xlim(c(-20, 20)) +
  labs(x = "βs") +
  facet_wrap(vars("β: Student t(ν = 1, µ = 0, σ = 3)")) +
  theme_pandem(prior = TRUE)

Density plot of prior distribution for model parameters

Simplified R code

brm(
  bf(outcome ~ derogation_ineffect*panbackdichot +
      new_cases_z + cumulative_cases_z +
      new_deaths_z + cumulative_deaths_z +
      v2x_rule + year_week_num),
  family = cumulative(),
  prior = c(
    prior(student_t(1, 0, 3), class = Intercept),
    prior(student_t(1, 0, 3), class = b)),
  ...
)

Model evaluation

Code 
params_to_show <- c("b_Intercept[1]", "b_derogation_ineffect", "b_panbackdichot", "b_v2x_rule")
Code 
plot_trace(m_restrictions$m_restrict_movement, params_to_show)

Code 
plot_trank(m_restrictions$m_restrict_movement, params_to_show)

Code 
plot_pp(m_restrictions$m_restrict_movement)

Code 
plot_trace(m_restrictions$m_restrict_pubtrans, params_to_show)

Code 
plot_trank(m_restrictions$m_restrict_pubtrans, params_to_show)

Code 
plot_pp(m_restrictions$m_restrict_pubtrans)

Code 
plot_trace(m_restrictions$m_restrict_stayhome, params_to_show)

Code 
plot_trank(m_restrictions$m_restrict_stayhome, params_to_show)

Code 
plot_pp(m_restrictions$m_restrict_stayhome)

Results

Predictions

Code 
preds_movement <- calc_preds(m_restrictions$m_restrict_movement)
preds_movement_details <- calc_preds_details(preds_movement)
diffs_movement <- calc_preds_diffs(preds_movement)
diffs_movement_details <- calc_preds_diffs_details(diffs_movement)

preds_pubtrans <- calc_preds(m_restrictions$m_restrict_pubtrans)
preds_pubtrans_details <- calc_preds_details(preds_pubtrans)
diffs_pubtrans <- calc_preds_diffs(preds_pubtrans)
diffs_pubtrans_details <- calc_preds_diffs_details(diffs_pubtrans)

preds_stayhome <- calc_preds(m_restrictions$m_restrict_stayhome)
preds_stayhome_details <- calc_preds_details(preds_stayhome)
diffs_stayhome <- calc_preds_diffs(preds_stayhome)
diffs_stayhome_details <- calc_preds_diffs_details(diffs_stayhome)
Code 
p1 <- ggplot(preds_movement, aes(x = .draw, y = .epred)) +
  geom_area(aes(fill = .category), position = position_stack()) +
  geom_label(
    data = calc_fuzzy_labs(preds_movement_details, filter_small = FALSE),
    aes(x = x, y = y, label = prob_ci_nice, hjust = hjust),
    fill = scales::alpha("white", 0.4), label.size = 0,
    fontface = "bold", size = 8, size.unit = "pt"
  ) +
  scale_x_continuous(breaks = NULL, expand = c(0, 0)) +
  scale_y_continuous(labels = label_percent(), expand = c(0, 0)) +
  scale_fill_manual(values = clrs[c(7, 4, 2)]) +
  labs(
    x = NULL, y = "Cumulative\nprobabilities",
    fill = "Internal movement measures", tag = "A"
  ) +
  facet_nested_wrap(
    vars(panbackdichot, derogation_ineffect),
    strip = nested_settings,
    nrow = 1
  ) +
  theme_pandem() +
  theme_fuzzy_bar

p2 <- ggplot(preds_pubtrans, aes(x = .draw, y = .epred)) +
  geom_area(aes(fill = .category), position = position_stack()) +
  geom_label(
    data = calc_fuzzy_labs(preds_pubtrans_details, filter_small = FALSE),
    aes(x = x, y = y, label = prob_ci_nice, hjust = hjust),
    fill = scales::alpha("white", 0.4), label.size = 0,
    fontface = "bold", size = 8, size.unit = "pt"
  ) +
  scale_x_continuous(breaks = NULL, expand = c(0, 0)) +
  scale_y_continuous(labels = label_percent(), expand = c(0, 0)) +
  scale_fill_manual(values = clrs[c(7, 4, 2)]) +
  labs(
    x = NULL, y = "Cumulative\nprobabilities",
    fill = "Public transportation measures", tag = "B"
  ) +
  facet_nested_wrap(
    vars(panbackdichot, derogation_ineffect),
    strip = nested_settings,
    nrow = 1
  ) +
  theme_pandem() +
  theme_fuzzy_bar

p3 <- ggplot(preds_stayhome, aes(x = .draw, y = .epred)) +
  geom_area(aes(fill = .category), position = position_stack()) +
  geom_label(
    data = calc_fuzzy_labs(preds_stayhome_details, filter_small = TRUE),
    aes(x = x, y = y, label = prob_ci_nice, hjust = hjust),
    fill = scales::alpha("white", 0.4), label.size = 0,
    fontface = "bold", size = 8, size.unit = "pt"
  ) +
  scale_x_continuous(breaks = NULL, expand = c(0, 0)) +
  scale_y_continuous(labels = label_percent(), expand = c(0, 0)) +
  scale_fill_manual(values = clrs[c(7, 4, 2, 1)], guide = guide_legend(nrow = 2)) +
  labs(
    x = NULL, y = "Cumulative\nprobabilities",
    fill = "Stay at home measures", tag = "C"
  ) +
  facet_nested_wrap(
    vars(panbackdichot, derogation_ineffect),
    strip = nested_settings,
    nrow = 1
  ) +
  theme_pandem() +
  theme_fuzzy_bar

(p1 / line_divider / p2 / line_divider / p3) +
  plot_layout(heights = c(0.31, 0.035, 0.31, 0.035, 0.31)) +
  plot_annotation(
    caption = str_wrap(
      glue(
        "The vertical slices of the bars depict 500 posterior samples;",
        "the fuzziness represents the uncertainty in category boundaries.",
        "95% credible intervals are shown as ranges in each category",
        .sep = " "
      ),
      width = 100
    ),
    theme = theme(
      plot.caption = element_text(
        margin = margin(t = 10), size = rel(0.7),
        family = "Noto Sans", face = "plain"
      )
    )
  )

Predicted probabilities of imposing emergency policies across states with low and high risks of democratic backsliding and derogation status

Complete table of results

Code 
notes <- paste(
  "Note: Estimates are median posterior log odds from ordered logistic regression models;",
  "95% credible intervals (highest density posterior interval, or HDPI) in brackets."
)

m_tbl_restrictions |>
  set_names(c("Restricted movement", "Close public transit", "Stay at home")) |>
  modelsummary(
    estimate = "{estimate}",
    statistic = "[{conf.low}, {conf.high}]",
    coef_map = coef_map,
    gof_map = gof_map,
    output = "tinytable",
    fmt = fmt_significant(2),
    notes = notes,
    width = c(0.3, rep(0.23, 3))
  ) |>
  style_tt(i = seq(1, 23, 2), j = 1, rowspan = 2, alignv = "t") |>
  style_tt(
    bootstrap_class = "table table-sm"
  )

Complete results from models showing relationship between derogations and COVID-19 restrictions
Restricted movement Close public transit Stay at home
Note: Estimates are median posterior log odds from ordered logistic regression models; 95% credible intervals (highest density posterior interval, or HDPI) in brackets.
Derogation in effect 1.09 1.1 1.9
[0.85, 1.30] [0.9, 1.3] [1.7, 2.1]
Pandemic backsliding (PanBack), dichotomous 0.61 0.75 1.11
[0.44, 0.78] [0.61, 0.90] [0.96, 1.27]
Derogation in effect × Pandemic backsliding 0.96 0.11 -0.44
[-0.13, 2.19] [-0.50, 0.72] [-1.00, 0.14]
New cases (standardized) 0.59 -0.092 0.015
[0.36, 0.81] [-0.176, -0.017] [-0.075, 0.107]
New deaths (standardized) 0.42 0.24 0.34
[0.23, 0.60] [0.16, 0.32] [0.25, 0.42]
Cumulative cases (standardized) -0.70 -0.040 -0.063
[-0.92, -0.50] [-0.141, 0.068] [-0.176, 0.054]
Cumulative deaths (standardized) 0.81 0.148 0.070
[0.59, 1.03] [0.041, 0.251] [-0.044, 0.189]
Rule of law index -0.55 -0.81 -0.37
[-0.68, -0.42] [-0.94, -0.68] [-0.49, -0.25]
Year-week number -0.021 -0.0113 -0.00062
[-0.023, -0.019] [-0.0132, -0.0092] [-0.00252, 0.00140]
Cut 1 -1.6 -0.94 -1.2
[-1.8, -1.5] [-1.05, -0.83] [-1.3, -1.1]
Cut 2 -0.84 0.90 0.039
[-0.96, -0.73] [0.78, 1.01] [-0.077, 0.142]
Cut 3 2.8
[2.7, 3.0]
N 9591 9591 9591
\(R^2\) 0.11 0.07 0.09

Contrasts

Code 
p1 <- diffs_movement |>
  ggplot(aes(x = .epred, y = fct_rev(.category), color = .category)) +
  geom_vline(xintercept = 0, linewidth = 0.25, linetype = "21") +
  stat_pointinterval() +
  facet_nested_wrap(vars(panbackdichot, derogation_ineffect), strip = nested_settings_diffs) +
  scale_x_continuous(labels = label_pp) +
  scale_color_manual(values = clrs[c(7, 4, 2)], guide = "none") +
  labs(
    x = NULL, y = NULL,
    title = "Internal movement measures", tag = "A"
  ) +
  theme_pandem() +
  theme_diffs

p2 <- diffs_pubtrans |>
  ggplot(aes(x = .epred, y = fct_rev(.category), color = .category)) +
  geom_vline(xintercept = 0, linewidth = 0.25, linetype = "21") +
  stat_pointinterval() +
  facet_nested_wrap(vars(panbackdichot, derogation_ineffect), strip = nested_settings_diffs) +
  scale_x_continuous(labels = label_pp) +
  scale_color_manual(values = clrs[c(7, 4, 2)], guide = "none") +
  labs(
    x = NULL, y = NULL,
    title = "Public transportation measures", tag = "B"
  ) +
  theme_pandem() +
  theme_diffs

p3 <- diffs_stayhome |>
  ggplot(aes(x = .epred, y = fct_rev(.category), color = .category)) +
  geom_vline(xintercept = 0, linewidth = 0.25, linetype = "21") +
  stat_pointinterval() +
  facet_nested_wrap(vars(panbackdichot, derogation_ineffect), strip = nested_settings_diffs) +
  scale_x_continuous(labels = label_pp) +
  scale_color_manual(values = clrs[c(7, 4, 2, 1)], guide = "none") +
  labs(
    x = NULL, y = NULL,
    title = "Stay at home measures", tag = "C"
  ) +
  theme_pandem() +
  theme_diffs

(p1 / line_divider / p2 / line_divider / p3) +
  plot_layout(heights = c(0.295, 0.035, 0.295, 0.035, 0.34)) +
  plot_annotation(
    caption = str_wrap(
      glue(
        "Point shows posterior median;", "
        thick lines show 80% credible interval;",
        "thin black lines show 95% credible interval",
        .sep = " "
      ),
      width = 150
    ),
    theme = theme(
      plot.caption = element_text(
        margin = margin(t = 10), size = rel(0.7),
        family = "Noto Sans", face = "plain"
      )
    )
  )

Contrasts in predicted probabilities of implementing COVID restrictions across states with low and high risks of democratic backsliding and derogation status

Contrasts in predicted probabilities of implementing COVID restrictions across states with low and high risks of democratic backsliding and derogation status
Code 
make_diffs_tbl(diffs_movement)
Severity Median ∆ p(∆ > 0)
No measures −19.8 [−23.1, −16.5] 0.00
Recommend to not travel −6.6 [−7.7, −4.4] 0.00
Restrictions in place 25.3 [20.9, 30.8] 1.00
No measures −19.8 [−23.1, −14.3] 0.00
Recommend to not travel −13.2 [−16.5, −8.8] 0.00
Restrictions in place 31.9 [23.1, 39.6] 1.00
No measures −12.1 [−16.5, −6.6] 0.00
Recommend to not travel −8.8 [−13.2, −4.4] 0.00
Restrictions in place 20.9 [12.1, 29.7] 1.00
No measures −12.1 [−15.4, −9.9] 0.00
Recommend to not travel −2.2 [−3.3, −2.2] 0.00
Restrictions in place 14.3 [11.0, 18.7] 1.00
Code 
make_diffs_tbl(diffs_pubtrans)
Severity Median ∆ p(∆ > 0)
No measures −24.2 [−27.5, −20.9] 0.00
Recommend closing 4.4 [3.3, 5.5] 1.00
Require closing 18.7 [15.4, 23.1] 1.00
No measures −17.6 [−24.2, −11.0] 0.00
Recommend closing −8.8 [−16.5, −2.2] 0.00
Require closing 27.5 [13.2, 39.6] 1.00
No measures −12.1 [−17.6, −5.5] 0.00
Recommend closing −8.8 [−16.5, −2.2] 0.00
Require closing 20.9 [7.7, 34.1] 1.00
No measures −17.6 [−20.9, −14.3] 0.00
Recommend closing 5.5 [4.4, 5.5] 1.00
Require closing 12.1 [9.9, 15.4] 1.00
Code 
make_diffs_tbl(diffs_stayhome)
Severity Median ∆ p(∆ > 0)
No measures −22.0 [−23.1, −20.9] 0.00
Recommend not leaving house −18.7 [−20.9, −17.6] 0.00
Require not leaving house, with exceptions 20.9 [18.7, 22.0] 1.00
Require not leaving house, with minimal exceptions 19.8 [16.5, 23.1] 1.00
No measures −7.7 [−9.9, −5.5] 0.00
Recommend not leaving house −13.2 [−16.5, −9.9] 0.00
Require not leaving house, with exceptions −5.5 [−12.1, 2.2] 0.09
Require not leaving house, with minimal exceptions 26.4 [13.2, 37.4] 1.00
No measures −2.2 [−3.3, −1.1] 0.01
Recommend not leaving house −4.4 [−7.7, −1.1] 0.01
Require not leaving house, with exceptions −6.6 [−15.4, 0.0] 0.01
Require not leaving house, with minimal exceptions 14.3 [2.2, 25.3] 0.99
No measures −16.5 [−17.6, −14.3] 0.00
Recommend not leaving house −11.0 [−12.1, −8.8] 0.00
Require not leaving house, with exceptions 18.7 [16.5, 19.8] 1.00
Require not leaving house, with minimal exceptions 7.7 [6.6, 9.9] 1.00