The above chart is one of my favorite graphs I've ever made. To explain the backstory, Monica and I are having a baby (due in January). To celebrate, we had our immediate family members submit guesses for the sex, weight, and birthdate. To make it a competition, we decided to apply the following scoring rules:
10 points for guessing the gender right
10 points minus the 1/2 point for each ounce you were off on the weight (0 points minimum)
10 points minus the number of days you were off on the due date (0 points minimum)
The above chart shows where everyone's guesses lined up and is colored by who will win based on when the baby arrives and how much it weighs. Note that this chart is already factoring in the points scored for those who guessed boy, which is why Monica and I are both out of the running already.
One reason I love this chart is that it's one of those things that scientists in the 1800s would have spent weeks calculating by hand to painstakingly produce it, and anyone lazier than that would have just waited till the baby came and then did the simple check to see who won. We all would have had rough intuitive ideas about how we were doing and what needed to happen to win, but the chart is able to crystallize that intuition and make it much easier to wrap our minds around all the scenarios. A computer can take all 1,745 possible outcomes shown in the graph above and calculate the scores for all 17 guessers almost instantaneously. Those 30,000 results can then be simplified down to one plot that is both enlightening and beautiful. I love it! Here's the code to produce the graph (Note: I used Podium's internal R package for the coloring, so this code will have a different color scheme):
library(lubridate)
library(tidyverse)
guesses = tibble(name=c("Adelaide", "Myra", "Ryan O",
"Jackson", "Monica", "Spencer",
"Aaron", "Michelle", "Laura",
"Jared", "Ryan C", "Danielle",
"Erica", "Mark", "Maureen", "Kyle",
"Elder Curtis", "Lydia"
),
gender=c("Boy", "Girl", "Boy", "Girl",
"Girl", "Boy", "Boy", "Girl", "Girl",
"Boy", "Girl", "Boy", "Boy", "Girl",
"Boy", "Girl", "Girl", "Girl"
),
weight = c(10, 15, 7.5, (9*16+3)/16, 8.5,
8+1/16, 6+15/16, 7+12/16,
7+2/16, 9+2/16, 6+12/16,
8+1/16, 8+13/16, 7+2/16,
8+6/16, 7+12/16, 7+9/16, 7+1/4),
due_date = ymd(paste0("2022-",
c("1-20", "1-10",
"1-14",
"1-27", "1-23", "1-21",
"1-14", "1-16", "1-10",
"1-25", "1-29", "1-20",
"1-23", "1-10", "1-21",
"1-14", "1-28", "1-12"))))
scores = expand_grid(weight= seq(6.5, 10.5, by=1/16),
birthday = seq.Date(ymd("2022-01-07"), to=ymd("2022-02-02"),
by=1)) %>%
rowwise() %>%
summarize(Guesser = guesses$name,
score = if_else(guesses$gender=="Boy", 10, 0)+
pmax(0, 10-8*abs(guesses$weight-weight))+
pmax(0, 10-abs(as.numeric(guesses$due_date-birthday))),
weight=weight,
birthday=birthday) %>%
group_by(weight, birthday) %>%
summarize(winner=Guesser[score==max(score)][1],
winning_points=max(score),
ties = sum(score==max(score))>1) %>%
ungroup %>%
mutate(weight_upper=weight+1/16, next_day=birthday+1,
winner=if_else(ties, "Tie", winner))
ggplot(guesses %>% filter(name!="Myra"), aes(x=due_date, y=weight,
label=name))+
geom_rect(data=scores, aes(xmin=birthday, ymin=weight, fill=winner,
xmax=next_day, ymax=weight_upper),
inherit.aes = F,
alpha=.5)+
geom_point(size=3, aes(color=gender))+
ggrepel::geom_text_repel(show.legend = F)+
geom_vline(xintercept = ymd("2022-01-28"), color="green")+
annotate("text", x=ymd("2022-01-28"), y=10.7, label="Due")+
theme_bw()+
scale_x_date("Birthday - January", date_labels = "%d",
date_breaks = "1 day", date_minor_breaks = "1 day", expand = expansion())+
scale_y_continuous("Weight (lbs)", breaks=function(x)(seq(floor(x[1]), ceiling(x[2]), by=1)),
minor_breaks = function(x)(seq(floor(x[1]), ceiling(x[2]), by=1/4)),
expand=expansion(add=c(0, .15)))+
guides(color=guide_legend(title=NULL), fill=guide_legend("Winner:"))+
theme(legend.position = "bottom")+
scale_color_manual(values=c("#1eb6e1", "#f30cb4"))
ggtitle("Guessing Game Win Chart")
Comments