Fantasy Football League Stats

divisions.csv

func.R

probWins <- function(probs, wins=length(probs)) {
    if (length(probs) == 0)
        return(1)
    p <- 0
    if (wins > 0)
        p <- probs[1] * probWins(probs[-1], wins - 1)
    if (wins < length(probs))
        p <- p + (1 - probs[1]) * probWins(probs[-1], wins)
    names(p) <- NULL
    p
}

winsDistribution <- function(points) {
    w <- nrow(points)
    probs <- expectedWins(points)
    dist <- 1
    for (i in 1:w) {
        x <- probs[,i]
        dist <- cbind((1-x) * dist, 0) + cbind(0, x * dist)
    }
    rownames(dist) <- colnames(points)
    colnames(dist) <- as.character(0:w)
    dist
}

expectedWins <- function(points) {
    round((apply(points, 1, rank) - 1) / (ncol(points) - 1), 4)
}

gamesData <- function(points, schedule, divisions=NULL) {
    l <- ncol(points)
    w <- nrow(points)
    week <- rep(1:w, l)
    team <- factor(rep(colnames(points), each=w))
    pts <- c(points)
    rank <- c(t(apply(-points, 1, rank)))
    opp <- c(schedule[1:w,])
    map <- (opp - 1) * w + week
    opp.team <- team[map]
    opp.pts <- pts[map]
    opp.rank <- rank[map]
    diff.pts <- pts - opp.pts
    ratio <- round(pts / opp.pts, 2)
    #diff.rank <- opp.rank - rank
    worl <- factor(c("Win","Loss","Tie")[2 - (diff.pts > 0) + (diff.pts == 0)])
    if (!is.null(divisions)) {
        div <- rep(divisions, each=w)
        divg <- div == div[map]
        data.frame(week,team,pts,rank,opp.team,opp.pts,opp.rank,diff.pts,ratio,worl,divg)
    } else {
        data.frame(week,team,pts,rank,opp.team,opp.pts,opp.rank,diff.pts,ratio,worl)
    }
}

streak <- function(x) {
    x <- x[!is.na(x)]
    x <- rle(as.character(x))
    n <- length(x$lengths)
    paste(substr(x$values[n], 1, 1), x$lengths[n], sep="-")
}

order.streak <- function(x) {
    i <- (1:length(x))*2
    x <- unlist(strsplit(as.character(x), ' '))
    n <- as.numeric(x[i])
    l <- x[i-1]
    t <- c(W = -1, L = 1)
    order(t[l] * n)
}

standings <- function(x, divisions=NULL, bye.points=FALSE) {
    l <- length(levels(x$team))
    if (!bye.points)
        x <- x[!is.na(x$opp.team),]
    n <- nrow(x)
    if (!is.null(divisions)) {
        colnames <- c("W","L","T","DW","DL","DT","streak","pts","opp.pts","e.wins","luck")#,"a.rank","a.opp.rank")
    } else {
        colnames <- c("W","L","T","streak","pts","opp.pts","e.wins","luck")#,"a.rank","a.opp.rank")
    }
    process <- function(t) {
        W <- sum(t$worl == "Win" , na.rm=TRUE)
        L <- sum(t$worl == "Loss", na.rm=TRUE)
        T <- sum(t$worl == "Tie" , na.rm=TRUE)
        if (!is.null(divisions)) {
            DW <- sum(t$worl == "Win"  & t$divg, na.rm=TRUE)
            DL <- sum(t$worl == "Loss" & t$divg, na.rm=TRUE)
            DT <- sum(t$worl == "Tie"  & t$divg, na.rm=TRUE)
        } else {
            DW <- DL <- DT <- NULL
        }
        strk <- streak(t$worl)
        pts <- sum(t$pts)
        opp.pts <- sum(t$opp.pts, na.rm=TRUE)
        e.wins <- (n - sum(t$rank)) / (l - 1)
        luck <- W+T/2 - e.wins + (nrow(t)-W-L-T)/2
        #a.rank <- mean(t$rank)
        #a.opp.rank <- mean(t$opp.rank, na.rm=TRUE)
        structure(as.data.frame(c(c(W,L,T, DW,DL,DT), list(strk), round(c(pts,opp.pts,e.wins,luck), 3))), names=colnames) # ,a.rank,a.opp.rank
    }
    result <- do.call(rbind, lapply(split(x, x$team), process))
    rownames(result) <- levels(x$team)
    if (!is.null(divisions)) {
        dw <- do.call(rbind, structure(by(result, divisions[rownames(result)], function(x) { order.standings(x, division=TRUE)[1,] }), dimnames=NULL))
        other <- result[!(rownames(result) %in% rownames(dw)),]
        x <- rbind(order.standings(dw), order.standings(other))
    } else {
        x <- order.standings(result)
    }
    format.standings(x)
}

order.standings <- function(x, division=FALSE) {
    if (division) {
        as.data.frame(order2(x, c("W","L","DW","DL","pts"), decreasing=c(TRUE,FALSE,TRUE,FALSE,TRUE)))
    } else {
        as.data.frame(order2(x, c("W","L","pts"), decreasing=c(TRUE,FALSE,TRUE)))
    }
}

format.standings <- function(x) {
    x[,c("W","L","T")] <- list(do.call(paste, c(x[,c("W","L","T")], sep="-")), NULL, NULL)
    colnames(x)[colnames(x) == "W"] <- "W-L-T"
    if (all(c("DW","DL","DT") %in% colnames(x))) {
        x[,c("DW","DL","DT")] <- list(do.call(paste, c(x[,c("DW","DL","DT")], sep="-")), NULL, NULL)
        colnames(x)[colnames(x) == "DW"] <- "Div"
    }
    x
}

unprojected <- function(x, p) {
    wins <- x$worl == "Win"
    loss <- x$worl == "Loss"
    ties <- x$worl == "Tie"
    wins <- summary(x[wins,][p[wins,]$worl != "Win",]$team)
    loss <- summary(x[loss,][p[loss,]$worl != "Loss",]$team)
    ties <- summary(x[ties,][p[ties,]$worl != "Tie",]$team)
    perf <- table(x$team, x$opp.pts < p$opp.pts)
    colnames(perf) <- c("opp.up", "opp.dn")
    cbind(luck2=wins-loss, W.U=wins, L.U=loss, T.U=ties, perf)
}

order2 <- function(x, indices, na.last=TRUE, decreasing=FALSE) {
    len <- length(indices)
    len2 <- length(na.last)
    len3 <- length(decreasing)
    if (len < len3)
        decreasing <- decreasing[1:len]
    if (len > len3)
        decreasing[(len3 + 1) : len] <- FALSE
    if (len < len2)
        na.last <- na.last[1:len]
    if (len > len2)
        na.last[(len2 + 1) : len] <- TRUE
    for (i in len:1) {
        x <- x[order(x[,indices[i]], na.last=na.last[i], decreasing=decreasing[i]),]
    }
    x
}

plotExpectedWins <- function(points) {
    l <- ncol(points)
    w <- nrow(points)
    plot(c(0,w), c(0,w), type="n", xlab="Week", ylab="E[Number of Wins]", main="Expected Number of Wins", ylim=c(0,w), xlim=c(0,w), las=1)
    colors <- 1:6
    style <- rep(1:6, each=length(colors))
    matlines(0:w, rbind(0, apply(expectedWins(points), 1, cumsum)), type='b', col=colors, lty=style, lwd=1, pch='°')
    legend("topleft", colnames(points), col=colors, lty=style)
}

plotWinsDistribution <- function(points) {
    dist <- winsDistribution(points)
    l <- ncol(points)
    w <- nrow(points)
    mx <- max(dist)
    par(mfrow=c(1,1))
    nr <- ceiling(sqrt(l))
    par(mfrow=c(nr, ceiling(l / nr)))
    for (i in 1:l) {
        barplot(dist[i,], xlim=c(0,w+2), ylim=c(0,mx), main=colnames(points)[i], xlab="E[Wins] Distribution", space=0, xpd=FALSE)
    }
    par(mfrow=c(1,1))
    invisible(dist)
}

schedulePermutations <- function(points, schedule, reps=1000) {
    teams <- colnames(points)
    l <- length(teams)
    wins <- matrix(0, reps, l)
    colnames(wins) <- teams
    for (i in 1:reps) {
        wins[i,] <- with(standings(gamesData(points[,sample(l)], schedule))[teams,], W + T / 2)
    }
    wins
}

plotWinsDistribution2 <- function(wins) {
    l <- ncol(wins)
    mx <- max(wins)
    par(mfrow=c(1,1))
    nr <- ceiling(sqrt(l))
    par(mfrow=c(nr, ceiling(l / nr)))
    for (i in 1:l) {
        hist(wins[,i], xlim=c(0,mx+2), ylim=c(0,1), main=colnames(wins)[i], xlab="Random Win Distribution")
    }
    par(mfrow=c(1,1))
}

rrt <- function(x, team) {
    w <- max(x$week) - min(x$week) + 1
    l <- nrow(x) / w
    teams <- as.character(x$team[seq(1, l * w, w)])
    subset <- x[x$team == team,]
    setsub <- x[x$team != team,]
    plot(range(subset$pts), range(gd$pts), type='n', xlab="My Scores", ylab="Their Scores", main=team)
    abline(0, 1, lty=2, col=8)
    points(rep(subset$pts, l-1), setsub$pts, pch=1, cex=0.8)
    points(subset$pts, subset$pts, pch=19, cex=0.8, col=heat.colors(l)[subset$rank])
    points(subset$pts, subset$opp.pts, pch=1, cex=0.8, col=heat.colors(l)[subset$opp.rank])
}

rrt2 <- function(x, team) {
    w1 <- min(x$week)
    wN <- max(x$week)
    w <- wN - w1 + 1
    l <- nrow(x) / w
    teams <- as.character(x$team[seq(1, l * w, w)])
    subset <- x[x$team == team,]
    setsub <- x[x$team != team,]
    diffs <- setsub$pts - rep(subset$pts, l-1)
    #opp <- apply(outer(subset$opp.team, teams, "=="), 1, which)
    plot(c(w1,wN), range(diffs), type='n', xlab="Weeks", ylab="Diffs", main=team)
    abline(h=0,lty=2, col=8)
    points(rep(w1:wN, l-1), diffs, pch=1, cex=0.8)
    points(w1:wN, rep(0, w), pch=18, cex=0.8, col=heat.colors(l)[subset$rank])
    points(w1:wN, -subset$diff.pts, pch=1, cex=0.8, col=heat.colors(l)[subset$opp.rank])
}

points.csv

report.snw

\documentclass[]{article}

\usepackage{setspace,relsize,comment,Sweave}

\setlength{\oddsidemargin}{0.35cm}
\setlength{\evensidemargin}{0.35cm}
\setlength{\textwidth}{16.2cm}
\setlength{\topmargin}{-1cm}
\setlength{\headsep}{0cm}
\setlength{\textheight}{23.4cm}

\SweaveOpts{prefix.string=graphics/}

\title{Biostat -- Fantasy Football 2010}
\author{Tatsuki Koyama and Will Gray}

\begin{document}

\maketitle

<<echo=f>>=
library(VICCBiostat)
source('func.r')

how.many.to.display <- 20 # for miscellaneous informtion.

## Data ##
sco <- as.matrix(read.csv('points.csv'))
sch <- as.matrix(read.csv('schedule.csv'))
div <- as.matrix(read.csv('divisions.csv'))[1,]
ord <- order(colnames(sco))

gd <- gamesData(sco, sch, div)
st <- standings(gd, div)

gd <- gd[,!(colnames(gd) %in% 'divg')]
sco <- sco[,ord]
sch <- sch[,ord]
@

\section*{Week 1 to Week 13}
\subsection*{Standings}
<<echo=f>>=
st
@

\newpage
\subsection*{By Points}
<<echo=f>>=
order2(st, c('pts'), decreasing=c(TRUE))
@

\subsection*{By Expected Wins}
<<echo=f>>=
order2(st, c('e.wins','pts'), decreasing=c(TRUE,TRUE))
@

\newpage
\subsection*{By Luck}
<<echo=f>>=
order2(st, c('luck','pts'), decreasing=c(TRUE,TRUE))
@

\subsection*{By Imaginary Defense}
<<echo=f>>=
order2(st, c('opp.pts','pts'), decreasing=c(FALSE,TRUE))
@

<<echo=f>>=
h <- how.many.to.display
wins <- gd[gd$worl == 'Win',]
loss <- gd[gd$worl == 'Loss',]
@

\newpage
\section*{Miscellaneous Information}
\subsection*{The highest points}
<<echo=f>>=
data.frame(gd[with(gd, order(pts, decreasing=TRUE)),][1:h, ], row.names=1:h)
@

\subsection*{The lowest points}
<<echo=f>>=
data.frame(gd[with(gd, order(pts, decreasing=FALSE)),][1:h, ], row.names=1:h)
@

\newpage
\subsection*{The lowest points to win a game}
<<echo=f>>=
data.frame(wins[with(wins, order(pts, decreasing=FALSE)),][1:h, ], row.names=1:h)
@

\subsection*{The highest points to lose a game}
<<echo=f>>=
data.frame(loss[with(loss, order(pts, decreasing=TRUE)),][1:h, ], row.names=1:h)
@

\newpage
\subsection*{The lowest rank to win a game}
<<echo=f>>=
data.frame(wins[with(wins, order(rank, decreasing=TRUE)),][1:h, ], row.names=1:h)
@

\subsection*{The highest rank to lose a game}
<<echo=f>>=
data.frame(loss[with(loss, order(rank, decreasing=FALSE)),][1:h, ], row.names=1:h)
@

\newpage
\subsection*{The most lopsided games by points}
<<echo=f>>=
data.frame(wins[with(wins, order(diff.pts, decreasing=TRUE)),][1:h, ], row.names=1:h)
@

\subsection*{The closest games by points}
<<echo=f>>=
data.frame(wins[with(wins, order(diff.pts, decreasing=FALSE)),][1:h, ], row.names=1:h)
@

\newpage
\subsection*{The most lopsided games by ratio}
<<echo=f>>=
data.frame(wins[with(wins, order(-ratio, decreasing=FALSE)),][1:h, ], row.names=1:h)
@

\subsection*{The closest games by ratio}
<<echo=f>>=
data.frame(wins[with(wins, order(-ratio, decreasing=TRUE)),][1:h, ], row.names=1:h)
@

\begin{center}
<<echo=f, fig=t, height=12, width=8>>=
plotExpectedWins(sco)
@

\subsection*{}
<<echo=f, fig=t, height=12, width=10>>=
plotWinsDistribution(sco)
@

\subsection*{}
<<echo=f, fig=t, height=12, width=8>>=
tplot(gd$pts ~ gd$team, type="db", jit=.2, dist=1.2, col=c(Loss=2,Tie=4,Win=1)[as.character(gd$worl)], las=2, pch=20, cex=.8, panel.first=quote({
    abline(h=median(gd$pts, na.rm=TRUE), lty=3, col=gray(.75))
    abline(h=quantile(gd$pts, .25, na.rm=TRUE), lty=3, col=gray(.75))
    abline(h=quantile(gd$pts, .75, na.rm=TRUE), lty=3, col=gray(.75))
}), main="Points Scored")
@

\subsection*{}
<<echo=f, fig=t, height=12, width=8>>=
tplot(gd$opp.pts ~ gd$team, type="db", jit=.2, dist=1.2, col=c(Loss=2,Tie=4,Win=1)[as.character(gd$worl)], las=2, pch=20, cex=.8, panel.first=quote({
    abline(h=median(gd$opp.pts, na.rm=TRUE), lty=3, col=gray(.75))
    abline(h=quantile(gd$opp.pts, .25, na.rm=TRUE), lty=3, col=gray(.75))
    abline(h=quantile(gd$opp.pts, .75, na.rm=TRUE), lty=3, col=gray(.75))
}), main="Points Against")
@

\subsection*{}
<<echo=f, results=tex>>=
for (team in colnames(sco)) {
    postscript(paste("graphics/-",team,".eps",sep=""), width=8, height=8, paper="special", horizontal=FALSE)
    rrt2(gd, team)
    dev.off()
    pdf(paste("graphics/-",team,".pdf",sep=""), width=8, height=8, version="1.1", encoding="default")
    rrt2(gd, team)
    dev.off()
    cat("\\includegraphics{graphics/-",team,"}\n", sep="")
}
@
\end{center}

<<echo=f, fig=f>>=
save(sco, sch, div, gd, st, wins, loss, file=paste('data.Rdata', sep=''))
@
\end{document}

schedule.csv