Instantly share code, notes, and snippets.

Last active May 22, 2023 03:08
Show Gist options
• Save adambear91/e6c0342b2e7edc1af9851d32b665b5c2 to your computer and use it in GitHub Desktop.
Code for blog post on information unraveling
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters
 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