Created
March 16, 2022 12:12
-
-
Save FrankRuns/8c619c598378dd4bb21cd64dcf26c3df to your computer and use it in GitHub Desktop.
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
--- | |
title: "Is-Behavior-Change-Happening" | |
author: "frank-corrigan" | |
date: "3/9/2022" | |
output: html_document | |
--- | |
```{r setup, include=FALSE} | |
knitr::opts_chunk$set(echo = TRUE) | |
# libraries | |
library(tidyverse) | |
library(rethinking) | |
``` | |
## Single Behavior - Super Optimistic Starting Point | |
As a leader, I want to be confident that certain behaviors are being demonstrated across my organizations. I can combine my starting intuition with observational data to understand the uncertainty around the proportion of time these certain behaviors are being practiced. | |
```{r context-slide-too-optimistic} | |
# create a grid of estimates for proportion of time behaviors are being used | |
p_grid <- seq(from=0, to=1, length.out = 1000) | |
# create a prior for each estimate in the grid above | |
# in this scenario, the leader is too optimistic saying it's happening | |
# at least 85% of the time. | |
prior <- c(rep(0, 850), rep(1, 100), rep(0, 50)) | |
# create a likelihood for each estimate based on observed data | |
# in this case the observed data is that the leader saw the behavior demonstrated | |
# at 9/10 meetings. | |
likelihood <- dbinom(9, size=10, prob=p_grid) | |
# create posterior. this is a combination of your intuition and | |
# observed data points. | |
unstd.posterior <- likelihood * prior | |
# normalize the posterior so it's a probability | |
posterior <- unstd.posterior / sum(unstd.posterior) | |
# sample the posterior so we can WHAT???? | |
samples <- sample(p_grid, prob=posterior, size=1e4, replace=TRUE) | |
print(paste("The behavior is most likely occuring between,", | |
round(HPDI(samples)[1],4)*100, "and", | |
round(HPDI(samples)[2],4)*100, "percent of the time.")) | |
print(paste("And our best guesss is,", | |
round(median(samples),4)*100, | |
"percent of the time.")) | |
``` | |
### Visualizing the Optimistic Possibilities | |
```{r context-slide-too-optimistic-plot} | |
the_dens <- density(samples) | |
the_data <- tibble(x = the_dens$x, y = the_dens$y) %>% | |
mutate(variable = case_when( | |
x <= 0.9 ~ "Lower", | |
x >= 0.9 ~ "Higher", | |
TRUE ~ NA_character_ | |
)) | |
ggplot(the_data, aes(x,y)) + geom_line() + | |
geom_area(data = filter(the_data, variable == "Lower"), fill = "#d73027") + | |
geom_area(data = filter(the_data, variable == "Higher"), fill = "#1a9850") + | |
scale_x_continuous(limits = c(0.5,1), labels = scales::percent) + | |
geom_vline(xintercept = 0.9) + | |
theme_minimal() + | |
theme(text = element_text(size = 20), | |
plot.title = element_text(face = "bold"), | |
plot.subtitle = element_text(size = 12), | |
axis.text.y = element_blank(), | |
axis.ticks.y = element_blank()) + | |
labs(x="Proportion of Time Behaviors are Happening", | |
y="Density of Possibilities", | |
title="Super Optimistic Starting Assumption", | |
subtitle="Using a super optimistic starting assumption, you can call it a victory...") | |
``` | |
## Single Behavior - Cautious, Realistic Starting Point | |
```{r context-slide-cautious-realistic} | |
# create a grid of estimates for proportion of time behaviors are being used | |
p_grid <- seq(from=0, to=1, length.out = 1000) | |
# create a prior for each estimate in the grid above | |
# in this scenario, the leader is too optimistic saying it's happening | |
# at least 50% of the time. | |
prior <- c(rep(0, 500), rep(1, 450), rep(0, 50)) | |
# prior <- c(rep(0, 675), rep(1, 275), rep(0, 50)) | |
# create a likelihood for each estimate based on observed data | |
# in this case the observed data is that the leader saw the behavior demonstrated | |
# at 9/10 meetings. | |
likelihood <- dbinom(9, size=10, prob=p_grid) | |
# create posterior. this is a combination of your intuition and | |
# observed data points. | |
unstd.posterior <- likelihood * prior | |
# normalize the posterior so it's a probability | |
posterior <- unstd.posterior / sum(unstd.posterior) | |
# sample the posterior so we can WHAT???? | |
samples <- sample(p_grid, prob=posterior, size=1e4, replace=TRUE) | |
print(paste("The bahavior is most likely occuring between,", | |
round(HPDI(samples)[1],4)*100, "and", | |
round(HPDI(samples)[2],4)*100, "percent of the time.")) | |
print(paste("And our best guesss is,", | |
round(median(samples),4)*100, | |
"percent of the time.")) | |
``` | |
### Visualizing the Cautious Possibilities | |
```{r context-slide-cautious-realistic-plot} | |
the_dens <- density(samples) | |
the_data <- tibble(x = the_dens$x, y = the_dens$y) %>% | |
mutate(variable = case_when( | |
x <= 0.9 ~ "Lower", | |
x >= 0.9 ~ "Higher", | |
TRUE ~ NA_character_ | |
)) | |
ggplot(the_data, aes(x,y)) + geom_line() + | |
geom_area(data = filter(the_data, variable == "Lower"), fill = "#d73027") + | |
geom_area(data = filter(the_data, variable == "Higher"), fill = "#1a9850") + | |
scale_x_continuous(limits = c(0.5,1), labels = scales::percent) + | |
geom_vline(xintercept = 0.9) + | |
theme_minimal() + | |
theme(text = element_text(size = 20), | |
plot.title = element_text(face = "bold"), | |
plot.subtitle = element_text(size = 12), | |
axis.text.y = element_blank(), | |
axis.ticks.y = element_blank()) + | |
labs(x="Proportion of Time Behaviors are Happening", | |
y="Density of Possibilities", | |
title="Cautious & Realistic Starting Assumption", | |
subtitle="Using a more cautious & skeptical starting assumption, it's time to listen to your team...") | |
``` | |
### Variations | |
```{r variations} | |
updating <- function(prior, obs_positive, obs) { | |
# inputs | |
# prior = number between 0-950 representing how confident you | |
# are the behaviors are happening at higher rates | |
# obs_count = occurrences you observed behavior out of obs | |
# obs = number of total observations | |
p_grid <- seq(from=0, to=1, length.out = 1000) | |
prior <- c(rep(0, prior), rep(1, 1000-prior-50), rep(0, 50)) | |
likelihood <- dbinom(obs_positive, size=obs, prob=p_grid) | |
unstd.posterior <- likelihood * prior | |
posterior <- unstd.posterior / sum(unstd.posterior) | |
samples <- sample(p_grid, prob=posterior, size=1e4, replace=TRUE) | |
return(median(samples)) | |
} | |
# vecs to play with parameters | |
priors_vec <- c(500, 675, 850) | |
obs_pos_vec <- c(8, 9, 10) | |
obs_vec <- c(10, 100, 1000) | |
# as your starting assumption is more confident, | |
# your updated confidence grows higher | |
for (prior in priors_vec) { | |
print(updating(prior, 9, 10)) | |
} | |
# as number of positive observations increases, | |
# the less uncertainty remains | |
for (obs_pos in obs_pos_vec) { | |
print(updating(500, obs_pos, 10)) | |
} | |
# as the total number of observations increases, | |
# and the rate of positives remains steady, | |
# the certainty converges toward the observed data | |
for (obs in obs_vec) { | |
print(updating(500, obs*0.9, obs)) | |
} | |
``` |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment