R/6_optimise.R

In ffsimulator: Simulate Fantasy Football Seasons

#' Optimise Lineups
#'
#' Calculates optimal lineups for all franchises in the dataframe based on a table of lineup constraints.
#'
#' Lineup efficiency is the percentage of optimal/best-ball score that is used as the actual score - by default, the lineup efficiency for a team in non-best-ball settings is normally distributed around a mean of 77.5% and a standard deviation of 5%.
#'
#' @param roster_scores a dataframe as generated by `ffs_score_rosters()` - should contain columns like: projected_score, pos, and player_id
#' @param lineup_constraints a dataframe as generated by `ffscrapr::ff_starter_positions()` - should contain columns pos, min, max, and offense_starters
#' @param lineup_efficiency_mean the average lineup efficiency to use, defaults to 0.775
#' @param lineup_efficiency_sd the standard deviation of lineup efficiency, defaults to 0.05
#' @param best_ball a logical: FALSE will apply a lineup efficiency factor and TRUE uses optimal scores as actual scores, default = FALSE
# @param parallel a logical: TRUE will run the optimization in parallel, requires the furrr and future packages as well as setting `future::plan()` in advance/externally. Default FALSE.
#' @param pos_filter a character vector specifying which positions are eligible - defaults to `c("QB","RB","WR","TE)`
# @param verbose a logical: TRUE (default) will print stuff.
#'
#' @return a dataframe of what each team scored for each week
#'
#' @examples \donttest{
#' # cached examples
#' roster_scores <- .ffs_cache("roster_scores.rds")
#' lineup_constraints <- .ffs_cache("mfl_lineup_constraints.rds")
#'
#' ffs_optimise_lineups(roster_scores, lineup_constraints)
#' }
#'
#' @seealso `vignette("custom")` for example usage
#'
#' @export

ffs_optimise_lineups <- function(roster_scores,
                                 lineup_constraints,
                                 lineup_efficiency_mean = 0.775,
                                 lineup_efficiency_sd = 0.05,
                                 best_ball = FALSE,
                                 pos_filter = c("QB", "RB", "WR", "TE") # ,
                                 # verbose = TRUE
) {
  checkmate::assert_number(lineup_efficiency_mean, lower = 0, upper = 1)
  checkmate::assert_number(lineup_efficiency_sd, lower = 0, upper = 0.25)
  checkmate::assert_flag(best_ball)

  checkmate::assert_data_frame(roster_scores)
  assert_columns(
    roster_scores,
    c(
      "pos", "pos_rank", "league_id", "franchise_id",
      "franchise_name", "season", "week", "projected_score"
    )
  )
  roster_scores <- data.table::as.data.table(roster_scores)

  checkmate::assert_data_frame(lineup_constraints, any.missing = FALSE)
  assert_columns(lineup_constraints, c("pos", "min", "max", "offense_starters"))

  lineup_constraints <- data.table::as.data.table(lineup_constraints)
  lineup_constraints <- lineup_constraints[lineup_constraints$pos %in% pos_filter]

  max_lineup_constraints <- lineup_constraints[, c("pos", "max")]

  data.table::setkeyv(max_lineup_constraints, "pos")
  data.table::setkeyv(roster_scores, "pos")

  optimal_scores <- merge(roster_scores, max_lineup_constraints, by = "pos")

  data.table::setkeyv(optimal_scores, c("league_id", "franchise_id", "franchise_name", "season", "week"))

  optimal_scores <- optimal_scores[
    optimal_scores$pos_rank <= optimal_scores$max & optimal_scores$pos %in% lineup_constraints$pos,
    c("league_id", "franchise_id", "franchise_name", "season", "week", "player_id", "pos", "projected_score")
  ]

  optimal_scores <-
    optimal_scores[,
      .ff_optimise_one_lineup(.SD, lineup_constraints),
      by = c("league_id", "franchise_id", "franchise_name", "season", "week"),
      .SDcols = c("player_id", "pos", "projected_score")
    ]

  if (best_ball) optimal_scores[, `:=`(lineup_efficiency = 1)]

  if (!best_ball) {
    optimal_scores[, `:=`(lineup_efficiency = stats::rnorm(.N, mean = lineup_efficiency_mean, sd = lineup_efficiency_sd))]
  }

  optimal_scores[, `:=`(actual_score = optimal_scores$optimal_score * optimal_scores$lineup_efficiency)]

  return(optimal_scores)
}

#' @rdname ffs_optimise_lineups
#' @export
ffs_optimize_lineups <- ffs_optimise_lineups

#' Optimise single lineup
#'
#' Optimises lineups for one franchise week at a time. Use purrr or loops to do more franchises/weeks/seasons
#'
#' @param franchise_scores a data frame of scores for one week and one franchise
#' @param lineup_constraints a data frame as created by `ffscrapr::ff_starter_positions()`
#'
#' @return a list including the optimal_score and the optimal_lineup.
#'
#' @keywords internal
.ff_optimise_one_lineup <- function(franchise_scores, lineup_constraints) {
  min_req <- sum(lineup_constraints$min)

  player_ids <- c(franchise_scores$player_id, rep_len(NA_character_, min_req))
  player_scores <- c(franchise_scores$projected_score, rep_len(0, min_req))
  player_scores[is.na(player_scores)] <- 0

  # binary - position identifiers

  pos_ids <- NULL

  for (i in lineup_constraints$pos) pos_ids <- c(pos_ids, as.integer(franchise_scores$pos == i), rep.int(1L, min_req))

  constraints_matrix <- matrix(
    c(
      pos_ids, # pos minimums
      pos_ids, # pos maximums
      as.integer(franchise_scores$pos %in% c("QB", "RB", "WR", "TE")), rep.int(1L, min_req), # total offensive starters
      rep.int(1L,length(player_scores))
      ),
    nrow = nrow(lineup_constraints) * 2 + 2,
    byrow = TRUE
  )

  constraints_dir <- c(
    rep_len(">=", nrow(lineup_constraints)),
    rep_len("<=", nrow(lineup_constraints)),
    "<=",
    "<="
  )

  constraints_rhs <- c(
    lineup_constraints$min,
    lineup_constraints$max,
    lineup_constraints$offense_starters[[1]],
    lineup_constraints$total_starters[[1]]
  )

  solve_lineup <- Rglpk::Rglpk_solve_LP(
    obj = player_scores,
    mat = constraints_matrix,
    dir = constraints_dir,
    rhs = constraints_rhs,
    types = rep("B", length(player_scores)),
    max = TRUE
  )

  optimals <- list(
    optimal_score = sum(player_scores * solve_lineup$solution),
    optimal_player_id = list(player_ids[as.logical(solve_lineup$solution)]),
    optimal_player_score = list(player_scores[as.logical(solve_lineup$solution)])
  )


  return(optimals)
}