ct_selection_untitled-E3915C76.R

# behavioral
laity2017 |> ct(q26, wt = weight1)      # mass attendance
laity2017 |> ct(q23, wt = weight1)      # confession
laity2017 |> ct(q25, wt = weight1)      # parish registration

# belief
laity2017 |> ct(q10_e, wt = weight1)    # transubstantiation
laity2017 |> ct(q10_i, wt = weight1)    # resurrection

# moral authority
laity2017 |> ct(q04_b, wt = weight1)    # birth control
laity2017 |> ct(q04_c, wt = weight1)    # abortion
laity2017 |> ct(q04_d, wt = weight1)    # homosexual activity

# institutional
laity2017 |> ct(q03_b, wt = weight1)    # can disagree and be loyal
laity2017 |> ct(q07, wt = weight1)      # response to bishops

laity2017 <- laity2017 |>
  mutate(
    # behavioral
    conf_mass       = if_else(q26 == 1, 1, 0),        # weekly attendance
    conf_confession = if_else(q23 %in% 1:3, 1, 0),    # at least once a year
    conf_parish     = if_else(q25 == 1, 1, 0),         # registered
    
    # belief
    conf_transub    = if_else(q10_e == 2, 1, 0),       # no = conformant
    conf_resurrect  = if_else(q10_i == 2, 1, 0),       # no = conformant
    
    # moral authority
    conf_bc         = if_else(q04_b == 1, 1, 0),       # church leaders
    conf_abortion   = if_else(q04_c == 1, 1, 0),       # church leaders
    conf_homosex    = if_else(q04_d == 1, 1, 0),       # church leaders
    
    # institutional
    conf_bishops    = if_else(q07 == 3, 1, 0),         # follow bishops
    conf_disagree   = if_else(q03_b %in% 3:4, 1, 0)   # disagree = conformant
  )


laity2017 <- laity2017 |>
  mutate(
    conf_index = rowSums(
      across(starts_with("conf_")), 
      na.rm = TRUE
    )
  )

laity2017 |> ct(conf_index, wt = weight1)


laity2017 |>
  filter(!is.na(conf_index)) |>
  ct(conf_index, wt = weight1) |>
  ggplot(aes(x = as.factor(conf_index), y = pct)) +
  geom_col(fill = "#7BB8D8", color = "black") +
  lab_bar(type = pct, pos = .01, sz = 8, above = TRUE) +
  y_pct() +
  theme_rb() +
  labs(
    title = "How Doctrinally Conformant Are American Catholics?",
    subtitle = "Index built from 10 items across behavior, belief, moral authority, and institutional loyalty\n0 = conformant on no items, 10 = conformant on all items",
    caption = "@ryanburge | Data: American Catholic Laity Poll 2017",
    x = "Number of Items Conformant (out of 10)",
    y = NULL
  )
save("cath_laity_conf_index.png", wd = 10, ht = 6)


library(gt)

conf_summary <- tibble(
  Category = c(
    "Behavioral", "Behavioral", "Behavioral",
    "Belief", "Belief",
    "Moral Authority", "Moral Authority", "Moral Authority",
    "Institutional", "Institutional"
  ),
  Item = c(
    "Attends Mass weekly",
    "Goes to confession at least once a year",
    "Registered as a parish member",
    "Believes bread/wine become body/blood of Jesus",
    "Believes Jesus physically rose from the dead",
    "Says Church leaders should have final say on birth control",
    "Says Church leaders should have final say on abortion",
    "Says Church leaders should have final say on homosexual activity",
    "Tries to follow bishops' guidance on politics/policy",
    "Disagrees that Catholics can be loyal while disagreeing with Church teaching"
  ),
  Variable = c(
    "conf_mass", "conf_confession", "conf_parish",
    "conf_transub", "conf_resurrect",
    "conf_bc", "conf_abortion", "conf_homosex",
    "conf_bishops", "conf_disagree"
  )
)

# calculate weighted pct conformant for each item
conf_pcts <- laity2017 |>
  select(weight1, starts_with("conf_")) |>
  pivot_longer(cols = starts_with("conf_"),
               names_to = "Variable", values_to = "value") |>
  filter(!is.na(value)) |>
  group_by(Variable) |>
  summarize(pct_conformant = weighted.mean(value, weight1, na.rm = TRUE))

# join and build table
tab <- conf_summary |>
  left_join(conf_pcts, by = "Variable") |>
  select(-Variable) |>
  gt(groupname_col = "Category") |>
  opt_table_font(
    font = c(
      "Abel Regular", "Segoe UI",
      default_fonts()[-c(1:3)]
    )) %>%
  cols_label(
    Item = "Conformance Item",
    pct_conformant = "% Conformant"
  ) |>
  fmt_percent(columns = pct_conformant, decimals = 1) |>
  tab_header(
    title = "Catholic Doctrinal Conformity Index",
    subtitle = "Items, definitions, and share of 2017 sample considered conformant on each"
  ) |>
  tab_source_note("Data: American Catholic Laity Poll 2017 | @ryanburge") |>
  tab_style(
    style = cell_fill(color = "#f0f0f0"),
    locations = cells_row_groups()
  ) |>
  tab_style(
    style = cell_text(weight = "bold"),
    locations = cells_row_groups()
  ) |>
  tab_options(
    table.font.size = 14,
    heading.title.font.size = 18,
    heading.subtitle.font.size = 14
  )

gtsave(tab, "E://graphs25/table_conformant.png")




gg1 <- laity2017 |>
  mutate(confession = frcode(
    q23 == 1 ~ "Once a month or more",
    q23 == 2 ~ "Several times a year",
    q23 == 3 ~ "Once a year",
    q23 == 4 ~ "Less than once a year",
    q23 == 5 ~ "Seldom or never"
  )) |>
  ct(confession, wt = weight1, show_na = FALSE) %>% 
  mutate(confession = fct_rev(confession))

gg1 %>% 
  ggplot(., aes(x = confession, y = pct, fill = confession)) +
  geom_col(color = "black") +
  coord_flip() +
  scale_fill_manual(values = c(
    "Once a month or more"  = "#2C6E49",
    "Several times a year"  = "#68B0AB",
    "Once a year"           = "#F4A259",
    "Less than once a year" = "#E07340",
    "Seldom or never"       = "#C1393D"
  )) +
  theme_rb() +
  lab_bar(above = TRUE, pos = .03, sz = 8, type = pct) +
  y_pct() +
  theme(plot.title = element_text(size = 15)) +
  labs(x = "", y = "", 
       title = "How often, if ever, do you participate in the Sacrament of Reconciliation (Confession)?", 
       caption = "@ryanburge  | Data: American Catholic Laity Poll 2017") +
  guides(fill = "none")
save('confessions_catholic.png', ht = 3.25)



gg1 <- laity2017 |>
  mutate(
    confession = frcode(
      q23 == 1 ~ "Once a month or more",
      q23 == 2 ~ "Several times a year",
      q23 == 3 ~ "Once a year",
      q23 == 4 ~ "Less than once a year",
      q23 == 5 ~ "Seldom or never"
    ),
    attend_cat = frcode(
      attend_harm == 1 ~ "Weekly+",
      attend_harm == 2 ~ "Monthly",
      attend_harm == 3 ~ "Seldom/Never"
    )
  ) |>
  filter(!is.na(attend_cat)) |>
  group_by(attend_cat) |>
  ct(confession, wt = weight1, show_na = FALSE) |>
  mutate(confession = fct_rev(confession)) 



gg1 %>% 
  mutate(lab = round(pct, 2)) %>% 
  ggplot(., aes(x = 1, y = pct, fill = fct_rev(confession))) +
  geom_col(color = "black") + 
  coord_flip() +
  facet_wrap(~ fct_rev(attend_cat), ncol =1, strip.position = "left") +
  theme_rb() +
  scale_fill_manual(values = c(
    "Once a month or more"  = "#2C6E49",
    "Several times a year"  = "#68B0AB",
    "Once a year"           = "#F4A259",
    "Less than once a year" = "#E07340",
    "Seldom or never"       = "#C1393D"
  )) +
  theme(legend.position = "bottom") +
  scale_y_continuous(labels = percent) +
  theme(strip.text.y.left = element_text(angle=0)) +
  guides(fill = guide_legend(reverse=T, nrow = 1)) +
  theme(axis.title.y=element_blank(), axis.text.y=element_blank(), axis.ticks.y=element_blank()) +
  theme(panel.grid.minor.y=element_blank(), panel.grid.major.y=element_blank()) +
  geom_text(aes(label = ifelse(pct >.05, paste0(lab*100, '%'), '')), position = position_stack(vjust = 0.5), size = 8, family = "bold", color = "black") +
  # geom_text(aes(label = ifelse(age2 == "18-35", paste0(lab*100, '%'), '')), position = position_stack(vjust = 0.5), size = 4, family = "font", color = "white") +
  # geom_text(aes(label = ifelse(age2 == "36-44", paste0(lab*100, '%'), '')), position = position_stack(vjust = 0.5), size = 4, family = "font", color = "white") +
  theme(plot.title = element_text(size = 16)) +
  theme(strip.text.y.left = element_text(angle = 0, hjust = 1)) +
  labs(x = "", y = "",
       title = "How often do you participate in Confession? — By Mass Attendance",
       caption = "@ryanburge | Data: American Catholic Laity Poll 2017") 
save("confession_by_attend.png", wd = 9, ht = 3)




# q07 - response to bishops
p_bishops <- laity2017 |>
  mutate(
    bishops = frcode(
      q07 == 1 ~ "Bishops' views are irrelevant",
      q07 == 2 ~ "Consider but decide myself",
      q07 == 3 ~ "Try to follow bishops' guidance"
    ),
    attend_cat = frcode(
      attend_harm == 1 ~ "Weekly+",
      attend_harm == 2 ~ "Monthly",
      attend_harm == 3 ~ "Seldom/Never"
    )
  ) |>
  filter(!is.na(attend_cat), !is.na(bishops)) |>
  group_by(attend_cat) |>
  ct(bishops, wt = weight1, show_na = FALSE) |>
  mutate(lab = round(pct, 2)) |>
  ggplot(aes(x = 1, y = pct, fill = fct_rev(bishops))) +
  geom_col(color = "black") +
  coord_flip() +
  facet_wrap(~ fct_rev(attend_cat), ncol = 1, strip.position = "left") +
  scale_fill_manual(values = c(
    "Bishops' views are irrelevant"  = "#C1393D",
    "Consider but decide myself"     = "#F4A259",
    "Try to follow bishops' guidance" = "#2C6E49"
  )) +
  geom_text(aes(label = ifelse(pct > .05, paste0(lab * 100, '%'), '')),
            position = position_stack(vjust = 0.5),
            size = 8, family = "bold", color = "black") +
  scale_y_continuous(labels = percent) +
  theme_rb() +
  theme(
    legend.position = "bottom",
    strip.text.y.left = element_text(angle = 0, hjust = 1),
    axis.title.y = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank(),
    panel.grid.minor.y = element_blank(),
    panel.grid.major.y = element_blank(),
    plot.title = element_text(size = 16)
  ) +
  guides(fill = guide_legend(reverse = TRUE, nrow = 1)) +
  labs(x = "", y = "", fill = "",
       title = "How do you respond to bishops' statements on politics/policy?",
       caption = "@ryanburge | Data: American Catholic Laity Poll 2017")

# q03_b - can disagree and be loyal
p_disagree <- laity2017 |>
  mutate(
    disagree = frcode(
      q03_b == 1 ~ "Strongly agree",
      q03_b == 2 ~ "Somewhat agree",
      q03_b == 3 ~ "Somewhat disagree",
      q03_b == 4 ~ "Strongly disagree"
    ),
    attend_cat = frcode(
      attend_harm == 1 ~ "Weekly+",
      attend_harm == 2 ~ "Monthly",
      attend_harm == 3 ~ "Seldom/Never"
    )) |>
  filter(!is.na(attend_cat), !is.na(disagree)) |>
  group_by(attend_cat) |>
  ct(disagree, wt = weight1, show_na = FALSE) |>
  mutate(lab = round(pct, 2)) |>
  ggplot(aes(x = 1, y = pct, fill = disagree)) +
  geom_col(color = "black") +
  coord_flip() +
  facet_wrap(~ fct_rev(attend_cat), ncol = 1, strip.position = "left") +
  scale_fill_manual(values = c(
    "Strongly agree"    = "#C1393D",
    "Somewhat agree"    = "#E07340",
    "Somewhat disagree" = "#68B0AB",
    "Strongly disagree" = "#2C6E49"
  )) +
  geom_text(aes(label = ifelse(pct > .05, paste0(lab * 100, '%'), '')),
            position = position_stack(vjust = 0.5),
            size = 8, family = "bold", color = "black") +
  scale_y_continuous(labels = percent) +
  theme_rb() +
  theme(
    legend.position = "bottom",
    strip.text.y.left = element_text(angle = 0, hjust = 1),
    axis.title.y = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank(),
    panel.grid.minor.y = element_blank(),
    panel.grid.major.y = element_blank(),
    plot.title = element_text(size = 16)
  ) +
  guides(fill = guide_legend(reverse = TRUE, nrow = 1)) +
  labs(x = "", y = "", fill = "",
       title = "Catholics can disagree with Church teaching and still remain loyal",
       caption = "@ryanburge | Data: American Catholic Laity Poll 2017")

p_bishops
save("bishops_by_attend.png", wd = 9, ht = 3)

p_disagree
save("disagree_by_attend.png", wd = 9, ht = 3)

(p_bishops / p_disagree) +
  plot_annotation(
    theme = theme(
      plot.title = element_text(family = "font"),
      plot.subtitle = element_text(family = "font"),
      plot.caption = element_text(family = "font")
    )
  )
save("bishops_disagree_patchwork.png", wd = 9, ht = 6)




conf_means <- laity2017 |>
  mutate(attend_cat = frcode(
    attend_harm == 1 ~ "Weekly+",
    attend_harm == 2 ~ "Monthly",
    attend_harm == 3 ~ "Seldom/Never"
  )) |>
  filter(!is.na(attend_cat), !is.na(conf_index)) |>
  group_by(attend_cat) |>
  summarize(mean_index = weighted.mean(conf_index, weight1, na.rm = TRUE)) |>
  mutate(
    attend_cat = fct_rev(attend_cat),
    label = paste0("Mean: ", round(mean_index, 2))
  )

laity2017 |>
  mutate(attend_cat = frcode(
    attend_harm == 1 ~ "Weekly+",
    attend_harm == 2 ~ "Monthly",
    attend_harm == 3 ~ "Seldom/Never"
  )) |>
  filter(!is.na(attend_cat), !is.na(conf_index)) |>
  group_by(attend_cat) |>
  ct(conf_index, wt = weight1, show_na = FALSE) |>
  mutate(attend_cat = fct_rev(attend_cat)) |>
  ggplot(aes(x = as.factor(conf_index), y = pct, fill = attend_cat)) +
  geom_col(color = "black") +
  geom_text(data = conf_means,
            aes(x = 11, y = Inf, label = label),
            hjust = 1.1, vjust = 1.5,
            inherit.aes = FALSE,
            size = 5, family = "bold") +
  facet_wrap(~ attend_cat, ncol = 1) +
  scale_fill_manual(values = c(
    "Weekly+"      = "#2C6E49",
    "Monthly"      = "#F4A259",
    "Seldom/Never" = "#C1393D"
  )) +
  lab_bar(type = pct, pos = .0185, sz = 6, above = TRUE) +
  y_pct() +
  theme_rb() +
  guides(fill = "none") +
  labs(
    title = "Distribution of Catholic Doctrinal Conformity Index\nby Mass Attendance",
    subtitle = "0 = conformant on no items, 10 = conformant on all items",
    caption = "@ryanburge | Data: American Catholic Laity Poll 2017",
    x = "Number of Items Conformant (out of 10)",
    y = NULL
  )
save("cath_laity_conf_index_attend.png", wd = 6, ht = 10)




conf_pcts_attend <- laity2017 |>
  mutate(attend_cat = frcode(
    attend_harm == 1 ~ "Weekly+",
    attend_harm == 2 ~ "Monthly",
    attend_harm == 3 ~ "Seldom/Never"
  )) |>
  filter(!is.na(attend_cat)) |>
  select(attend_cat, weight1, starts_with("conf_"), -conf_index) |>
  pivot_longer(cols = starts_with("conf_"),
               names_to = "Variable", values_to = "value") |>
  filter(!is.na(value)) |>
  group_by(attend_cat, Variable) |>
  summarize(pct_conformant = weighted.mean(value, weight1, na.rm = TRUE),
            .groups = "drop") |>
  pivot_wider(names_from = attend_cat, values_from = pct_conformant)

tab2 <- conf_summary |>
  left_join(conf_pcts_attend, by = "Variable") |>
  left_join(conf_pcts, by = "Variable") |>
  select(-Variable) |>
  gt(groupname_col = "Category") |>
  opt_table_font(
    font = c(
      "Abel Regular", "Segoe UI",
      default_fonts()[-c(1:3)]
    )) %>%
  cols_label(
    Item = "Conformance Item",
    pct_conformant = "Full Sample",
    `Weekly+` = "Weekly+",
    `Monthly` = "Monthly",
    `Seldom/Never` = "Seldom/Never"
  ) |>
  fmt_percent(columns = c(pct_conformant, `Weekly+`, `Monthly`, `Seldom/Never`),
              decimals = 1) |>
  tab_header(
    title = "Catholic Doctrinal Conformity Index",
    subtitle = "% conformant by Mass attendance level"
  ) |>
  tab_spanner(
    label = "By Attendance",
    columns = c(`Weekly+`, `Monthly`, `Seldom/Never`)
  ) |>
  tab_source_note("Data: American Catholic Laity Poll 2017 | @ryanburge") |>
  tab_style(
    style = cell_fill(color = "#f0f0f0"),
    locations = cells_row_groups()
  ) |>
  tab_style(
    style = cell_text(weight = "bold"),
    locations = cells_row_groups()
  ) |>
  data_color(
    columns = c(pct_conformant, `Weekly+`, `Monthly`, `Seldom/Never`),
    method = "numeric",
    palette = c("#C1393D", "#F4A259", "#2C6E49")
  ) |>
  tab_options(
    table.font.size = 14,
    heading.title.font.size = 18,
    heading.subtitle.font.size = 14
  )

gtsave(tab2, "E://graphs25/cath_conform_3cats.png")


laity2017 |>
  mutate(
    low_mass = if_else(attend_harm == 3, 1, 0),
    low_confession = if_else(q23 == 5, 1, 0)
  ) |>
  filter(!is.na(low_mass), !is.na(low_confession)) |>
  summarize(
    both_low = weighted.mean(low_mass == 1 & low_confession == 1, weight1, na.rm = TRUE)
  )