Blame for plumber.R

#QUEENS PICTH DESIGN APP API

library(plumber)
library(mgcv)
library(data.table)
library(jsonlite)

cat("Loading model artifacts...\n")
fit          <- readRDS("fit_l6_champ.rds")
vaa_mod      <- readRDS("vaa_anchor_model.rds")
haa_mod      <- readRDS("haa_anchor_model.rds")
scaling      <- readRDS("shape_scaling_factors.rds")
mu_l6        <- scaling$mu_l6
sig_l6       <- scaling$sig_l6
train_means  <- fread("train_means.csv")

model_levels <- c("FF","CU","ST","SI","FC","SL","CH","FS","KC","SV","KN","EP","FA","FO","CS","SC")

cat(sprintf("Model ready. %d pitch types loaded.\n", length(model_levels)))

cat("Loading pitcher profiles...\n")
pitcher_profiles <- tryCatch({
  dt <- fread("pitcher_profiles.csv")
  cat(sprintf("Pitcher profiles loaded: %d rows, %d pitchers.\n",
              nrow(dt), dt[, uniqueN(player_name)]))
  dt
}, error = function(e) {
  warning(sprintf("Failed to load pitcher_profiles.csv: %s", conditionMessage(e)))
  NULL
})

build_features <- function(d) {
  d <- as.data.table(d)

  d[, p_throws := fifelse(p_throws %in% c("Left","LHP"), "L",
                  fifelse(p_throws %in% c("Right","RHP"), "R", p_throws))]

  d[, pfx_x_sym   := fifelse(p_throws == "L", pfx_x * -1,   pfx_x)]
  d[, plate_x_sym := fifelse(p_throws == "L", plate_x * -1, plate_x)]
  d[, rel_x_sym   := fifelse(p_throws == "L", release_pos_x * -1, release_pos_x)]

  if (!"release_extension" %in% names(d)) d[, release_extension := 6.0]
  d[is.na(release_extension), release_extension := 6.0]

  d[, flight_time   := (1.4167 - 50) / vy0]
  d[, vaa           := atan((vz0 + az * flight_time) / -(vy0 + ay * flight_time)) * (180 / pi)]
  d[, haa           := atan((vx0 + ax * flight_time) / -(vy0 + ay * flight_time)) * (180 / pi)]
  d[, haa_sym       := fifelse(p_throws == "L", haa * -1, haa)]

  d[, vaa_resid     := vaa     - predict(vaa_mod, newdata = d)]
  d[, haa_resid_sym := haa_sym - predict(haa_mod, newdata = d)]

  d <- merge(d, train_means, by = "pitch_type", all.x = FALSE)
  d[, ivb_diff    := pfx_z     - base_ivb]
  d[, hb_diff_sym := pfx_x_sym - base_hb]

  d[, pitch_type := factor(as.character(pitch_type), levels = model_levels)]
  d[, p_throws   := factor(as.character(p_throws), levels = c("L", "R"))]

  d[!is.na(pitch_type)]
}

score_pitches <- function(d) {
  d <- build_features(d)
  if (nrow(d) == 0) return(list(error = "No valid pitches after feature engineering"))

  raw       <- predict(fit, newdata = d)
  shape_plus <- (((raw * -1) - mu_l6) / sig_l6) * 10 + 100

  term_mat  <- predict(fit, newdata = d, type = "terms")
  col_names <- colnames(term_mat)

  list(
    n          = nrow(d),
    shape_plus = round(as.numeric(shape_plus), 1),
    terms      = lapply(seq_len(nrow(d)), function(i) {
      row <- as.list(round(term_mat[i, ], 3))
      names(row) <- col_names
      row
    })
  )
}


#* @apiTitle Queens Shape+ API
#* @apiDescription Scores pitch shapes using the Shape+ v2.0 GAM model

#* @filter cors
function(req, res) {
  res$setHeader("Access-Control-Allow-Origin",  "*")
  res$setHeader("Access-Control-Allow-Methods", "GET, POST, OPTIONS")
  res$setHeader("Access-Control-Allow-Headers", "Content-Type")
  if (req$REQUEST_METHOD == "OPTIONS") {
    res$status <- 200
    return(list())
  }
  plumber::forward()
}

#* @post /score
#* @serializer json
function(req) {
  tryCatch({
    body <- fromJSON(req$postBody, simplifyDataFrame = TRUE)
    score_pitches(as.data.table(body))
  }, error = function(e) {
    list(error = conditionMessage(e))
  })
}

#* Find comparable pitchers by movement profile
#* Expects JSON body: pitch_type, ivb, hb_sym, velo, arm_angle, p_throws
#* Returns top 5 closest pitchers with their full arsenals
#* @post /find_comps
#* @serializer unboxedJSON
function(req) {
  tryCatch({

    # ── Guard: profiles must have loaded at startup ──────────────────────────
    if (is.null(pitcher_profiles)) {
      return(list(error = "pitcher_profiles.csv failed to load at startup"))
    }

    # ── Parse request body ───────────────────────────────────────────────────
    body <- fromJSON(req$postBody, simplifyVector = TRUE)

    input_pitch_type <- as.character(body$pitch_type)
    input_p_throws   <- as.character(body$p_throws)
    input_ivb        <- as.numeric(body$ivb)
    input_hb         <- as.numeric(body$hb_sym)
    input_velo       <- as.numeric(body$velo)
    input_arm        <- as.numeric(body$arm_angle)

    # ── Filter to matching anchor pitch type (any handedness — hb_sym is already symmetrized)
    anchor_rows <- pitcher_profiles[pitch_type == input_pitch_type]

    if (nrow(anchor_rows) == 0) {
      return(list(error = "no matches"))
    }

    # ── Compute weighted distance for each matching row ──────────────────────
    # Arm angle tightly weighted (/8) so a submarine pitcher never matches an over-the-top guy.
    # If input arm_angle is NA/null, skip that term to avoid NaN distances.
    arm_term <- if (!is.na(input_arm)) ((anchor_rows$arm_angle - input_arm) / 8)^2 else 0
    anchor_rows[, dist := sqrt(
      ((ivb       - input_ivb)  / 3)^2 +
      ((hb_sym    - input_hb)   / 3)^2 +
      ((velo      - input_velo) / 5)^2 +
      arm_term
    )]

    # ── Top 5 closest pitchers ───────────────────────────────────────────────
    top5 <- head(anchor_rows[order(dist)], 5)

    # ── For each top pitcher, pull their full arsenal ────────────────────────
    result <- lapply(seq_len(nrow(top5)), function(i) {
      row         <- top5[i]
      pitcher_nm  <- row$player_name
      anchor_dist <- round(row$dist, 3)

      arsenal_rows <- pitcher_profiles[player_name == pitcher_nm]

      arsenal <- lapply(seq_len(nrow(arsenal_rows)), function(j) {
        r <- arsenal_rows[j]
        list(
          pitch_type = r$pitch_type,
          velo       = r$velo,
          ivb        = r$ivb,
          hb_sym     = r$hb_sym,
          rel_z      = r$rel_z,
          arm_angle  = r$arm_angle,
          n          = r$n
        )
      })

      list(
        player_name = pitcher_nm,
        p_throws    = row$p_throws,
        anchor_dist = anchor_dist,
        arsenal     = arsenal
      )
    })

    result

  }, error = function(e) {
    list(error = conditionMessage(e))
  })
}

#* Health check
#* @get /health
function() {
  list(status = "ok", model = "fit_l6_champ", time = as.character(Sys.time()))
}