knitr::include_graphics("https://c1.staticflickr.com/3/2940/14582969029_a4ca9475a7_b.jpg")


The Problem


This problem comes from FiveThirtyEight’s The Riddler. Copied from the original posting is the situation:


“You are a super villain whose two roommates also happen to be super villains.

A problem: James Bond has discovered your whereabouts and is coming to get you. Good thing all three of you are great at designing spy-capturing nets. Time to fortify your defenses.

You and all your roommates will place one net each, but you’re villains, so you each want to design the trap that actually nabs Bond. One major thing to keep in mind: Villains’ nets, as everyone knows, are always placed in threes, and in increasing order of effectiveness. So if your lair is equipped with nets that capture an invader 10, 20 and 50 percent of the time, for example, James Bond has to try to get past them in that order. Unless, of course, he gets captured first. So you each need to design not the most effective net, but the net you think is most likely to grab Bond before someone else’s. (You don’t know what traps your roommates are designing before all three are deployed.)

Keep that in mind as you design and name your new net. Specifically, calibrate the percentage chance that it will capture James Bond if he tries to pass by it. Remember, your goal is for your trap to ensnare James Bond. Ninety-nine percent effectiveness sounds like a great trap, but it is also likely to come at the end of the three traps, and Bond may have already been captured before he gets to it."


Framing the Question


Players

There are 3 players, you and your two roommates.


Actions

Each player chooses to build a net with a probability between 0 and 1 inclusive of catching Bond.

\(P_{i}\) where \(i \in [1,3]\) can choose net of probability \(x_{i} \in [0,1]\)


Payoffs

This is the payoff function for player one but can be applied symmetrically to the other players.

\[ \mu(x_{1}, x_{2}, x_{3}) = \left\{ \begin{array}{ll} x_{1} < x_{2} \quad \& \quad x_{1} < x_{3} , \quad \quad x_{1} \\ x_{1} > x_{2} \quad \& \quad x_{1} < x_{3} , \quad \quad x_{1}(1-x_{2}) \\ x_{1} < x_{2} \quad \& \quad x_{1} > x_{3} , \quad \quad x_{1}(1-x_{3}) \\ x_{1} > x_{2} \quad \& \quad x_{1} > x_{3} , \quad \quad x_{1}(1-x_{2})(1-x_{3}) \end{array} \right. \]


Best Responses

This portion is still under development but eventually I will set up a game theory solution to this problem. Until then, this section can be useful for framing the problem.


The BruteForce ™ Approach


The Idea

An initial solution, BruteForce ™ assumes that people randomly decide how good to build their nets. This assumption is likely invalid, but gives us a starting point before a Nash Equalibrium is found.


Data Generation

Here I generate 10 million rows of random data of values between 0 and 1 for three players. The first 10 rows of the data are shown below.

# Loading Packages
library(dplyr)
library(knitr)
library(kableExtra)
library(ggplot2)

# Setting seed for reproducability
set.seed(007)

# test dataset (simulating 10 million random picks)
test <- data.table::data.table(x = runif(10000000), y =  runif(10000000), z = runif(10000000))

head(test, 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x y z
0.9889093 0.9107375 0.5271469
0.3977455 0.2104637 0.5561906
0.1156978 0.4790141 0.5366160
0.0697487 0.3040859 0.8152530
0.2437494 0.5215345 0.0293481
0.7920104 0.4212988 0.8670009
0.3400624 0.0314055 0.6705283
0.9720625 0.9279826 0.8985070
0.1658555 0.9931123 0.7809951
0.4591037 0.7854317 0.2821976


Applying the Payoffs

I calculate the payoffs (probabilities of catching Bond) for player x for each row conditional on the choices for the other two players’ actions.

# Score assignment based off of description
test[ x < y & x < z, xscore := x]
test[ x < y & x > z, xscore := x*(1 - z)]
test[ x > y & x < z, xscore := x*(1 - y)]
test[ x > y & x > z, xscore := x*(1 - y)*(1 - z)]

head(test, 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x y z xscore
0.9889093 0.9107375 0.5271469 0.0417399
0.3977455 0.2104637 0.5561906 0.3140345
0.1156978 0.4790141 0.5366160 0.1156978
0.0697487 0.3040859 0.8152530 0.0697487
0.2437494 0.5215345 0.0293481 0.2365958
0.7920104 0.4212988 0.8670009 0.4583374
0.3400624 0.0314055 0.6705283 0.3293825
0.9720625 0.9279826 0.8985070 0.0071051
0.1658555 0.9931123 0.7809951 0.1658555
0.4591037 0.7854317 0.2821976 0.3295457


Picking a Probability

Since these probabilites are continuous and we want enough data per each choice to know that ideal choice (the one with the highest chance of catching Bond) aren’t just due to random chance, I bin the probabilities to the nearest tenth of a percentage point.

For each binned BruteForce ™ probability, I then find the median score. The binned probability with the highest score is the specification I build my net to. Based on this, if people choose their picks randomly my net should be the one to catch bond about 40% of the time with a net that catches Bond 56.4% of time. The top 10 choices are displayed below.

# Making choices discrete (to whole percentage point)
test[, x_cut := substr(as.character(x) , 1 , 5)]

# Creating average score by choice
test[,av_score := median(xscore), by = as.factor(x_cut)]

# Checking out the average scores by the binned scores
new <- test[!duplicated(x_cut)] %>%
  select(x_cut, av_score) %>%
  .[order(as.numeric(x_cut))]
  
new %>%
  .[order(as.numeric(av_score), decreasing = TRUE)] %>%
  head(. , 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x_cut av_score
0.564 0.4018656
0.558 0.4015816
0.593 0.4013792
0.559 0.3997753
0.582 0.3994711
0.578 0.3990748
0.577 0.3980202
0.591 0.3978163
0.580 0.3977812
0.598 0.3977391


Checking the Distribution

The distribution seems to confirm that the optimal choice when your opponants are choosing randomly is somewhere around 55%.

ggplot() + 
  geom_area(aes(y = av_score, x = as.numeric(x_cut), fill = "blue"), data = new, stat="identity") + 
  geom_vline(xintercept = .564) +
  coord_cartesian(xlim=c(0,1)) +
  xlab("Net Probabilities") +
  ylab("Chance of Catching Bond") +
  ggtitle("Choosing the Best Net", subtitle = "BruteForce is Shown in Black") +
  scale_fill_manual(values = "#85C1E9")


The AggraCounter ™ Approach


The Idea

An initial solution, AggraCounter ™ assumes that people tend to build nets with high chances of getting bond to build their nets.


Data Generation

Here I generate 10 million rows of data of values between 0 and 1 for three players. The first 10 rows of the data are shown below.

# Setting seed for reproducability
set.seed(007)

# test dataset (simulating 10 million random picks)
test <- data.table::data.table(x = runif(10000000), 
                               y = truncnorm::rtruncnorm(n=10000000, a=0, b=1, mean= .7, sd = .15), 
                               z = truncnorm::rtruncnorm(n=10000000, a=0, b=1, mean= .7, sd = .15))

head(test, 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x y z
0.9889093 0.9017966 0.6470216
0.3977455 0.6921058 0.6215727
0.1156978 0.7081008 0.7791315
0.0697487 0.4209209 0.6804043
0.2437494 0.8777723 0.8356827
0.7920104 0.6657937 0.7984308
0.3400624 0.3692735 0.6511528
0.9720625 0.7978182 0.8167255
0.1658555 0.6842499 0.6562436
0.4591037 0.7343893 0.7447049


Applying the Payoffs

I calculate the payoffs (probabilities of catching Bond) for player x for each row conditional on the choices for the other two players’ actions.

# Score assignment based off of description
test[ x < y & x < z, xscore := x]
test[ x < y & x > z, xscore := x*(1 - z)]
test[ x > y & x < z, xscore := x*(1 - y)]
test[ x > y & x > z, xscore := x*(1 - y)*(1 - z)]

head(test, 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x y z xscore
0.9889093 0.9017966 0.6470216 0.0342792
0.3977455 0.6921058 0.6215727 0.3977455
0.1156978 0.7081008 0.7791315 0.1156978
0.0697487 0.4209209 0.6804043 0.0697487
0.2437494 0.8777723 0.8356827 0.2437494
0.7920104 0.6657937 0.7984308 0.2646948
0.3400624 0.3692735 0.6511528 0.3400624
0.9720625 0.7978182 0.8167255 0.0360196
0.1658555 0.6842499 0.6562436 0.1658555
0.4591037 0.7343893 0.7447049 0.4591037


Picking a Probability

Since these probabilites are continuous and we want enough data per each choice to know that ideal choice (the one with the highest chance of catching Bond) aren’t just due to random chance, I bin the probabilities to the nearest tenth of a percentage point.

For each binned AggraCounter ™ probability, I then find the median score. The binned probability with the highest score is the specification I build my net to. Based on this, if people choose their picks randomly my net should be the one to catch bond about 61% of the time with a net that catches Bond 61.6% of time. The top 10 choices are displayed below.

# Making choices discrete (to whole percentage point)
test[, x_cut := substr(as.character(x) , 1 , 5)]

# Creating average score by choice
test[,av_score := median(xscore), by = as.factor(x_cut)]

# Checking out the average scores by the binned scores
new <- test[!duplicated(x_cut)] %>%
  select(x_cut, av_score) %>%
  .[order(as.numeric(x_cut))]
  
new %>%
  .[order(as.numeric(av_score), decreasing = TRUE)] %>%
  head(. , 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x_cut av_score
0.616 0.6160026
0.615 0.6150065
0.614 0.6140034
0.613 0.6130142
0.612 0.6120225
0.611 0.6110242
0.610 0.6100290
0.609 0.6090562
0.608 0.6080523
0.607 0.6070590


Checking the Distribution

The distribution seems to confirm that the optimal choice when your opponants are choosing randomly is very sharp at the 61% mark.

ggplot() + 
  geom_area(aes(y = av_score, x = as.numeric(x_cut), fill = "blue"), data = new, stat="identity") + 
  geom_vline(xintercept = 0.616) +
  coord_cartesian(xlim=c(0,1)) +
  xlab("Net Probabilities") +
  ylab("Chance of Catching Bond") +
  ggtitle("Choosing the Best Net", subtitle = "AggraCounter is Shown in Black") +
  scale_fill_manual(values = "#85C1E9")


The SmallCounter ™ Approach


The Idea

An initial solution, SmallCounter ™ assumes that people decide to build their nets around the 30% mark. Aka that people tend to build bad nets.


Data Generation

Here I generate 10 million rows of data of values between 0 and 1 for three players. The first 10 rows of the data are shown below.

# Setting seed for reproducability
set.seed(007)

# test dataset (simulating 10 million random picks)
test <- data.table::data.table(x = runif(10000000), 
                               y = truncnorm::rtruncnorm(n=10000000, a=0, b=1, mean= .3, sd = .15), 
                               z = truncnorm::rtruncnorm(n=10000000, a=0, b=1, mean= .3, sd = .15))

head(test, 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x y z
0.9889093 0.5017966 0.4177832
0.3977455 0.2921058 0.2248913
0.1156978 0.3081008 0.3449043
0.0697487 0.0209209 0.1005773
0.2437494 0.6694601 0.6211516
0.7920104 0.4777723 0.2833111
0.3400624 0.2657937 0.5832725
0.9720625 0.6357605 0.4727607
0.1658555 0.3978182 0.4736066
0.4591037 0.2842499 0.4568382


Applying the Payoffs

I calculate the payoffs (probabilities of catching Bond) for player x for each row conditional on the choices for the other two players’ actions.

# Score assignment based off of description
test[ x < y & x < z, xscore := x]
test[ x < y & x > z, xscore := x*(1 - z)]
test[ x > y & x < z, xscore := x*(1 - y)]
test[ x > y & x > z, xscore := x*(1 - y)*(1 - z)]

head(test, 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x y z xscore
0.9889093 0.5017966 0.4177832 0.2868454
0.3977455 0.2921058 0.2248913 0.2182409
0.1156978 0.3081008 0.3449043 0.1156978
0.0697487 0.0209209 0.1005773 0.0682895
0.2437494 0.6694601 0.6211516 0.2437494
0.7920104 0.4777723 0.2833111 0.2964295
0.3400624 0.2657937 0.5832725 0.2496759
0.9720625 0.6357605 0.4727607 0.1866762
0.1658555 0.3978182 0.4736066 0.1658555
0.4591037 0.2842499 0.4568382 0.1784849


Picking a Probability

Since these probabilites are continuous and we want enough data per each choice to know that ideal choice (the one with the highest chance of catching Bond) aren’t just due to random chance, I bin the probabilities to the nearest tenth of a percentage point.

For each binned SmallCounter ™ probability, I then find the median score. The binned probability with the highest score is the specification I build my net to. Based on this, if people choose their picks randomly my net should be the one to catch bond about 47% of the time with a net that catches Bond 99.7% of time. The top 10 choices are displayed below.

# Making choices discrete (to whole percentage point)
test[, x_cut := substr(as.character(x) , 1 , 5)]

# Creating average score by choice
test[,av_score := median(xscore), by = as.factor(x_cut)]

# Checking out the average scores by the binned scores
new <- test[!duplicated(x_cut)] %>%
  select(x_cut, av_score) %>%
  .[order(as.numeric(x_cut))]
  
new %>%
  .[order(as.numeric(av_score), decreasing = TRUE)] %>%
  head(. , 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x_cut av_score
0.997 0.4714578
0.994 0.4709338
0.993 0.4697044
0.999 0.4690410
0.992 0.4687508
0.995 0.4681786
0.998 0.4680476
0.996 0.4680050
0.989 0.4668749
0.987 0.4667903


Checking the Distribution

The distribution seems to confirm that the optimal choice when your opponants are building a bad net is to build a good net.

ggplot() + 
  geom_area(aes(y = av_score, x = as.numeric(x_cut), fill = "blue"), data = new, stat="identity") + 
  geom_vline(xintercept = 0.997) +
  coord_cartesian(xlim=c(0,1)) +
  xlab("Net Probabilities") +
  ylab("Chance of Catching Bond") +
  ggtitle("Choosing the Best Net", subtitle = "SmallCounter is Shown in Black") +
  scale_fill_manual(values = "#85C1E9")

The MixedBag ™ Approach


The Idea

An initial solution, MixedBag ™ assumes that one of your opponants builds a good net and the other builds a bad net.


Data Generation

Here I generate 10 million rows of data of values between 0 and 1 for three players. The first 10 rows of the data are shown below.

# Setting seed for reproducability
set.seed(007)

# test dataset (simulating 10 million random picks)
test <- data.table::data.table(x = runif(10000000), 
                               y = truncnorm::rtruncnorm(n=10000000, a=0, b=1, mean= .7, sd = .15), 
                               z = truncnorm::rtruncnorm(n=10000000, a=0, b=1, mean= .3, sd = .15))

head(test, 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x y z
0.9889093 0.9017966 0.2470216
0.3977455 0.6921058 0.2215727
0.1156978 0.7081008 0.6435397
0.0697487 0.4209209 0.3791315
0.2437494 0.8777723 0.2804043
0.7920104 0.6657937 0.4356827
0.3400624 0.3692735 0.3984308
0.9720625 0.7978182 0.2511528
0.1658555 0.6842499 0.4167255
0.4591037 0.7343893 0.2562436


Applying the Payoffs

I calculate the payoffs (probabilities of catching Bond) for player x for each row conditional on the choices for the other two players’ actions.

# Score assignment based off of description
test[ x < y & x < z, xscore := x]
test[ x < y & x > z, xscore := x*(1 - z)]
test[ x > y & x < z, xscore := x*(1 - y)]
test[ x > y & x > z, xscore := x*(1 - y)*(1 - z)]

head(test, 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x y z xscore
0.9889093 0.9017966 0.2470216 0.0731249
0.3977455 0.6921058 0.2215727 0.3096159
0.1156978 0.7081008 0.6435397 0.1156978
0.0697487 0.4209209 0.3791315 0.0697487
0.2437494 0.8777723 0.2804043 0.2437494
0.7920104 0.6657937 0.4356827 0.1493719
0.3400624 0.3692735 0.3984308 0.3400624
0.9720625 0.7978182 0.2511528 0.1471734
0.1658555 0.6842499 0.4167255 0.1658555
0.4591037 0.7343893 0.2562436 0.3414613


Picking a Probability

Since these probabilites are continuous and we want enough data per each choice to know that ideal choice (the one with the highest chance of catching Bond) aren’t just due to random chance, I bin the probabilities to the nearest tenth of a percentage point.

For each binned MixedBag ™ probability, I then find the median score. The binned probability with the highest score is the specification I build my net to. Based on this, if people choose their picks randomly my net should be the one to catch bond about 39% of the time with a net that catches Bond 62 of time. The top 10 choices are displayed below.

# Making choices discrete (to whole percentage point)
test[, x_cut := substr(as.character(x) , 1 , 5)]

# Creating average score by choice
test[,av_score := median(xscore), by = as.factor(x_cut)]

# Checking out the average scores by the binned scores
new <- test[!duplicated(x_cut)] %>%
  select(x_cut, av_score) %>%
  .[order(as.numeric(x_cut))]
  
new %>%
  .[order(as.numeric(av_score), decreasing = TRUE)] %>%
  head(. , 10) %>%
  kable() %>%
  kable_styling("striped", full_width = FALSE) %>%
  row_spec(0, bold = T, color = "white", background = "#5e78d6")
x_cut av_score
0.620 0.3857079
0.601 0.3856839
0.593 0.3856610
0.622 0.3855008
0.600 0.3851163
0.598 0.3850324
0.617 0.3848407
0.606 0.3847336
0.613 0.3846831
0.592 0.3846129


Checking the Distribution

The distribution seems to confirm that the optimal choice when one of your opponants is building a bad net and the other is building a good net is somewhere around low 60% points.

ggplot() + 
  geom_area(aes(y = av_score, x = as.numeric(x_cut), fill = "blue"), data = new, stat="identity") + 
  geom_vline(xintercept = 0.620) +
  coord_cartesian(xlim=c(0,1)) +
  xlab("Net Probabilities") +
  ylab("Chance of Catching Bond") +
  ggtitle("Choosing the Best Net", subtitle = "MixedBag is Shown in Black") +
  scale_fill_manual(values = "#85C1E9")