Skip to content

Stats speed up (take 2) #3094

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
blackshadowshade wants to merge 1 commit into
base: master
Choose a base branch
from
+100 −134
Open

Stats speed up (take 2) #3094

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
234 changes: 100 additions & 134 deletions tools/stats/R/calcStats.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,22 +7,9 @@ box::use(
data.table,
Matrix,
jsonlite,
dplyr,
condformat
htmltools
)

# These were imported as libraries in the initial code, but don't
# appear to me to be needed:
# * colorRamps

# The %>% operator is imported from dplyr, and needs to be invoked
# under that exact name with no namespace, for reasons described
# in the first comment by "greg" in
# https://forum.posit.co/t/magrittr-inside-a-package/2033
# (That thread is about magrittr, but dplyr implements the same
# operator, and clearly has the same issue.)
`%>%` <- dplyr$`%>%`

save_dir <- function() {
# Choose target file save directory
if (('unix' == .Platform$OS.type) && ('X11' == .Platform$GUI)) {
Expand All @@ -33,7 +20,7 @@ save_dir <- function() {
dir_path <- './'
}

return(dir_path);
return(dir_path)
}

connectToDatabase <- function() {
Expand All @@ -48,7 +35,7 @@ connectToDatabase <- function() {
unix.sock = "/Applications/MAMP/tmp/mysql/mysql.sock"
)
} else {
# Otherwise connect via TCP/IP
# Otherwise connect via Unix socket
db <- RMySQL$dbConnect(
RMySQL$MySQL(),
user = 'root',
Expand Down Expand Up @@ -102,7 +89,7 @@ queryPlayerNames <- function(db) {
}

queryButtonStats <- function(db) {
# Submit query for button vs button data, ignoring mirror matches
# Submit query for button vs button data; mirror matches are flagged but not filtered here
suppressWarnings(
data.df <- DBI$dbGetQuery(
db,
Expand Down Expand Up @@ -194,16 +181,12 @@ calcButtonMatchupsPlayed <- function(data.df, button.names.df) {
ngame <- nrow(data.df) / 2
max.button <- max(button.names.df$alt_button_id)

# Create data frame with button involved in each game
games.played.df <- data.frame(
first_button_id = data.df$alt_button_id[2*(1:ngame) - 1],
second_button_id = data.df$alt_button_id[2*(1:ngame)]
)

# Create matchup frequency matrix of games played
dt <- data.table$data.table(games.played.df, key = c('first_button_id', 'second_button_id'))
freq.dt <- dt[, .N, by = eval(data.table$key(dt))]
freq.matrix <- as.matrix(with(freq.dt, Matrix$sparseMatrix(i = first_button_id, j = second_button_id, x = N, dims = c(max.button, max.button))))
freq.matrix <- buildFrequencyMatrix(
data.df$alt_button_id[2*(1:ngame) - 1],
data.df$alt_button_id[2*(1:ngame)],
max.button
)

freq.matrix.df <- as.data.frame(freq.matrix, row.names = button.names.df$button_name)
colnames(freq.matrix.df) <- button.names.df$button_name
Expand All @@ -219,10 +202,7 @@ calcButtonMatchupsPlayed <- function(data.df, button.names.df) {
freq.matrix[0 == freq.matrix] <- NA

# Take log of frequency matrix and increase dynamic range
log.freq.matrix <- log2(freq.matrix)
log.freq.matrix.limited <- log.freq.matrix
upper.limit <- 5
log.freq.matrix.limited[log.freq.matrix.limited > upper.limit] <- upper.limit
log.freq.matrix.limited <- pmin(log2(freq.matrix), 5)

# Create colour palette
color.palette <- colorRampPalette(c('grey', 'red'))
Expand Down Expand Up @@ -256,37 +236,75 @@ calcButtonMatchupsPlayed <- function(data.df, button.names.df) {
dev.off()
}

calcButtonMatchupWinStats <- function(data.df, button.names.df, is.colour = FALSE) {
# Create matchup matrix with win/loss info
game.winner.df <- data.frame(
winner_button_id = data.df$alt_button_id[data.df$did_win],
winner_button_name = data.df$button_name[data.df$did_win],
loser_button_id = data.df$alt_button_id[!data.df$did_win],
loser_button_name = data.df$button_name[!data.df$did_win]
buildFrequencyMatrix <- function(row_ids, col_ids, n) {
dt <- data.table$data.table(row_id = row_ids, col_id = col_ids,
key = c('row_id', 'col_id'))
freq.dt <- dt[, .N, by = eval(data.table$key(dt))]
as.matrix(Matrix$sparseMatrix(
i = freq.dt$row_id,
j = freq.dt$col_id,
x = freq.dt$N,
dims = c(n, n)
))
}

buildColouredHtmlTable <- function(df, caption) {
# Compute cell background colours from 'Win %' and '# games played' columns
output.colour <- pmin(4, floor(df$'Win %' / 20))
# use a special colour for fewer than 5 matchups
output.colour[df$'# games played' < 5] <- 5

colour.map <- c('0' = '#ff8888', '1' = '#ffcccc', '2' = '#ffffcc',
'3' = '#ccffcc', '4' = '#88ff88', '5' = '#8888ff')
bg <- colour.map[as.character(output.colour)]

col.names <- names(df)
header <- paste0(
'<thead><tr>',
paste0('<th>', col.names, '</th>', collapse = ''),
'</tr></thead>'
)

rows <- paste0(
'<tr>',
'<td>', htmltools$htmlEscape(as.character(df[[1]])), '</td>',
'<td>', htmltools$htmlEscape(as.character(df[[2]])), '</td>',
'<td style="background-color:', bg, '">', df[[3]], '</td>',
'<td>', df[[4]], '</td>',
'</tr>'
)

paste0(
'<table border="1"><caption>', htmltools$htmlEscape(caption), '</caption>',
header,
'<tbody>', paste(rows, collapse = ''), '</tbody>',
'</table>'
)
}

calcButtonMatchupWinStats <- function(data.df, button.names.df) {
# Populate a button matchup frequency matrix
dt <- data.table$data.table(game.winner.df, key = c('winner_button_id', 'loser_button_id'))
freq.dt <- dt[, .N, by = eval(data.table$key(dt))]
max_button_id <- max(button.names.df$alt_button_id)
freq.matrix <- as.matrix(with(freq.dt, Matrix$sparseMatrix(i = winner_button_id, j = loser_button_id, x = N, dims = c(max_button_id, max_button_id))))
freq.matrix <- buildFrequencyMatrix(
data.df$alt_button_id[data.df$did_win],
data.df$alt_button_id[!data.df$did_win],
max(button.names.df$alt_button_id)
)

# Calculate the total number of games played for each matchup
n.games.matrix <- freq.matrix + t(freq.matrix)
n.games.matrix[row(n.games.matrix) == col(n.games.matrix)] <- n.games.matrix[row(n.games.matrix) == col(n.games.matrix)] / 2
diag(n.games.matrix) <- diag(n.games.matrix) / 2

# Create a data frame with unplayed matchups
n.games.df <- data.frame(
button1 = rep(button.names.df$button_name, each = nrow(button.names.df)),
button2 = button.names.df$button_name,
n.games = as.vector(n.games.matrix)
zero.idx <- which(n.games.matrix == 0, arr.ind = TRUE)
unplayed.df <- data.frame(
button1 = button.names.df$button_name[zero.idx[, 1]],
button2 = button.names.df$button_name[zero.idx[, 2]]
)
unplayed.df <- n.games.df[0 == n.games.df$n.games, 1:2]
write.csv(unplayed.df, file = 'unplayed_button_matchups.csv', row.names = FALSE)

# Calculate the win percentage for each matchup
win.percentage.matrix <- round(100 * freq.matrix / n.games.matrix, 2)
win.percentage.matrix[row(win.percentage.matrix) == col(win.percentage.matrix)] <- NA
diag(win.percentage.matrix) <- NA

# Flatten the matrix out into a data frame with one matchup per row
win.percentage.df <- data.frame(
Expand All @@ -297,77 +315,47 @@ calcButtonMatchupWinStats <- function(data.df, button.names.df, is.colour = FALS
)

# Save data as CSV and JSON object
win.percentage.df.short <- win.percentage.df
colnames(win.percentage.df.short) <- c('b1', 'b2', 'wp', 'ng')

write.table(
win.percentage.df.short,
file = 'win_percentage_stats.csv',
col.names = c('button_1', 'button_2', 'win_percentage', 'number_of_games'),
setNames(win.percentage.df, c('b1', 'b2', 'wp', 'ng')),
file = 'win_percentage_stats.csv',
col.names = c('button_1', 'button_2', 'win_percentage', 'number_of_games'),
row.names = FALSE,
sep = ','
)

df.json <- jsonlite$toJSON(win.percentage.df.short, pretty = TRUE, digits = 2)
writeLines(df.json, paste0(save_dir(), 'win_percentage_stats.json'))

writeLines(
jsonlite$toJSON(setNames(win.percentage.df, c('b1', 'b2', 'wp', 'ng')), pretty = TRUE, digits = 2),
paste0(save_dir(), 'win_percentage_stats.json')
)

# Remove empty rows
win.percentage.df <- win.percentage.df[!is.na(win.percentage.df$win.percentage),]
names(win.percentage.df) <- c('Button Name', 'Opponent Button Name', 'Win %', '# games played')


# Create HTML table of button matchup stats
if (is.colour) {
output.colour <- pmin(4, floor(win.percentage.df$'Win %'/20))
# use a special colour for fewer than 5 matchups
output.colour[win.percentage.df$'# games played' < 5] <- 5

out.table <- condformat$condformat(win.percentage.df) %>%
condformat$rule_fill_discrete(contains('Win %'),
expression = output.colour,
colours = c('0' = '#ff8888', '1' = '#ffcccc', '2' = '#ffffcc', '3' = '#ccffcc', '4' = '#88ff88', '5' = '#8888ff')) %>%
condformat$theme_caption(paste0('Button stats generated on ',
as.character(as.Date(max(data.df$last_action_time))),
', only contains played matchups'))
out.html <- condformat$condformat2html(out.table)
return(out.html)
} else {
stats.table <- xtable$xtable(
win.percentage.df,
display = c('s', 's', 's', 'f', 'd'),
caption = paste0(
'Button stats generated on ',
as.character(as.Date(max(data.df$last_action_time))),
', only contains played matchups'
)
)
}
caption <- paste0('Button stats generated on ',
as.character(as.Date(max(data.df$last_action_time))),
', only contains played matchups')

return(stats.table)
return(buildColouredHtmlTable(win.percentage.df, caption))
}

calcPlayerMatchupWinStats <- function(data.df, player.names.df, is.colour = FALSE) {
# Create matchup matrix with win/loss info
game.winner.df <- data.frame(
winner_player_id = data.df$player_id[data.df$did_win],
winner_player_name = data.df$player_name[data.df$did_win],
loser_player_id = data.df$player_id[!data.df$did_win],
loser_player_name = data.df$player_name[!data.df$did_win]
)

calcPlayerMatchupWinStats <- function(data.df, player.names.df) {
# Populate a player matchup frequency matrix
dt <- data.table$data.table(game.winner.df, key = c('winner_player_id', 'loser_player_id'))
freq.dt <- dt[, .N, by = eval(data.table$key(dt))]
max_player_id <- max(player.names.df$player_id)
freq.matrix <- as.matrix(with(freq.dt, Matrix$sparseMatrix(i = winner_player_id, j = loser_player_id, x = N, dims = c(max_player_id, max_player_id))))
freq.matrix <- buildFrequencyMatrix(
data.df$player_id[data.df$did_win],
data.df$player_id[!data.df$did_win],
max(player.names.df$player_id)
)

# Calculate the total number of games played for each matchup
n.games.matrix <- freq.matrix + t(freq.matrix)
n.games.matrix[row(n.games.matrix) == col(n.games.matrix)] <- n.games.matrix[row(n.games.matrix) == col(n.games.matrix)] / 2
diag(n.games.matrix) <- diag(n.games.matrix) / 2

# Calculate the win percentage for each matchup
win.percentage.matrix <- 100 * freq.matrix / n.games.matrix
win.percentage.matrix[row(win.percentage.matrix) == col(win.percentage.matrix)] <- NA
diag(win.percentage.matrix) <- NA

# Flatten the matrix out into a data frame with one matchup per row
win.percentage.df <- data.frame(
Expand All @@ -392,59 +380,37 @@ calcPlayerMatchupWinStats <- function(data.df, player.names.df, is.colour = FALS
win.percentage.sorted.df$win.percentage <- round(win.percentage.sorted.df$win.percentage, 2)
names(win.percentage.sorted.df) <- c('Player Name', 'Opponent Name', 'Win %', '# games played')

# Create HTML table of button matchup stats
if (is.colour) {
output.colour <- pmin(4, floor(win.percentage.sorted.df$'Win %'/20))
# use a special colour for fewer than 5 matchups
output.colour[win.percentage.sorted.df$'# games played' < 5] <- 5

out.table <- condformat$condformat(win.percentage.sorted.df) %>%
condformat$rule_fill_discrete(contains('Win %'),
expression = output.colour,
colours = c('0' = '#ff8888', '1' = '#ffcccc', '2' = '#ffffcc', '3' = '#ccffcc', '4' = '#88ff88', '5' = '#8888ff')) %>%
condformat$theme_caption(paste0('Player stats generated on ',
as.character(as.Date(max(data.df$last_action_time))),
', only contains played matchups'))
out.html <- condformat$condformat2html(out.table)
return(out.html)
} else {
stats.table <- xtable$xtable(
win.percentage.sorted.df,
display = c('s', 's', 's', 'f', 'd'),
caption = paste0(
'Player stats generated on ',
as.character(as.Date(max(data.df$last_action_time))),
', only contains played matchups'
)
)
# Create HTML table of player matchup stats
caption <- paste0('Player stats generated on ',
as.character(as.Date(max(data.df$last_action_time))),
', only contains played matchups')

return(stats.table)
}
return(buildColouredHtmlTable(win.percentage.sorted.df, caption))
}

generateHtmlFile <- function(html.table, fname) {
# Save HTML table to file
print(
html.table,
type = 'html',
include.rownames = FALSE,
file = paste0(save_dir(), fname)
)
path <- paste0(save_dir(), fname)
if (is.character(html.table)) {
writeLines(html.table, path)
} else {
print(html.table, type = 'html', include.rownames = FALSE, file = path)
}
}

runAll <- function() {
db <- connectToDatabase()
on.exit(RMySQL$dbDisconnect(db))
button.names.df <- queryButtonNames(db)
player.names.df <- queryPlayerNames(db)
data.df <- queryButtonStats(db)
RMySQL$dbDisconnect(db)

data.df$alt_button_id <- button.names.df$alt_button_id[match(data.df$button_id, button.names.df$button_id)]

generateHtmlFile(calcSingleButtonStats(data.df), 'button_stats.html')
calcButtonMatchupsPlayed(data.df, button.names.df)
generateHtmlFile(calcPlayerMatchupWinStats(data.df, player.names.df, TRUE), 'player_matchup_stats.html')
generateHtmlFile(calcButtonMatchupWinStats(data.df, button.names.df, FALSE), 'button_matchup_stats.html')
generateHtmlFile(calcPlayerMatchupWinStats(data.df, player.names.df), 'player_matchup_stats.html')
generateHtmlFile(calcButtonMatchupWinStats(data.df, button.names.df), 'button_matchup_stats.html')
}

runAll()