Code for blog post on information unraveling

information_unraveling_052123.R

library(tidyverse) 

#### FUNCTIONS ####
# Recalculate my expectation for a given recursive step
recalculate_expectation <- function(x0, tau) {
  # possible dollar values of your card
  # (Note: I use a finer grain than 1-cent increments for more precision)
  x <- seq(.0001, .9999, .0001) 
  
  # probability you don't reveal your card based on its value
  p_no_reveal <- 1 - plogis(x - x0, scale = tau)
  
  # return my new expectation after you reject my request
  as.numeric(x %*% (p_no_reveal / sum(p_no_reveal)))
}

# Calculate my expected beliefs over several recursive steps
return_expectations <- function(tau, num_recursions, prior_exp = 0.5) {
  guesser_expectations <- accumulate(
    seq_len(num_recursions), 
    \(acc, nxt) recalculate_expectation(acc, tau), 
    .init = prior_exp
  )
  
  # return a tibble of the results for all recursive steps
  tibble(
    temperature = tau,
    recursion_level = seq_len(num_recursions + 1) - 1,
    expectation = guesser_expectations
  )
}

# Calculate expected payoff for sender given an expected guess
get_expected_payoff <- function(guess_no_reveal, tau) {
  # the code requires a decimal value between 0 and 1, not an integer!
  # (multiply this number by 100 to get a cent value)
  stopifnot(between(guess_no_reveal, 0, 1))
  
  x <- seq(.0001, .9999, .0001)
  p_reveal <- plogis(x - guess_no_reveal, scale = tau)
  
  # return expected sender payoff
  (sum((1 - p_reveal) * guess_no_reveal) + as.numeric(x %*% p_reveal)) /
    length(x)
}

# Helper function to label axes of plots with pretty exponents
label_exp <- function(x) {
  format(as.numeric(x), scientific = TRUE) %>% 
    str_replace("e", "0^{") %>%
    str_remove("\\+") %>% 
    str_c("$", ., "}$") %>% 
    latex2exp::TeX()
}


#### RESULTS ####
# Save results for different parameter values
results <- map_dfr(
  unique(rep(2:10, 5)^rep(-3:1, each = 9)), return_expectations, 20
) %>% 
  mutate(
    sender_payoff = map2_dbl(
      expectation, temperature, 
      ~get_expected_payoff(.x, .y)
    )
  )


#### FIGURES ####
# Plot expectation as function of recursion level for different temps
recursion_plot <- results %>% 
  filter(
    temperature %in% 10^(-3:1),
    recursion_level <= 15
  ) %>% 
  ggplot(aes(recursion_level, expectation, color = as.factor(temperature))) +
  geom_line(linewidth = 1, alpha = 0.8) +
  labs(
    x = "Level of Recursion", y = "Expected Value of Card",
    color = "Decision Noise"
  ) +
  scale_x_continuous(breaks = 0:15) +
  scale_y_continuous(
    labels = \(x) str_c(100 * x, "\u00A2")
  ) +
  scale_color_manual(
    values = RColorBrewer::brewer.pal(6, "Reds")[6:2],
    labels = function(x) {
      format(as.numeric(x), scientific = TRUE) %>% 
        str_replace("e", "0^{") %>% 
        str_remove("\\+") %>% 
        str_c("$", ., "}$") %>% 
        latex2exp::TeX()
    }
  ) +
  theme_classic() +
  theme(legend.position = "bottom")


# Plot expectation as function of temperature for different recursion levels
noise_plot <- results %>% 
  filter(recursion_level %in% c(1, 2, 4, 16)) %>% 
  ggplot(aes(temperature, expectation, color = as.factor(recursion_level))) +
  geom_line(linewidth = 1, alpha = 0.8) +
  labs(
    x = "Decision Noise", y = "Expected Value of Card",
    color = "Level of Recursion"
  ) +
  scale_x_log10(
    breaks = 10^(-3:1),
    labels = label_exp
  ) +
  scale_y_continuous(
    labels = \(x) str_c(100 * x, "\u00A2")
  ) +
  scale_color_manual(values = RColorBrewer::brewer.pal(6, "Blues")[3:6]) +
  theme_classic() +
  theme(legend.position = "bottom")


# Plot distribution of belief over value of card after 1 recursion step
df_distributions <- results %>% 
  filter(
    temperature %in% 10^c(-3, -1, 1),
    between(recursion_level, 1, 3)
  ) %>%
  reframe(
    quality = seq(.001, .999, .001),
    p_ns = 1 - plogis(quality - expectation, scale = temperature),
    p_ns = p_ns / sum(p_ns), # normalize to probability distribution
    .by = c(expectation, temperature, recursion_level)
  ) %>% 
  rename(`Level of Recursion` = recursion_level)

post_dist_plot <- df_distributions %>% 
  filter(quality <= 0.5) %>% # cutoff at 0.5 for clarity
  ggplot(aes(y = p_ns, color = as.factor(temperature))) +
  geom_line(aes(quality), linewidth = 1, alpha = 0.8) +
  geom_point(
    aes(expectation), 
    data = filter(df_distributions, near(expectation, quality, .0005)),
    size = 3
  ) +
  facet_wrap(vars(`Level of Recursion`), labeller = "label_both") +
  labs(
    x = element_blank(), y = "Likelihood of Card Value",
    color = "Decision Noise"
  ) +
  scale_x_continuous(
    breaks = seq(0, 1, 0.1),
    labels = \(x) str_c(100 * x, "\u00A2")
  ) +
  scale_y_continuous(
    breaks = NULL
  ) +
  scale_color_manual(
    values = RColorBrewer::brewer.pal(6, "Reds")[c(6, 4, 2)],
    labels = label_exp
  ) +
  theme_classic() +
  theme(legend.position = "bottom")


# Plot expected payoff of signaler as function of noise
payoff_plot <- results %>% 
  filter(recursion_level %in% c(1, 2, 4, 16)) %>% 
  ggplot(aes(temperature, sender_payoff, color = as.factor(recursion_level))) +
  geom_line(linewidth = 1, alpha = 0.8) +
  labs(
    x = "Decision Noise", y = "Expected Signaler Payoff",
    color = "Level of Recursion"
  ) +
  scale_x_log10(
    breaks = 10^(-3:1),
    labels = label_exp
  ) +
  scale_y_continuous(
    labels = \(x) str_c(100 * x, "\u00A2")
  ) +
  scale_color_manual(values = RColorBrewer::brewer.pal(6, "Blues")[3:6]) +
  theme_classic() +
  theme(legend.position = "bottom")


# ---- Sesssion Info ----
# R version 4.3.0 (2023-04-21)
# Platform: aarch64-apple-darwin20 (64-bit)
# Running under: macOS Ventura 13.3.1
# 
# Matrix products: default
# BLAS:   /System/Library/Frameworks/Accelerate.framework/Versions/A/Frameworks/vecLib.framework/Versions/A/libBLAS.dylib 
# LAPACK: /Library/Frameworks/R.framework/Versions/4.3-arm64/Resources/lib/libRlapack.dylib;  LAPACK version 3.11.0
# 
# locale:
# [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
# 
# time zone: America/New_York
# tzcode source: internal
# 
# attached base packages:
# [1] stats     graphics  grDevices utils     datasets  methods  
# [7] base     
# 
# other attached packages:
# [1] lubridate_1.9.2 forcats_1.0.0   stringr_1.5.0   dplyr_1.1.2    
# [5] purrr_1.0.1     readr_2.1.4     tidyr_1.3.0     tibble_3.2.1   
# [9] ggplot2_3.4.2   tidyverse_2.0.0
# 
# loaded via a namespace (and not attached):
# [1] gtable_0.3.3       compiler_4.3.0     tidyselect_1.2.0  
# [4] scales_1.2.1       yaml_2.3.7         fastmap_1.1.1     
# [7] R6_2.5.1           labeling_0.4.2     generics_0.1.3    
# [10] knitr_1.42         munsell_0.5.0      tzdb_0.3.0        
# [13] pillar_1.9.0       RColorBrewer_1.1-3 rlang_1.1.1       
# [16] utf8_1.2.3         stringi_1.7.12     xfun_0.39         
# [19] timechange_0.2.0   cli_3.6.1          withr_2.5.0       
# [22] magrittr_2.0.3     digest_0.6.31      grid_4.3.0        
# [25] rstudioapi_0.14    hms_1.1.3          latex2exp_0.9.6   
# [28] lifecycle_1.0.3    vctrs_0.6.2        evaluate_0.20     
# [31] glue_1.6.2         farver_2.1.1       blogdown_1.16     
# [34] fansi_1.0.4        colorspace_2.1-0   rmarkdown_2.21    
# [37] tools_4.3.0        pkgconfig_2.0.3    htmltools_0.5.5