Add formula interfaces to elo functions

NAMESPACE

@@ -2,12 +2,20 @@
 
 S3method(as.data.frame,elo.run)
 S3method(as.matrix,elo.run)
+S3method(elo.calc,default)
+S3method(elo.calc,formula)
+S3method(elo.prob,default)
+S3method(elo.prob,formula)
+S3method(elo.update,default)
+S3method(elo.update,formula)
 S3method(last,elo.run)
 S3method(print,elo.run)
 export(elo.calc)
+export(elo.model.frame)
 export(elo.prob)
 export(elo.run)
 export(elo.update)
+export(is.score)
 export(last)
 export(score)
 importFrom(Rcpp,sourceCpp)

NEWS.md

@@ -1,3 +1,14 @@
+# elo ...
+
+* Implemented `elo.model.frame()`.
+
+* Changed the signatures of `elo.calc()` and `elo.update()` to match formula interface.
+
+* Changed `elo.calc()`, `elo.update()`, and `elo.prob()` to S3 generics, and implemented
+  formula methods. The default methods now include options to adjust Elos. (#3)
+
+* Added `is.score()` to test for "score-ness".
+
 # elo 0.1.2
 
 * Fixed a spelling error in DESCRIPTION.
@@ -8,7 +19,7 @@
 
 * Elaborated the description of the package.
 
-* Tweak the internal `elo.run` object.
+* Tweak the internal `"elo.run"` object.
 
 * Tweaked the README and vignette.
 

R/elo.R

@@ -4,9 +4,17 @@
 #'
 #' @section Functions:
 #'
-#' Below are listed some of the functions available in \code{elo}:
+#' Listed below are the most useful functions available in \code{elo}:
 #'
-#' \code{\link{elo.calc}}: Calculate Elos for a series of matches.
+#' \code{\link{elo.prob}}: Calculate the probability that team A beats team B.
+#'
+#' \code{\link{elo.update}}: Calculate the update value for a given Elo matchup.
+#'
+#' \code{\link{elo.calc}}: Calculate post-update Elo values.
+#'
+#' \code{\link{elo.run}}: Calculate Elos for a series of matches.
+#'
+#' \code{\link{score}}: Create a 1/0/0.5 win "indicator" based on two teams' scores.
 #'
 #' @section Data:
 #'

R/elo.calc.R

@@ -0,0 +1,50 @@
+
+#' Elo functions
+#'
+#' Calculate post-update Elo values. This is vectorized.
+#'
+#' @param formula A formula. See the "details" section of \code{\link{elo.model.frame}}.
+#' @inheritParams elo.model.frame
+#' @param elo.A,elo.B Numeric vectors of elo scores.
+#' @param wins.A Numeric vector of wins by team A.
+#' @param ... Other arguments (not in use at this time).
+#' @param adjust.A,adjust.B Numeric vectors to adjust \code{elo.A} and \code{elo.B} by.
+#' @seealso \code{\link{elo.prob}}, \code{\link{elo.update}}
+#' @examples
+#' elo.calc(c(1, 0), c(1500, 1500), c(1500, 1600), k = 20)
+#'
+#' dat <- data.frame(wins.A = c(1, 0), elo.A = c(1500, 1500),
+#'                   elo.B = c(1500, 1600), k = c(20, 20))
+#' elo.calc(wins.A ~ elo.A + elo.B + k(k), data = dat)
+#' @name elo.calc
+NULL
+#> NULL
+
+#' @rdname elo.calc
+#' @export
+elo.calc <- function(wins.A, ...)
+{
+  UseMethod("elo.calc")
+}
+
+#' @rdname elo.calc
+#' @export
+elo.calc.default <- function(wins.A, elo.A, elo.B, k, ..., adjust.A = 0, adjust.B = 0)
+{
+  validate_score(wins.A)
+  elo.up <- elo.update(wins.A = wins.A, elo.A = elo.A, elo.B = elo.B, k = k, ...,
+                       adjust.A = adjust.A, adjust.B = adjust.B)
+  data.frame(elo.A = elo.A + elo.up, elo.B = elo.B - elo.up)
+}
+
+#' @rdname elo.calc
+#' @export
+elo.calc.formula <- function(formula, data, na.action, subset, k = NULL, ...)
+{
+  Call <- match.call()
+  Call[[1L]] <- quote(elo.model.frame)
+  Call$required.vars <- c("wins", "teams", "k")
+  mf <- eval(Call, parent.frame())
+  elo.calc(mf[[1]], mf[[2]], mf[[3]], k = mf[[4]], ...,
+           adjust.A = mf$`(adj1)`, adjust.B = mf$`(adj2)`)
+}

R/elo.model.frame.R

@@ -0,0 +1,134 @@
+
+#' Interpret formulas in \code{elo} functions
+#'
+#' A helper function to create the \code{model.frame} for many \code{elo} functions.
+#'
+#' @param formula A formula. See "details", below.
+#' @param data A \code{data.frame} in which to look for objects in \code{formula}.
+#' @param na.action A function which indicates what should happen when the data contain NAs.
+#' @param subset An optional vector specifying a subset of observations.
+#' @param k A constant k-value (or a vector, where appropriate).
+#' @param ... Other arguments (not in use at this time).
+#' @param required.vars One or more of \code{c("wins", "teams", "k")}, denoting which variables
+#'   are required to appear in the final model.frame..
+#' @details
+#' With the exception of the formula in \code{\link{elo.run}},
+#'   \code{formula} is usually of the form \code{wins.A ~ elo.A + elo.B}, where \code{elo.A} and \code{elo.B}
+#'   are vectors of Elos, and \code{wins.A} is between 0 and 1,
+#'   denoting whether team A (Elo A) won or lost (or something between).
+#'
+#' \code{formula} accepts two special functions in it. \code{k()} allows for complicated Elo updates. For
+#'   constant Elo updates, use the \code{k = } argument instead of this special function.
+#'   \code{adjust()} allows for Elos to be adjusted for, e.g., home-field advantage. The second argument
+#'   to this function can be a scalar or vector of appropriate length.
+#'
+#' @seealso \code{\link{elo.run}}, \code{\link{elo.calc}}, \code{\link{elo.prob}}
+#' @export
+elo.model.frame <- function(formula, data, na.action, subset, k = NULL, ..., required.vars = "teams")
+{
+  Call <- match.call()
+  required.vars <- match.arg(required.vars, c("wins", "teams", "k"), several.ok = TRUE)
+  indx <- match(c("formula", "data", "subset", "na.action"), names(Call), nomatch = 0)
+  if(indx[1] == 0) stop("A formula argument is required.")
+
+  temp.call <- Call[c(1, indx)]
+  temp.call[[1L]] <- quote(stats::model.frame)
+  specials <- c("adjust", "k")
+
+  temp.call$formula <- if(missing(data))
+  {
+    stats::terms(formula, specials)
+  } else stats::terms(formula, specials, data = data)
+
+  adjenv <- new.env(parent = environment(formula))
+  if(!is.null(attr(temp.call$formula, "specials")$adjust))
+  {
+    assign("adjust", function(x, y) {
+      if(length(y) == 1)
+      {
+        attr(x, "adjust") <- rep(y, times = length(x))
+      } else if(length(y) == length(x))
+      {
+        attr(x, "adjust") <- y
+      } else stop("The second argument to 'adjust' needs to be length 1 or the same length as the first argument.")
+
+      class(x) <- c("adjustedElo", class(x))
+      x
+    }, envir = adjenv)
+  }
+  if(!is.null(attr(temp.call$formula, "specials")$k))
+  {
+    assign("k", function(x) x, envir = adjenv)
+  }
+  environment(temp.call$formula) <- adjenv
+
+  mf <- eval(temp.call, parent.frame())
+    if(nrow(mf) == 0) stop("No (non-missing) observations")
+
+  Terms <- stats::terms(mf)
+
+  #####################################################################
+
+  has.wins <- attr(Terms, "response") == 1
+  if("wins" %in% required.vars && !has.wins)
+  {
+    stop("A 'wins' component is required in 'formula'.")
+  } else if("wins" %in% required.vars)
+  {
+    mf[[1]] <- as.numeric(mf[[1]])
+    validate_score(mf[[1]])
+  }
+
+  #####################################################################
+
+  k.col <- attr(Terms, "specials")$k
+  has.k <- !is.null(k.col) || !is.null(k)
+
+  if(!has.k && "k" %in% required.vars) stop("'k' is not in 'formula' or specified as an argument.")
+
+  if(is.null(k.col) && !is.null(k))
+  {
+    if(ncol(mf) != 2 + has.wins) stop("'formula' doesn't appear to be specified correctly.")
+    mf$`(k)` <- k
+    k.col <- 3 + has.wins
+  } else if(!is.null(k.col))
+  {
+    if(!is.null(k)) warning("'k = ' argument being ignored.")
+    if(ncol(mf) != 3 + has.wins) stop("'formula' doesn't appear to be specified correctly.")
+    if(!identical(k.col, as.integer(3 + has.wins))) stop("'k()' should be the last term in 'formula'.")
+  } else
+  {
+    if(ncol(mf) != 2 + has.wins) stop("'formula' doesn't appear to be specified correctly.")
+  }
+
+  if("k" %in% required.vars && (!is.numeric(mf[[k.col]]) || anyNA(mf[[k.col]])))
+    stop("'k' should be numeric and non-NA.")
+
+  #####################################################################
+
+  adjs <- attr(Terms, "specials")$adjust
+  mf$`(adj1)` <- if(is.null(adjs) || !any(adjs == 1 + has.wins)) 0 else attr(mf[[1 + has.wins]], "adjust")
+  mf$`(adj2)` <- if(is.null(adjs) || !any(adjs == 2 + has.wins)) 0 else attr(mf[[2 + has.wins]], "adjust")
+
+  if(!is.numeric(mf$`(adj1)`) || !is.numeric(mf$`(adj2)`)) stop("Any Elo adjustments should be numeric!")
+
+  #####################################################################
+
+  mf[[1 + has.wins]] <- remove_adjustedElo(mf[[1 + has.wins]])
+  mf[[2 + has.wins]] <- remove_adjustedElo(mf[[2 + has.wins]])
+
+  #####################################################################
+
+  attr(mf, "has.wins") <- has.wins
+  attr(mf, "has.k") <- has.k
+
+  if(4 + has.wins + has.k != ncol(mf)) stop("Something went wrong parsing the formula into a model.frame.")
+
+  return(mf)
+}
+
+has.wins <- function(x)
+{
+  attr(x, "has.wins")
+}
+

R/elo.prob.R

@@ -0,0 +1,48 @@
+#' Elo functions
+#'
+#' Calculate the probability that team A beats team B. This is vectorized.
+#'
+#' @inheritParams elo.calc
+#' @details
+#'   Note that \code{formula} can be missing the \code{wins.A} component. If
+#'   present, it's ignored by \code{\link{elo.model.frame}}.
+#' @seealso \code{\link{elo.update}}, \code{\link{elo.calc}}
+#' @examples
+#' elo.prob(1500, 1500)
+#' elo.prob(c(1500, 1500), c(1500, 1600))
+#'
+#' dat <- data.frame(wins.A = c(1, 0), elo.A = c(1500, 1500),
+#'                   elo.B = c(1500, 1600), k = c(20, 20))
+#' elo.prob(~ elo.A + elo.B, data = dat)
+#'
+#' ## Also works to include the wins and k:
+#' elo.calc(wins.A ~ elo.A + elo.B + k(k), data = dat)
+#' @name elo.prob
+NULL
+#> NULL
+
+#' @rdname elo.prob
+#' @export
+elo.prob <- function(elo.A, ...)
+{
+  UseMethod("elo.prob")
+}
+
+#' @rdname elo.prob
+#' @export
+elo.prob.default <- function(elo.A, elo.B, ..., adjust.A = 0, adjust.B = 0)
+{
+  1/(1 + 10^(((elo.B + adjust.B) - (elo.A + adjust.A))/400.0))
+}
+
+#' @rdname elo.prob
+#' @export
+elo.prob.formula <- function(formula, data, na.action, subset, ...)
+{
+  Call <- match.call()
+  Call[[1L]] <- quote(elo.model.frame)
+  Call$required.vars <- "teams"
+  mf <- eval(Call, parent.frame())
+  elo.prob(mf[[1 + has.wins(mf)]], mf[[2 + has.wins(mf)]], ...,
+           adjust.A = mf$`(adj1)`, adjust.B = mf$`(adj2)`)
+}