kikrpikr

(noun) A machine learning prediction engine to help owners maximize kicker point output for an NFL fantasy football team.

Provided for use by the Bay Area Dynasty League team owners solely for entertainment purposes.

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 950
#| column: screen-inset-shaded

set.seed(888)
library(shiny)
library(bslib)
library(DT)
library(readr)
library(dplyr)
 library(workflows)
library(parsnip)
library(recipes)   # if preprocessing steps were used
 library(glmnet)
if (FALSE) {
  library(munsell)
}
#library(tidymodels)

Cov_ma_small = c("pos_imptot","def_imptot",
               "week","season",
               "max_dist_mv","kicker_home","fg_pct_mv","xp_pct_mv",
               "fourth_down_try_rate_ma",
               "szn_def_kkr_mean_pts","szn_kkr_mean_pts",
               "roof_closed","roof_dome","roof_open",
               "wind_weather","precipitation_unknown","precipitation_yes")

ui <- fluidPage(
  uiOutput("pred_week"),
  DTOutput("editable_table"),
  actionButton("update_preds", "Update Predictions"),
  actionButton("reset_button", "Reset"),
  uiOutput("data_timestamp")
  # verbatimTextOutput("verb")
)


server <- function(input, output, session) {

# Example dropdown choices
dropdown_choices <- list(
  precipitation = c("no", "yes", "unknown"),
  roof          = c("open", "closed", "dome","outdoors")
)

colorder <- c("X",".pred","kicker_name","posteam","pos_imptot","defteam","def_imptot","roof",
             "wind_weather","precipitation","kicker_home_fmt","szn_kkr_mean_pts", "fg_pct_mv","xp_pct_mv","max_dist_mv","sum_fg_att","sum_xp_att", "fourth_down_try_rate_ma","szn_def_kkr_mean_pts",
             "week","season","kicker_home")

    pred_data_url <- "https://raw.githubusercontent.com/numbersinfigures/blog_Rcode_excerpted/refs/heads/main/tinkering_scraps/test_pred_data.csv"
    utils::download.file(pred_data_url, "test_pred_data.csv")
initial_data <- read.csv("test_pred_data.csv")
file_ctime <- max(initial_data$weather_nw_dltime)
weekpred <- max(initial_data$week,na.rm=T)

print(paste("Data as of:", file_ctime))

#   output$data_timestamp <- renderText({
#     paste(paste("Data as of:", file_mtime),"// Based on BADL Kicker Scoring Rubric",
#           "(FG 0-29 = 3pts; FG 30-39 = 4pts; 40+ = 6pts)", sep = "\n")
# })

output$data_timestamp <- renderUI({
  HTML(paste("",paste("Data as of:", file_ctime),"Note: For kickers with less than 6 games this season, some model values are substituted with values from last season or leaguewide.","","Kicker Scoring Based on BADL Kicker Settings:", 
          "(FG 0-39 = 3pts; FG 40-49 = 4pts; FG 50+ = 6pts;","FG Missed 0-39 = -1pt, FG Missed 40+ = 0pt; 
          XP = 1pt; XP Missed = 0pts)", sep = "<br/>"))
})

output$pred_week <- renderUI({
  h2(paste("Week",weekpred,"Fantasy Point Predictions",sep=" "))
})

other_kickers_url <- "https://raw.githubusercontent.com/numbersinfigures/blog_Rcode_excerpted/refs/heads/main/tinkering_scraps/other_kicker_stats.csv"
utils::download.file(other_kickers_url, "other_kicker_stats.csv")
kicker_set <- read.csv("other_kicker_stats.csv")

workflow_url <- "https://raw.githubusercontent.com/numbersinfigures/blog_Rcode_excerpted/refs/heads/main/tinkering_scraps/test_ridge_workflow.rds"
utils::download.file(workflow_url, "test_ridge_workflow.rds")
loaded_workflow <- readRDS("test_ridge_workflow.rds")

recalculate_score <- function(df) {
    pred_df <- data.frame(predict(loaded_workflow, df))
    df$.pred <- pred_df$.pred
    df <- df[order(-df$.pred), ]
    df
}

vars_to_logical_df <- function(mydf) {
  mydf$precipitation_yesTRUE     <- mydf$precipitation == "yes"
  mydf$precipitation_unknownTRUE <- mydf$precipitation == "unknown"
  
  mydf$roof_closedTRUE <- mydf$roof == "closed"
  mydf$roof_openTRUE   <- mydf$roof == "open"
  mydf$roof_domeTRUE   <- mydf$roof == "dome"
  
  return(mydf)
}  

initial_data$precipitation_yesTRUE[initial_data$roof %in% c("closed", "dome")] <- FALSE
initial_data$precipitation[initial_data$roof %in% c("closed", "dome")] <- "no"
initial_data$season <- 2025
# colnames(initial_data) <- c("Initial Rank","Pred Pts", "K Name", "Game ID", "Kick Tm", "Def Tm", "K Tm Pred Score",  "D Tm Pred Score",  
#                             "Max Dist Att", "K Home Tm", "Seas FG %", "Seas XP %", "4th Down Conv Att %", 
#                             "D Seas Avg to K", "K Seas Avg", "roof_closedTRUE", "roof_domeTRUE","roof_openTRUE", "Pred Wind", "precip_unk" ,
#                             "precip_yes", 
#                             "Pred Precipitation", 
#                             "Roof","week","season")
initial_data <- initial_data[order(-initial_data$.pred), ]
initial_data$kicker_home_fmt <- ifelse(initial_data$kicker_home == 1, "Home", "Away")
initial_data <- initial_data[, colorder]

base_values <- initial_data
base_colnames <- names(initial_data)

values <- reactiveValues(data = initial_data) 
output$editable_table <- renderDT({

  columns2hide <- which(names(values$data) %in% c(
    "precipitation_yesTRUE","precipitation_unknownTRUE",
    "roof_closedTRUE","roof_domeTRUE","roof_openTRUE",
    "week","season","game_id","kicker_home","weather_nw_dltime"
  )) - 1

  editable_cols <- c(
    which(names(initial_data) == "kicker_name"),
    which(names(initial_data) == "precipitation"),
    which(names(initial_data) == "roof"),
    which(names(initial_data) == "wind_weather"),
    which(names(initial_data) == "pos_imptot"),
    which(names(initial_data) == "def_imptot")
  )
  all_cols <- seq_along(initial_data)
  disable_cols <- setdiff(all_cols, editable_cols) - 1
  disable_cols <- disable_cols[disable_cols >= 0]

  # build gradient breaks and colors for fg_pct_mv and xp_pct_mv
  rng_fg  <- range(values$data$fg_pct_mv, na.rm = TRUE)
  brks_fg <- seq(rng_fg[1],rng_fg[2], length.out = 20)
  clrs_fg <- round(seq(255, 40, length.out = length(brks_fg) + 1), 0) %>%
    {paste0("rgb(255,", ., ",", ., ")")}

  rng_xp <- range(values$data$xp_pct_mv, na.rm = TRUE)
  brks_xp <- seq(rng_fg[1],rng_fg[2], length.out = 20)
  clrs_xp <- round(seq(255, 40, length.out = length(brks_xp) + 1), 0) %>%
    {paste0("rgb(255,", ., ",", ., ")")}

  rng_kmean  <- range(values$data$szn_kkr_mean_pts, na.rm = TRUE)
  brks_kmean <- seq(rng_kmean[1],rng_kmean[2], length.out = 20)
  clrs_kmean <- round(seq(255, 40, length.out = length(brks_kmean) + 1), 0) %>%
    {paste0("rgb(255,", ., ",", ., ")")}

  rng_maxdist <- range(values$data$max_dist_mv, na.rm = TRUE)
  brks_maxdist <- seq(rng_maxdist[1],rng_maxdist[2], length.out = 20)
  clrs_maxdist <- round(seq(255, 40, length.out = length(brks_maxdist) + 1), 0) %>%
    {paste0("rgb(255,", ., ",", ., ")")}
  
  rng_def <- range(values$data$szn_def_kkr_mean_pts, na.rm = TRUE)
  brks_def <- seq(rng_def[1],rng_def[2], length.out = 20)
  clrs_def <- round(seq(255, 40, length.out = length(brks_def) + 1), 0) %>%
    {paste0("rgb(", ., ",255,", ., ")")}
  
  rng_4d <- range(values$data$fourth_down_try_rate_ma, na.rm = TRUE)
  brks_4d <- seq(rng_4d[1],rng_4d[2], length.out = 20)
  clrs_4d <- round(seq(255, 40, length.out = length(brks_4d) + 1), 0) %>%
    {paste0("rgb(255,", ., ",255)")}
  
  req(ncol(values$data) > 0)
  datatable(
    values$data,
    colnames = c("Initial Pred Rank","Pred Pts", "K Name", "K Tm", "K Tm Vegas Pred Score", "Def Tm",
                 "D Tm Vegas Pred Score", "Roof", "Pred Wind", "Pred Precipitation", "K Home Tm",
                 "K Seas Avg Pts", "Seas FG %", "Seas XP %", "Max Dist Att", "FG Att", "XP Att",
                 "Tm 4th Down Conv Att %","D Seas Avg Pts to K"),
    editable = list(
      target = "cell",
      disable = list(columns = disable_cols)
    ),
    options = list(
      pageLength = 16,
      dom = "lftrip",
      columnDefs = list(list(visible = FALSE, targets = columns2hide),
                        list(className = 'dt-center', targets = "_all")) # center all columns
    ),
    rownames = FALSE
  ) %>%
    formatRound(columns = c(".pred", "szn_kkr_mean_pts", "szn_def_kkr_mean_pts"), digits = 2) %>%
    formatPercentage(columns = c("fourth_down_try_rate_ma","fg_pct_mv","xp_pct_mv"), digits = 1) %>%
    formatStyle(
      ".pred",
      background = styleColorBar(c(max(values$data[, ".pred"]),0), "lightblue"),
      backgroundSize = "98% 88%",
      backgroundRepeat = "no-repeat",
      backgroundPosition = "center"
    ) %>%
    formatStyle(
      "fg_pct_mv",
      backgroundColor = styleInterval(brks_fg, clrs_fg)
    ) %>%
    formatStyle(
      "xp_pct_mv",
      backgroundColor = styleInterval(brks_xp, clrs_xp)
    ) %>%
    formatStyle(
      "szn_kkr_mean_pts",
      backgroundColor = styleInterval(brks_kmean, clrs_kmean)
    ) %>%
    formatStyle(
      "max_dist_mv",
      backgroundColor = styleInterval(brks_maxdist, clrs_maxdist)
    ) %>%
    formatStyle(
      "szn_def_kkr_mean_pts",
      backgroundColor = styleInterval(brks_def, clrs_def)
    ) %>%
    formatStyle(
      "fourth_down_try_rate_ma",
      backgroundColor = styleInterval(brks_4d, clrs_4d)
    ) %>%
    formatStyle(
      columns = c("kicker_name", "precipitation", "roof",
                  "wind_weather", "pos_imptot", "def_imptot"),
      backgroundColor = "#f9f9d1",
      fontWeight = "bold"
    ) %>% 
#no clue why this works for shiny but not shinylive
    formatStyle("kicker_home_fmt",
      backgroundColor = DT::styleEqual(levels=c("Away", "Home"),values= c('gray40', 'white'))
)
}, server = TRUE)

observeEvent(input$reset_button, {
  isolate({
    values$data <- base_values   # revert to original
    proxy <- dataTableProxy("editable_table")
    replaceData(proxy, values$data, resetPaging = FALSE, rownames = FALSE)
  })
})

observeEvent(input$editable_table_cell_edit, {
   isolate({
    info <- input$editable_table_cell_edit
    row <- info$row
    col <- info$col + 1
    if (row < 1 || col < 1 || row > nrow(values$data) || col > ncol(values$data)) return()

    col_name  <- colnames(values$data)[col]
    new_value <- info$value
    print(new_value)

    if (col_name %in% names(dropdown_choices)) {
      if (new_value %in% dropdown_choices[[col_name]]) {
        values$data[row, col] <- new_value
      } else {
        showNotification(paste("Invalid value for", col_name, ":", new_value), type = "error")
      }
    } else {
      values$data[row, col] <- DT::coerceValue(new_value, values$data[row, col])
    }

    replaceData(dataTableProxy("editable_table"), values$data, resetPaging = FALSE, rownames = FALSE)
  })
}
)

observeEvent(input$update_preds, {
    isolate({
      for (r in seq_len(nrow(values$data))) {
        new_kicker <- values$data[r, "kicker_name"]
        stats <- kicker_set[kicker_set$kicker_name == new_kicker, ]
        if (nrow(stats) == 0) stats <- kicker_set[kicker_set$kicker_name == "Other", ]
        if (nrow(stats) == 1) {
          values$data[r, "fg_pct_mv"] <- stats$fg_pct_4nw
          values$data[r, "xp_pct_mv"] <- stats$xp_pct_4nw
          values$data[r, "max_dist_mv"] <- stats$max_dist_4nw
          values$data[r, "szn_kkr_mean_pts"] <- stats$szn_kkr_mean_pts
          # only update attempts if season is 2025
          if (stats$season == 2025) {
            values$data[r, "sum_fg_att"] <- stats$fg_att_4nw
            values$data[r, "sum_xp_att"] <- stats$xp_att_4nw
          }
        }
      }
      values$data <- vars_to_logical_df(values$data)
      values$data <- recalculate_score(values$data)
      values$data$newrank = 1:nrow(values$data)

      proxy <- dataTableProxy("editable_table")
      replaceData(proxy, values$data, resetPaging = FALSE, rownames = TRUE)
    })
  })

}
  
shinyApp(ui, server)

Editable Variables:

Kicker Name (format: FirstInitial.LastName, no spaces) [in case of late injury replacement/missing from midweek predictions]

Kicker Team Estimated Score

Defensive Team Estimated Score

Precipitation (“yes”/“no”/“unknown”)

Wind (in mph)

Roof (“closed”/“open”/“outdoors”/“dome”)