#' 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 \link[=formula.specials]{the help page for formulas} for details.
#' @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", "elos", "k", "group", "regress")},
#' denoting which variables are required to appear in the final model.frame.
#' @param warn.k Should a warning be issued if \code{k} is specified as an argument and in \code{formula}?
#' @param ncol.k How many columns (\code{NCOL}) should \code{k} have?
#' @param ncol.elos How many Elo columns are expected?
#' @seealso \code{\link{elo.run}}, \code{\link{elo.calc}}, \code{\link{elo.update}}, \code{\link{elo.prob}}
#' @export
elo.model.frame <- function(formula, data, na.action, subset, k = NULL, ..., required.vars = "elos", warn.k = TRUE, ncol.k = 1, ncol.elos = 2)
{
Call <- match.call()
required.vars <- match.arg(required.vars, c("wins", "elos", "k", "group", "regress", "neutral", "weights"), several.ok = TRUE)
indx <- match(c("formula", "data", "subset", "na.action", "weights"), 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", "group", "regress", "neutral", "players")
temp.call$formula <- if(missing(data))
{
stats::terms(formula, specials)
} else stats::terms(formula, specials, data = data)
mf <- eval(temp.call, parent.frame())
if(nrow(mf) == 0) stop("No (non-missing) observations")
Terms <- stats::terms(mf)
naaction <- stats::na.action(mf)
#####################################################################
has.wins <- attr(Terms, "response") == 1
k.col <- attr(Terms, "specials")$k
has.k <- !null_or_length0(k.col) || !is.null(k)
grp.col <- attr(Terms, "specials")$group
reg.col <- attr(Terms, "specials")$regress
neu.col <- attr(Terms, "specials")$neutral
wts.col <- which(names(mf) == "(weights)")
if("wins" %in% required.vars && !has.wins)
{
stop("A 'wins' component is required in the left-hand side of 'formula'.")
}
if("k" %in% required.vars && !has.k)
{
stop("'k' is not in 'formula' or specified as an argument.")
} else if(!null_or_length0(k.col) && !is.null(k) && warn.k)
{
warning("'k = ' argument being ignored.")
}
# need all the parens b/c ! is a low-precident operator
sum.nonempty <- (!null_or_length0(k.col)) + (!null_or_length0(grp.col)) + (!null_or_length0(reg.col)) +
(!null_or_length0(neu.col)) + (!null_or_length0(wts.col))
if(has.wins + sum.nonempty + ncol.elos != ncol(mf))
{
stop("'formula' not specified correctly: found ", ncol(mf), " columns; expected ",
has.wins + sum.nonempty + ncol.elos)
}
# figure out which columns are the "real" ones
elo.cols <- if(sum.nonempty == 0)
{
(1:ncol.elos) + has.wins
} else setdiff(1:ncol(mf), c(if(has.wins) 1, k.col, grp.col, reg.col, neu.col, wts.col))
stopifnot(ncol.elos %in% 1:2)
if(length(elo.cols) != ncol.elos) stop("Trouble finding the Elo columns.")
#####################################################################
out <- data.frame(row.names = 1:nrow(mf)) # in case one of the next two lines is a matrix
out$elo.A <- remove_elo_adjust(mf[[elo.cols[1]]])
if(ncol.elos == 2) out$elo.B <- remove_elo_adjust(mf[[elo.cols[2]]])
if("wins" %in% required.vars)
{
out$wins.A <- as.numeric(mf[[1]])
if(!(is.mov <- inherits(mf[[1]], "elo.mov"))) validate_score(out$wins.A)
} else is.mov <- FALSE
if("k" %in% required.vars)
{
k <- if(null_or_length0(k.col))
{
if(!(length(k) %in% c(1, nrow(mf)))) stop("'k' must be length 1 or the number of rows of data")
if(length(k) == 1) k <- rep(k, nrow(mf))
k
} else mf[[k.col]]
stopifnot(ncol.k %in% 1:2)
if(ncol.k == 2 && NCOL(k) == 1) k <- matrix(c(k, k), ncol = 2)
out$k <- k
if(!is.numeric(out$k) || anyNA(out$k)) stop("'k' should be numeric and non-NA.")
}
if("group" %in% required.vars)
{
out$group <- if(null_or_length0(grp.col)) TRUE else mf[[grp.col]]
}
if("regress" %in% required.vars)
{
out$regress <- if(null_or_length0(reg.col))
{
regress(rep(FALSE, times = nrow(out)), 1500, 0, FALSE)
} else mf[[reg.col]]
}
if("neutral" %in% required.vars)
{
out$home.field <- if(null_or_length0(neu.col)) rep(1, times = nrow(out)) else 1 - mf[[neu.col]]
}
if("weights" %in% required.vars)
{
out$weights <- if(null_or_length0(wts.col))
{
rep(1, times = nrow(out))
} else mf[["(weights)"]]
}
adjs <- attr(Terms, "specials")$adjust
out$adj.A <- if(null_or_length0(adjs) || !any(adjs == elo.cols[1])) 0 else attr(fix_adjust(mf[[elo.cols[1]]], naaction), "adjust")
if(ncol.elos == 2) out$adj.B <- if(null_or_length0(adjs) || !any(adjs == elo.cols[2])) 0 else attr(fix_adjust(mf[[elo.cols[2]]], naaction), "adjust")
if(!is.numeric(out$adj.A) || (!is.null(out$adj.B) && !is.numeric(out$adj.B))) stop("Any Elo adjustments should be numeric!")
attr(out, "terms") <- Terms
attr(out, "na.action") <- naaction
attr(out, "outcome") <- if(is.mov) "mov" else "score"
out
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.