Finding an Optimal Strategy for Shut The Box: Part 3
This is the third in a series of posts that investigates the creation of an optimal strategy for the game Shut the Box, and I’d recommend you read the first two blogs before continuing.
At the end of the second blog, we’d created a StrategyPerformance (and GameSpace) dataframe that provided information about the WinRate of any strategy assuming that all choices after it were made at random amongst the available choices.
In this blog we’re firstly going to take the output from the previous blog, and join the full GameSpace dataframe with the StrategyPerformance dataframe to ensure that the GameSpace dataframe has strategy performance context. In my case, two strategies were never used in the 5 million simulations (go figure!), so I have filled in their Occurrences and WinRate values with 0.
library(dplyr)
max_score_to_win = 3
GameSpace = read.csv('GameSpace.csv')
# Update the Strategy Count
GameSpace = GameSpace %>% group_by(RivalGroup) %>% mutate(StrategyCount = length(RivalGroup))
WinLoss = data.frame(Outcome = rep("", NumGames))
StrategyPerformance = read.csv('StrategyPerformance_Random.csv')
GameSpace = left_join(GameSpace, StrategyPerformance[,c("StrategyChosen", "WinRate", "Occurrences")], by = c("StrategyNum" = "StrategyChosen"))
# Handle case where strategy never used in a simulation
GameSpace$Occurrences = ifelse(is.na(GameSpace$Occurrences), 0, GameSpace$Occurrences)
GameSpace$WinRate = ifelse(is.na(GameSpace$WinRate), 0, GameSpace$WinRate)
GameSpace$TimesWin = round(GameSpace$WinRate * GameSpace$Occurrences,0)Next we’ll find those strategies that have been used fewer than 50 times and then create sufficient simulations starting with the chosen strategy (and using random choice for any subsequent decisions) to move the sample size to 50.
As we do this, we will update the existing performance data for all strategies in the GameSpace dataframe.
run_specific_strategies = function(GS, CountRequired)
{
# Find all the competing strategies with fewer than CountRequired occurrences
RarelyUsedStrategies = GS %>% filter(StrategyCount > 1, Occurrences < CountRequired) %>% select(StateNum, TotalRolled, StrategyNum, Occurrences)
completed = 0
for (RUS in RarelyUsedStrategies$StrategyNum)
{
for (GameNum in 1:(CountRequired - RarelyUsedStrategies$Occurrences[RarelyUsedStrategies$StrategyNum == RUS]))
{
res_row = 0
Results = data.frame(GameNum = rep(0,10),
TossNum = rep(0,10),
StateNum = rep("",10),
TotalRolled = rep(0,10),
StrategyChosen = rep(0,10),
TargetSum = rep(0,10),
Result = rep("",10))
res_row = res_row + 1
Results$GameNum[res_row] = GameNum
Results$StateNum[res_row] = RUS
Results$TossNum[res_row] = 1
ThisResult = "Undetermined"
while (ThisResult == "Undetermined")
{
if(res_row == 1)
{
Results$TotalRolled[res_row] = RarelyUsedStrategies$TotalRolled[RarelyUsedStrategies$StrategyNum == RUS]
CandidateStrategies = RUS
} else
{
Results$TotalRolled[res_row] = sample(1:6,1) + sample(1:6,1)
CandidateStrategies = GS$StrategyNum[GS$StateNum == Results$StateNum[res_row] & GS$TotalRolled == Results$TotalRolled[res_row]]
}
if (length(CandidateStrategies) == 1)
{
Results$StrategyChosen[res_row] = CandidateStrategies
} else
{
Results$StrategyChosen[res_row] = sample(CandidateStrategies, 1)
}
# Check for win
Results$TargetSum[res_row] = ifelse(GS$F1[GS$StrategyNum == Results$StrategyChosen[res_row]] != 999, GS$F1[GS$StrategyNum == Results$StrategyChosen[res_row]], 0) +
ifelse(GS$F2[GS$StrategyNum == Results$StrategyChosen[res_row]] != 999, GS$F2[GS$StrategyNum == Results$StrategyChosen[res_row]], 0) +
ifelse(GS$F3[GS$StrategyNum == Results$StrategyChosen[res_row]] != 999, GS$F3[GS$StrategyNum == Results$StrategyChosen[res_row]], 0) +
ifelse(GS$F4[GS$StrategyNum == Results$StrategyChosen[res_row]] != 999, GS$F4[GS$StrategyNum == Results$StrategyChosen[res_row]], 0) +
ifelse(GS$F5[GS$StrategyNum == Results$StrategyChosen[res_row]] != 999, GS$F5[GS$StrategyNum == Results$StrategyChosen[res_row]], 0) +
ifelse(GS$F6[GS$StrategyNum == Results$StrategyChosen[res_row]] != 999, GS$F6[GS$StrategyNum == Results$StrategyChosen[res_row]], 0) +
ifelse(GS$F7[GS$StrategyNum == Results$StrategyChosen[res_row]] != 999, GS$F7[GS$StrategyNum == Results$StrategyChosen[res_row]], 0) +
ifelse(GS$F8[GS$StrategyNum == Results$StrategyChosen[res_row]] != 999, GS$F8[GS$StrategyNum == Results$StrategyChosen[res_row]], 0) +
ifelse(GS$F9[GS$StrategyNum == Results$StrategyChosen[res_row]] != 999, GS$F9[GS$StrategyNum == Results$StrategyChosen[res_row]], 0)
if(Results$TargetSum[res_row] <= max_score_to_win)
{
Results$Result[res_row] = "Win"
WinLoss$Outcome[GameNum] = "Win"
ThisResult = "Win"
for (ss in 1:res_row)
{
GS$Occurrences[GS$StrategyNum == Results$StrategyChosen[ss]] = GS$Occurrences[GS$StrategyNum == Results$StrategyChosen[ss]] + 1
GS$TimesWin[GS$StrategyNum == Results$StrategyChosen[ss]] = GS$TimesWin[GS$StrategyNum == Results$StrategyChosen[ss]] + 1
GS$WinRate = ifelse(GS$Occurrences == 0, NA, GS$TimesWin/GS$Occurrences)
}
} else
{
if(is.na(GS$P1[GS$StrategyNum == Results$StrategyChosen[res_row]]))
{
Results$Result[res_row] = "Lost"
WinLoss$Outcome[GameNum] = "Lost"
ThisResult = "Lost"
for (ss in 1:res_row)
{
GS$Occurrences[GS$StrategyNum == Results$StrategyChosen[ss]] = GS$Occurrences[GS$StrategyNum == Results$StrategyChosen[ss]] + 1
GS$WinRate = ifelse(GS$Occurrences == 0, NA, GS$TimesWin/GS$Occurrences)
}
}
}
if(ThisResult == "Undetermined")
{
Results$Result[res_row] = "Undetermined"
res_row = res_row + 1
Results$StateNum[res_row] = GS %>% ungroup() %>% filter(X1 == GS$F1[GS$StrategyNum == Results$StrategyChosen[res_row-1]],
X2 == GS$F2[GS$StrategyNum == Results$StrategyChosen[res_row-1]],
X3 == GS$F3[GS$StrategyNum == Results$StrategyChosen[res_row-1]],
X4 == GS$F4[GS$StrategyNum == Results$StrategyChosen[res_row-1]],
X5 == GS$F5[GS$StrategyNum == Results$StrategyChosen[res_row-1]],
X6 == GS$F6[GS$StrategyNum == Results$StrategyChosen[res_row-1]],
X7 == GS$F7[GS$StrategyNum == Results$StrategyChosen[res_row-1]],
X8 == GS$F8[GS$StrategyNum == Results$StrategyChosen[res_row-1]],
X9 == GS$F9[GS$StrategyNum == Results$StrategyChosen[res_row-1]]) %>% select(StateNum) %>% unique()
Results$TossNum[res_row] = Results$TossNum[res_row-1] + 1
}
}
}
completed = completed + 1
print(paste("Completed ", completed, " of ", length(RarelyUsedStrategies$StrategyNum), " strategies", sep = ""))
}
return(GS)
}
##
GameSpace = run_specific_strategies(GameSpace, 50)Having done this, we next order the strategies within each Rival Group by WinRate, and cull any rival strategies whose WinRate is statistically below that of the strategy with the highest WinRate at the 5% level. Here’s the relevant code:
cull_strategies_all_groups = function(GS)
{
ToCull = rep(0,5000)
row_num = 0
for(RivalGroupChosen in unique(GS$RivalGroup))
{
RivalData = GS %>% ungroup() %>% filter(RivalGroup == RivalGroupChosen) %>% select(StrategyNum, Occurrences, TimesWin, WinRate) %>% arrange(desc(WinRate))
if(length(RivalData$StrategyNum) == 1)
{
row_num = row_num + 1
ToCull[row_num] = 0
} else
{
for (ind in 2:length(RivalData$StrategyNum))
{
# If best strategy has a 100% record, keep only it
if(RivalData$WinRate[1] == 1)
{
row_num = row_num + 1
ToCull[row_num] = RivalData$StrategyNum[ind]
} else
{
# Cull nay strategy with a WinRate that is stat sig less than the best WinRate at the 5% level
if(prop.test(c(RivalData$TimesWin[1],RivalData$TimesWin[ind]), c(RivalData$Occurrences[1], RivalData$Occurrences[ind]), alternative = "greater", correct = TRUE)$p.value < 0.05)
{
row_num = row_num + 1
ToCull[row_num] = RivalData$StrategyNum[ind]
}
}
}
}
}
return(ToCull)
}# Bulk remove srategies that are clearly dominated statisticallyRemove_Strategies_Bulk = cull_strategies_all_groups(GameSpace)GameSpace = GameSpace %>% filter(!StrategyNum %in% Remove_Strategies_Bulk)# Update the Strategy CountGameSpace = GameSpace %>% group_by(RivalGroup) %>% mutate(StrategyCount = length(RivalGroup))Ideally, we would end this step with GameSpace containing exactly 5,566 rows - one for each of the 11 possible totals for each of the 506 valid pre-roll states - but, in my case at least, we’re not there yet.
I therefore, firstly, reuse the previous function, this time to ensure that any remaining strategy has been used at least 500 times, then perform a cull, and then do the same thing again ensuring that any remaining strategy has been used at least 1,000 times and then perform a final cull.
GameSpace = run_specific_strategies(GameSpace, 500)
# Bulk remove srategies that are clearly dominated statistically
Remove_Strategies_Bulk = cull_strategies_all_groups(GameSpace)
GameSpace = GameSpace %>% filter(!StrategyNum %in% Remove_Strategies_Bulk)
# Update the Strategy Count
GameSpace = GameSpace %>% group_by(RivalGroup) %>% mutate(StrategyCount = length(RivalGroup))
##
GameSpace = run_specific_strategies(GameSpace, 1000)
# Bulk remove srategies that are clearly dominated statistically
Remove_Strategies_Bulk = cull_strategies_all_groups(GameSpace)
GameSpace = GameSpace %>% filter(!StrategyNum %in% Remove_Strategies_Bulk)
# Update the Strategy Count
GameSpace = GameSpace %>% group_by(RivalGroup) %>% mutate(StrategyCount = length(RivalGroup))
###
write.csv(GameSpace,'GameSpace_Near_Optimised.csv', row.names = FALSE)We still have 5,770 rows in GameSpace at the end of this, 5,369 related to strategies with no rivals, 380 to strategies with one rival, and 21 related to strategies with two rivals.
The differences in the WinRates across Strategies with a given RivalGroup are generally small - say 1 or 2% - so it seems reasonable to settle for the Strategy within each RivalGroup that has the highest WinRate as the chosen strategy (bearing in mind that all remaining rivals have been deployed by now at least 1,000 times).
The final code to choose the remaining optimal strategies is:
OptimalStrategy = GameSpace %>% group_by(RivalGroup) %>% slice_max(WinRate, n=1, with_ties = FALSE) %>%
select(RivalGroup, StateNum, Open, TotalRolled, StrategyNum, Removed, Occurrences, TimesWin, WinRate)
write.csv(OptimalStrategy,'GameSpace_Optimised.csv', row.names = FALSE)
####################In the next part we’ll estimate the win rate that, using those strategies in normal play, will produce.