Skip to content

Instantly share code, notes, and snippets.

@adambear91
Last active May 22, 2023 03:08
Show Gist options
  • Save adambear91/e6c0342b2e7edc1af9851d32b665b5c2 to your computer and use it in GitHub Desktop.
Save adambear91/e6c0342b2e7edc1af9851d32b665b5c2 to your computer and use it in GitHub Desktop.
Code for blog post on information unraveling
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment