ryanburge/ct_selection_untitled-4A657570.R Secret

## ct_selection_untitled-4A657570.R
gg1 <- gss %>%
  mutate(ab = case_when(abany == 1 ~ 1,
                        abany == 2 ~ 0)) %>%
  group_by(year) %>%
  mean_ci(ab, wt = wtssall) %>% na.omit()

gg2 <- gss %>%
  filter(year >= 2021) %>%
  mutate(ab = case_when(abany == 1 ~ 1,
                        abany == 2 ~ 0)) %>%
  group_by(year) %>%
  mean_ci(ab, wt = wtssnrps) %>% na.omit()


all <- bind_rows(gg1, gg2)


ribbon_join <- all %>%
  filter(year %in% c(2016, 2018)) %>%
  summarise(mean = base::mean(mean),
            lower = base::mean(lower),
            upper = base::mean(upper)) %>%
  mutate(year = 2017)

all_plot <- bind_rows(all, ribbon_join) %>% arrange(year)


all_plot %>%
  ggplot(aes(x = year, y = mean)) +

  geom_ribbon(data = filter(all_plot, year <= 2017),
              aes(ymin = lower, ymax = upper),
              fill = "#2a9d8f", alpha = 0.15) +
  geom_ribbon(data = filter(all_plot, year >= 2017),
              aes(ymin = lower, ymax = upper),
              fill = "#e76f51", alpha = 0.2) +
  geom_smooth(method = "loess", span = 0.4,
              color = "gray25", linewidth = 1.1, se = FALSE) +
  geom_point(aes(color = if_else(year < 2017, "pre", "post")),
             data = filter(all_plot, year != 2017),  # don't plot phantom point
             size = 2.5) +
  scale_color_manual(values = c("pre" = "#2a9d8f", "post" = "#e76f51"),
                     guide = "none") +

  # Vertical line at 2017
  geom_vline(xintercept = 2017, linetype = "dashed",
             color = "#e76f51", linewidth = 0.7) +

  # === LONG HORIZON ANNOTATIONS ===
  # Bracket with endcaps for stable era
  annotate("segment", x = 1977, xend = 2016,
           y = 0.64, yend = 0.64,
           color = "#2a9d8f", linewidth = 0.7) +
  annotate("segment", x = 1977, xend = 1977,
           y = 0.635, yend = 0.645,
           color = "#2a9d8f", linewidth = 0.7) +
  annotate("segment", x = 2016, xend = 2016,
           y = 0.635, yend = 0.645,
           color = "#2a9d8f", linewidth = 0.7) +
  annotate("text", x = 1996.5, y = 0.655,
           label = "40 years: no sustained shift — large moves reversed",
           hjust = 0.5, size = 3.3, color = "#2a9d8f", family = "bold") +
    annotate("text", x = 2021.5, y = 0.635,
           label = "+9 ppt since 2016\n(8 years)",
           hjust = 0.5, size = 3.3, color = "#e76f51", family = "bold") +

  scale_x_continuous(breaks = seq(1977, 2024, by = 5),
                     limits = c(1975, 2026)) +
  scale_y_continuous(labels = scales::percent_format(accuracy = 1),
                     limits = c(0.28, 0.68)) +
  labs(
    title = "Support for Abortion Under Any Circumstances in the GSS",
    subtitle = "Public opinion barely budged for four decades, then shifted sharply",
    x = NULL, y = NULL,
    caption = "@ryanburge | Data: General Social Survey, 1977-2024"
  ) +
  theme_rb()

save("abortion_gss_movement.png")


library(tidyverse)

funnel <- tibble(
  stage = c("A Survey of 1,000 Americans",
            "Identify as Christian",
            "Identify as Evangelical",
            "Attend Church Regularly",
            "Attend a Church That Teaches Dispensationalism",
            "Could Actually Articulate The Belief System"),
  n = c(1000, 600, 230, 110, 55, 28)
) %>%
  mutate(stage = fct_rev(fct_inorder(stage)),
         xmin = -n / 2,
         xmax = n / 2)


funnel %>%
  ggplot(.) +
  geom_rect(aes(xmin = xmin, xmax = xmax,
                ymin = as.numeric(stage) - .38,
                ymax = as.numeric(stage) + .38,
                fill = stage),
            color = "black") +
  geom_text(aes(x = 0, y = as.numeric(stage), label = scales::comma(n)),
            color = "white", size = 7, family = "bold") +
  geom_text(aes(x = 530, y = as.numeric(stage), label = stage),
            hjust = 0, size = 3.5, lineheight = .35, family = "bold") +
  scale_fill_manual(values = c("#4a1d5e",   # bottom bar: deep violet
                               "#7a1f3d",   # dark wine
                               "#a34a28",   # burnt sienna
                               "#1f5f5f",   # teal
                               "#1d4e7a",   # dark steel blue
                               "#2d2d2d")) +
xlim(-520, 1050) +
  theme_rb() +
  labs(title = "Why You Can't Measure Dispensationalism with a Survey",
       subtitle = "The denominator collapses before you ever ask the question",
       caption = "@ryanburge | Stages 4-6 are rough estimates. MOE on a subsample of 28: +/- 18 points.") +
  theme(axis.text = element_blank(),
        axis.title = element_blank(),
        panel.grid = element_blank(),
        plot.title = element_text(size = 18, family = "bold", hjust = .5),
        plot.subtitle = element_text(size = 13, family = "font", hjust = .5,
                                     margin = margin(b = 15)),
        plot.caption = element_text(size = 10, family = "font", color = "#666666"))

save("dispensationalism_funnel.png", wd = 9, ht = 6)


yougov <- tribble(
  ~group,                                          ~true_pct, ~est_pct,
  "Have a household income over $1 million",        0,         10,
  "Are transgender",                                1,         12,
  "Have a household income over $500,000",          1,         19,
  "Are Muslim",                                     1,         20,
  "Are Native American",                            1,         20,
  "Are Jewish",                                     2,         25,
  "Live in New York City",                          3,         22,
  "Are gay or lesbian",                             3,         24,
  "Are atheists",                                   3,         28,
  "Are bisexual",                                   4,         24,
  "Are members of a union",                         4,         35,
  "Are vegan or vegetarian",                        5,         25,
  "Are Asian",                                      6,         24,
  "Are a military veteran",                         6,         37,
  "Live in Texas",                                  9,         22,
  "Are left-handed",                               11,         31,
  "Live in California",                            12,         25,
  "Are Black",                                     12,         40,
  "Have an advanced degree",                       12,         34,
  "Are first-generation immigrants",               14,         26,
  "Are Hispanic",                                  17,         35,
  "Are Catholic",                                  22,         39,
  "Own a gun",                                     32,         52,
  "Have at least a college degree",                33,         46,
  "Have a household income over $100,000",         34,         35,
  "Have a passport",                               37,         42,
  "Are Democrats",                                 42,         50,
  "Are obese",                                     42,         56,
  "Are Republicans",                               47,         49,
  "Are married",                                   51,         52,
  "Have at least one child",                       57,         59,
  "Voted in the 2020 election",                    62,         61,
  "Have a household income over $50,000",          62,         50,
  "Are white",                                     64,         59,
  "Own a house",                                   65,         49,
  "Are fully vaccinated against COVID-19",         66,         60,
  "Have a pet",                                    67,         64,
  "Are Christian",                                 70,         57,
  "Have read a book in the past year",             77,         50,
  "Have a household income over $25,000",          82,         65,
  "Have a driver's license",                       83,         71,
  "Own a smartphone",                              85,         80,
  "Have flown on a plane",                         88,         61,
  "Own a car",                                     88,         67,
  "Have at least a high school degree",            89,         65    # numbers truncated in paste; filled from article text
) %>%
  mutate(error = est_pct - true_pct,
         religion = group %in% c("Are Muslim", "Are Jewish", "Are atheists",
                                 "Are Catholic", "Are Christian"))


 yougov %>% filter(religion == TRUE)


 pew %>%
   mutate(yg_group = case_when(reltrad == 60000 ~ "Are Muslim",
                               reltrad == 50000 ~ "Are Jewish",
                               reltrad == 10000 ~ "Are Catholic")) %>%
   ct(yg_group, wt = weight)

 # Atheists
 pew %>%
   mutate(atheist = case_when(unaffildetail == 1 ~ 1, TRUE ~ 0)) %>%
   ct(atheist, wt = weight)

 # Christian = all Christian traditions in RELTRAD
 pew %>%
   mutate(christian = case_when(reltrad %in% c(1100, 1200, 1300, 10000, 20000,
                                               30000, 40001, 40002) ~ 1,
                                TRUE ~ 0)) %>%
   ct(christian, wt = weight)


 yougov <- yougov %>%
   mutate(rls_true = case_when(group == "Are Muslim" ~ 1.2,
                               group == "Are Jewish" ~ 1.7,
                               group == "Are atheists" ~ 4.9,
                               group == "Are Catholic" ~ 18.9,
                               group == "Are Christian" ~ 62.1))


 yougov %>%
   filter(religion == TRUE) %>%
   pivot_longer(cols = c(est_pct, true_pct, rls_true),
                names_to = "type", values_to = "pct") %>%
   mutate(type = frcode(type == "est_pct" ~ "Public's Guess",
                        type == "true_pct" ~ "YouGov's Benchmark (2022)",
                        type == "rls_true" ~ "Pew RLS (2023-24)"),
          group = frcode(group == "Are Christian" ~ "Christian",
                         group == "Are Catholic" ~ "Catholic",
                         group == "Are atheists" ~ "Atheist",
                         group == "Are Jewish" ~ "Jewish",
                         group == "Are Muslim" ~ "Muslim")) %>%
   ggplot(., aes(x = fct_rev(group), y = pct / 100, fill = type)) +
   geom_col(position = position_dodge(width = .8), color = "black", width = .75) +
   geom_text(aes(label = paste0(round(pct), "%")),
             position = position_dodge(width = .8),
             hjust = -.25, size = 5, family = "bold") +
   coord_flip() +
   scale_y_continuous(labels = scales::percent, limits = c(0, .78)) +
   scale_fill_manual(values = c("#a63d40", "#cccccc", "#1f5f5f")) +
   theme_rb(legend = TRUE) +
   labs(x = "",
        y = "Share of American Adults",
        title = "What Americans Think vs. What the Data Says",
        subtitle = "Median public estimate of each group's size, against two benchmarks",
        caption = "@ryanburge | Estimates: YouGov, March 2022 (medians). Benchmarks: YouGov 2022; Pew Religious Landscape Study 2023-24.") +
   theme(plot.title = element_text(size = 18, family = "bold", hjust = .5),
         plot.subtitle = element_text(size = 12, family = "font", hjust = .5))

 save("yougov_religion_three.png", wd = 9, ht = 6)
	gg1 <- gss %>%
	mutate(ab = case_when(abany == 1 ~ 1,
	abany == 2 ~ 0)) %>%
	group_by(year) %>%
	mean_ci(ab, wt = wtssall) %>% na.omit()

	gg2 <- gss %>%
	filter(year >= 2021) %>%
	mutate(ab = case_when(abany == 1 ~ 1,
	abany == 2 ~ 0)) %>%
	group_by(year) %>%
	mean_ci(ab, wt = wtssnrps) %>% na.omit()



	all <- bind_rows(gg1, gg2)


	ribbon_join <- all %>%
	filter(year %in% c(2016, 2018)) %>%
	summarise(mean = base::mean(mean),
	lower = base::mean(lower),
	upper = base::mean(upper)) %>%
	mutate(year = 2017)

	all_plot <- bind_rows(all, ribbon_join) %>% arrange(year)


	all_plot %>%
	ggplot(aes(x = year, y = mean)) +

	geom_ribbon(data = filter(all_plot, year <= 2017),
	aes(ymin = lower, ymax = upper),
	fill = "#2a9d8f", alpha = 0.15) +
	geom_ribbon(data = filter(all_plot, year >= 2017),
	aes(ymin = lower, ymax = upper),
	fill = "#e76f51", alpha = 0.2) +
	geom_smooth(method = "loess", span = 0.4,
	color = "gray25", linewidth = 1.1, se = FALSE) +
	geom_point(aes(color = if_else(year < 2017, "pre", "post")),
	data = filter(all_plot, year != 2017), # don't plot phantom point
	size = 2.5) +
	scale_color_manual(values = c("pre" = "#2a9d8f", "post" = "#e76f51"),
	guide = "none") +

	# Vertical line at 2017
	geom_vline(xintercept = 2017, linetype = "dashed",
	color = "#e76f51", linewidth = 0.7) +

	# === LONG HORIZON ANNOTATIONS ===
	# Bracket with endcaps for stable era
	annotate("segment", x = 1977, xend = 2016,
	y = 0.64, yend = 0.64,
	color = "#2a9d8f", linewidth = 0.7) +
	annotate("segment", x = 1977, xend = 1977,
	y = 0.635, yend = 0.645,
	color = "#2a9d8f", linewidth = 0.7) +
	annotate("segment", x = 2016, xend = 2016,
	y = 0.635, yend = 0.645,
	color = "#2a9d8f", linewidth = 0.7) +
	annotate("text", x = 1996.5, y = 0.655,
	label = "40 years: no sustained shift — large moves reversed",
	hjust = 0.5, size = 3.3, color = "#2a9d8f", family = "bold") +
	annotate("text", x = 2021.5, y = 0.635,
	label = "+9 ppt since 2016\n(8 years)",
	hjust = 0.5, size = 3.3, color = "#e76f51", family = "bold") +

	scale_x_continuous(breaks = seq(1977, 2024, by = 5),
	limits = c(1975, 2026)) +
	scale_y_continuous(labels = scales::percent_format(accuracy = 1),
	limits = c(0.28, 0.68)) +
	labs(
	title = "Support for Abortion Under Any Circumstances in the GSS",
	subtitle = "Public opinion barely budged for four decades, then shifted sharply",
	x = NULL, y = NULL,
	caption = "@ryanburge \| Data: General Social Survey, 1977-2024"
	) +
	theme_rb()

	save("abortion_gss_movement.png")




	library(tidyverse)

	funnel <- tibble(
	stage = c("A Survey of 1,000 Americans",
	"Identify as Christian",
	"Identify as Evangelical",
	"Attend Church Regularly",
	"Attend a Church That Teaches Dispensationalism",
	"Could Actually Articulate The Belief System"),
	n = c(1000, 600, 230, 110, 55, 28)
	) %>%
	mutate(stage = fct_rev(fct_inorder(stage)),
	xmin = -n / 2,
	xmax = n / 2)



	funnel %>%
	ggplot(.) +
	geom_rect(aes(xmin = xmin, xmax = xmax,
	ymin = as.numeric(stage) - .38,
	ymax = as.numeric(stage) + .38,
	fill = stage),
	color = "black") +
	geom_text(aes(x = 0, y = as.numeric(stage), label = scales::comma(n)),
	color = "white", size = 7, family = "bold") +
	geom_text(aes(x = 530, y = as.numeric(stage), label = stage),
	hjust = 0, size = 3.5, lineheight = .35, family = "bold") +
	scale_fill_manual(values = c("#4a1d5e", # bottom bar: deep violet
	"#7a1f3d", # dark wine
	"#a34a28", # burnt sienna
	"#1f5f5f", # teal
	"#1d4e7a", # dark steel blue
	"#2d2d2d")) +
	xlim(-520, 1050) +
	theme_rb() +
	labs(title = "Why You Can't Measure Dispensationalism with a Survey",
	subtitle = "The denominator collapses before you ever ask the question",
	caption = "@ryanburge \| Stages 4-6 are rough estimates. MOE on a subsample of 28: +/- 18 points.") +
	theme(axis.text = element_blank(),
	axis.title = element_blank(),
	panel.grid = element_blank(),
	plot.title = element_text(size = 18, family = "bold", hjust = .5),
	plot.subtitle = element_text(size = 13, family = "font", hjust = .5,
	margin = margin(b = 15)),
	plot.caption = element_text(size = 10, family = "font", color = "#666666"))

	save("dispensationalism_funnel.png", wd = 9, ht = 6)



	yougov <- tribble(
	~group, ~true_pct, ~est_pct,
	"Have a household income over $1 million", 0, 10,
	"Are transgender", 1, 12,
	"Have a household income over $500,000", 1, 19,
	"Are Muslim", 1, 20,
	"Are Native American", 1, 20,
	"Are Jewish", 2, 25,
	"Live in New York City", 3, 22,
	"Are gay or lesbian", 3, 24,
	"Are atheists", 3, 28,
	"Are bisexual", 4, 24,
	"Are members of a union", 4, 35,
	"Are vegan or vegetarian", 5, 25,
	"Are Asian", 6, 24,
	"Are a military veteran", 6, 37,
	"Live in Texas", 9, 22,
	"Are left-handed", 11, 31,
	"Live in California", 12, 25,
	"Are Black", 12, 40,
	"Have an advanced degree", 12, 34,
	"Are first-generation immigrants", 14, 26,
	"Are Hispanic", 17, 35,
	"Are Catholic", 22, 39,
	"Own a gun", 32, 52,
	"Have at least a college degree", 33, 46,
	"Have a household income over $100,000", 34, 35,
	"Have a passport", 37, 42,
	"Are Democrats", 42, 50,
	"Are obese", 42, 56,
	"Are Republicans", 47, 49,
	"Are married", 51, 52,
	"Have at least one child", 57, 59,
	"Voted in the 2020 election", 62, 61,
	"Have a household income over $50,000", 62, 50,
	"Are white", 64, 59,
	"Own a house", 65, 49,
	"Are fully vaccinated against COVID-19", 66, 60,
	"Have a pet", 67, 64,
	"Are Christian", 70, 57,
	"Have read a book in the past year", 77, 50,
	"Have a household income over $25,000", 82, 65,
	"Have a driver's license", 83, 71,
	"Own a smartphone", 85, 80,
	"Have flown on a plane", 88, 61,
	"Own a car", 88, 67,
	"Have at least a high school degree", 89, 65 # numbers truncated in paste; filled from article text
	) %>%
	mutate(error = est_pct - true_pct,
	religion = group %in% c("Are Muslim", "Are Jewish", "Are atheists",
	"Are Catholic", "Are Christian"))


	yougov %>% filter(religion == TRUE)


	pew %>%
	mutate(yg_group = case_when(reltrad == 60000 ~ "Are Muslim",
	reltrad == 50000 ~ "Are Jewish",
	reltrad == 10000 ~ "Are Catholic")) %>%
	ct(yg_group, wt = weight)

	# Atheists
	pew %>%
	mutate(atheist = case_when(unaffildetail == 1 ~ 1, TRUE ~ 0)) %>%
	ct(atheist, wt = weight)

	# Christian = all Christian traditions in RELTRAD
	pew %>%
	mutate(christian = case_when(reltrad %in% c(1100, 1200, 1300, 10000, 20000,
	30000, 40001, 40002) ~ 1,
	TRUE ~ 0)) %>%
	ct(christian, wt = weight)



	yougov <- yougov %>%
	mutate(rls_true = case_when(group == "Are Muslim" ~ 1.2,
	group == "Are Jewish" ~ 1.7,
	group == "Are atheists" ~ 4.9,
	group == "Are Catholic" ~ 18.9,
	group == "Are Christian" ~ 62.1))


	yougov %>%
	filter(religion == TRUE) %>%
	pivot_longer(cols = c(est_pct, true_pct, rls_true),
	names_to = "type", values_to = "pct") %>%
	mutate(type = frcode(type == "est_pct" ~ "Public's Guess",
	type == "true_pct" ~ "YouGov's Benchmark (2022)",
	type == "rls_true" ~ "Pew RLS (2023-24)"),
	group = frcode(group == "Are Christian" ~ "Christian",
	group == "Are Catholic" ~ "Catholic",
	group == "Are atheists" ~ "Atheist",
	group == "Are Jewish" ~ "Jewish",
	group == "Are Muslim" ~ "Muslim")) %>%
	ggplot(., aes(x = fct_rev(group), y = pct / 100, fill = type)) +
	geom_col(position = position_dodge(width = .8), color = "black", width = .75) +
	geom_text(aes(label = paste0(round(pct), "%")),
	position = position_dodge(width = .8),
	hjust = -.25, size = 5, family = "bold") +
	coord_flip() +
	scale_y_continuous(labels = scales::percent, limits = c(0, .78)) +
	scale_fill_manual(values = c("#a63d40", "#cccccc", "#1f5f5f")) +
	theme_rb(legend = TRUE) +
	labs(x = "",
	y = "Share of American Adults",
	title = "What Americans Think vs. What the Data Says",
	subtitle = "Median public estimate of each group's size, against two benchmarks",
	caption = "@ryanburge \| Estimates: YouGov, March 2022 (medians). Benchmarks: YouGov 2022; Pew Religious Landscape Study 2023-24.") +
	theme(plot.title = element_text(size = 18, family = "bold", hjust = .5),
	plot.subtitle = element_text(size = 12, family = "font", hjust = .5))

	save("yougov_religion_three.png", wd = 9, ht = 6)
No results found