Nothing
# Things you can do with the big grand.data object and unique roster.
#Block the seasons into 4. This will make it easier to add new games as time goes along.
season.block <- function (season) {
year <- as.numeric(substr(season,1,4))
1 + 1*(year >= 2005) + 1*(year >= 2007) + 1*(year >= 2009) + 1*(year >= 2011) + 1*(year >= 2013)
}
compare.CDF <- function (original, target, range=1:200) {
#range=1:200
original <- sort(original); target <- sort(target)
oq <- quantile(original, seq(0,1,by=0.001), na.rm=TRUE)
tq <- quantile(target, seq(0,1,by=0.001), na.rm=TRUE)
values <- sapply(range, function(rr) mean(tq[oq==rr]))
if (is.na(values[1])) values[1] <- range[1]
picks <- 2:length(values)
for (kk in picks[is.na(values[-1])]) values[kk] <- values[kk-1] + 1
values[values > max(range)] <- max(range)
names(values) <- range
values
}
make.adjusted.distance.homeaway.table <- function (shots.in) { #,
#shots.in = shot.data
message ("Creating distance adjustment tables.")
shots.in$seasonblock <- season.block(shots.in$season)
seasonblocks <- 1:max(shots.in$seasonblock)
shots.split <- lapply(seasonblocks,
function (bb) shots.in[shots.in$seasonblock==bb,
c("type", "ev.team", "hometeam", "awayteam", "distance")])
split.table <- expand.grid (seasonblock=seasonblocks, type=unique(shots.in$type),
teams=unique(shots.in$hometeam), stringsAsFactors = FALSE)
quantile.adjust <- sapply (1:nrow(split.table), function(rr) {
prop <- split.table[rr,]
## message (prop)
original <- shots.split[[prop[[1]]]]$distance[shots.split[[prop[[1]]]]$type == prop[[2]] &
shots.split[[prop[[1]]]]$ev.team == prop[[3]] &
shots.split[[prop[[1]]]]$hometeam == prop[[3]]]
target <- shots.split[[prop[[1]]]]$distance[shots.split[[prop[[1]]]]$type == prop[[2]] &
shots.split[[prop[[1]]]]$ev.team == prop[[3]] &
shots.split[[prop[[1]]]]$awayteam == prop[[3]]]
compare.CDF (original, target)
})
return (list(split.table=split.table, quantile.adjust=quantile.adjust))
}
update.adjusted.distance <- function (shots.in,
split.object) {
#shots.in=shot.data; split.object=distance.adjust
shots.in$seasonblock <- season.block(shots.in$season)
seasonblocks <- 1:max(shots.in$seasonblock)
shots.in$adjusted.distance <- shots.in$distance
shots.split <- lapply(seasonblocks,
function (bb) shots.in[shots.in$seasonblock==bb,
c("type", "ev.team", "hometeam", "awayteam",
"distance", "adjusted.distance")])
for (rr in 1:nrow(split.object$split.table)) {
prop <- split.object$split.table[rr,]
## message(prop)
rows <- which (shots.split[[prop[[1]]]]$type == prop[[2]] &
shots.split[[prop[[1]]]]$hometeam == prop[[3]] &
shots.split[[prop[[1]]]]$distance > 0)
if (length(rows)>0) shots.split[[prop[[1]]]]$adjusted.distance[rows] <-
split.object$quantile.adjust[shots.split[[prop[[1]]]]$distance[rows], rr]
}
for (bb in seasonblocks)
shots.in$adjusted.distance[shots.in$seasonblock==bb] <- shots.split[[bb]]$adjusted.distance
shots.in$adjusted.distance[shots.in$adjusted.distance > 200] <- 200
return(shots.in$adjusted.distance)
}
create.adjusted.distance <- function (sub.data, distance.adjust=NULL) { #, split.table
## load ("../../nhlscrapr-probs-0.RData")
## sub.data=grand.data; distance.adjust=NULL
message ("Correcting for Distance Anomalies.")
sub.data$adjusted.distance <- NA
etypes <- c("GOAL","SHOT","MISS")
shot.rows <- which (sub.data$etype %in% etypes)
shot.data <- sub.data[shot.rows,
c("season", "type", "ev.team", "hometeam", "awayteam", "distance")]
# shottypes <- unique(shot.data$type)
if (is.null(distance.adjust)) distance.adjust <- make.adjusted.distance.homeaway.table (shot.data)
dist.one <- update.adjusted.distance (shot.data, distance.adjust)
sub.data$adjusted.distance[shot.rows] <- dist.one
return(list(grand.data=sub.data,
distance.adjust=distance.adjust))
}
#impute locations for MISS shots.
impute.miss.xy <- function (grand.data) {
#load ("ainty.RData")
message ("Imputing missing shot locations using saved shots-on-goal.")
sub.data <- grand.data[,c("etype","type","adjusted.distance","xcoord","ycoord")]
etypes <- c("SHOT","MISS") #shots and misses have the same distance distributions.
shot.rows <- which (sub.data$etype %in% etypes)
tiny <- sub.data[shot.rows,]
tiny$adjusted.distance <- round(tiny$adjusted.distance)
for (dd in 1:200) {
if (dd %% 10 == 0) message ("Imputing distance from net: ", dd)
shotset <- which(tiny$adjusted.distance == dd & !is.na(tiny$xcoord) & !is.na(tiny$ycoord)) #tiny$etype=="SHOT" &
missset <- which(tiny$adjusted.distance == dd & (is.na(tiny$xcoord) | is.na(tiny$ycoord))) #tiny$etype=="MISS" &
if (length(shotset) > 0 & length(missset) > 0) {
picks <- sample(shotset, length(missset), replace=TRUE)
tiny$xcoord[missset] <- tiny$xcoord[picks]
tiny$ycoord[missset] <- tiny$ycoord[picks]
}
}
grand.data[shot.rows, c("xcoord","ycoord")] <- tiny[, c("xcoord","ycoord")]
return(grand.data)
}
## par(mfrow=c(2,1)); hist(tiny$adjusted.distance[tiny$etype=="MISS"]); hist(tiny$adjusted.distance[tiny$etype=="SHOT"]);
#######################################################################
## Bin into quadrilaterals.
in.triangle <- function (xyp, tr) {
area <- (-tr[5]*tr[3] + tr[4]*(tr[3]-tr[2]) + tr[1]*(-tr[6]+tr[5]) + tr[2]*tr[6])/2
ss <- 1/2/area * (tr[4]*tr[3] - tr[1]*tr[6] + (tr[6]-tr[4])*xyp[,1] + (tr[1]-tr[3])*xyp[,2])
tt <- 1/2/area * (tr[1]*tr[5] - tr[4]*tr[2] + (tr[4]-tr[5])*xyp[,1] + (tr[2]-tr[1])*xyp[,2])
output <- (ss > 0 & tt > 0 & 1 > ss+tt)
return(output)
}
in.tri.rev <- function (tr=matrix(c(0,0.5,1, 0,1,0), nrow=3), xy.points) in.triangle (xy.points, tr)
pick.section <- function (xy.points) {
in.1 <- apply(nhlscrapr::quadsarray[1:3,,], 3, in.tri.rev, xy.points)
in.2 <- apply(nhlscrapr::quadsarray[c(1,3,4),,], 3, in.tri.rev, xy.points)
picks <- in.1 | in.2
picks[is.na(picks)] <- FALSE
picker <- function (row) if (sum(row)>0) min(which(row)) else 0
sections <- apply (picks, 1, picker)
return(sections)
}
#######################################################################
expit <- function(x) exp(x)/(1+exp(x))
prob.score.simple.objects <- function (shots.in) {
#shots.in = shot.data[rows,]
#distance=shots.in$adjusted.distance
shots.in <- shots.in[shots.in$etype %in% c("SHOT","GOAL","MISS"),]
df1 <- data.frame (cut.distance = cut (shots.in$adjusted.distance, c(seq(0,100,by=5), Inf), include.lowest = TRUE),
its.a.sog = 1*(shots.in$etype %in% c("SHOT","GOAL")),
its.a.goal = 1*(shots.in$etype == "GOAL"))
df2 <- df1[df1$its.a.sog == 1,]
sog.obj <- suppressWarnings(bigglm (its.a.sog ~ cut.distance, family=binomial(link=logit), data=df1))
glm.obj <- suppressWarnings(bigglm (its.a.goal ~ cut.distance, family=binomial(link=logit), data=df2))
shot.if.ongoal <- expit(predict(sog.obj, df1))
df1$cut.distance[!(df1$cut.distance %in% unique(df2$cut.distance))] <- NA
goal.if.ongoal <- expit(predict(glm.obj, df1))
return(list(sog.obj=sog.obj, glm.obj=glm.obj,
shot.if.ongoal=shot.if.ongoal,
goal.if.ongoal=goal.if.ongoal))
}
shot.sub.rows <- function (shot.data, seasonblock, shottype, condition) {
shot.data$seasonblock <- season.block(shot.data$season)
rows <- NULL
if (condition == "homeESSH")
rows <- which(shot.data$home.sk <= shot.data$away.sk &
shot.data$ev.team == shot.data$hometeam &
shot.data$seasonblock == seasonblock &
shot.data$type == shottype &
shot.data$away.G > 1 & shot.data$home.G > 1)
if (condition == "homePP")
rows <- which(shot.data$home.sk > shot.data$away.sk &
shot.data$ev.team == shot.data$hometeam &
shot.data$seasonblock == seasonblock &
shot.data$type == shottype &
shot.data$away.G > 1 & shot.data$home.G > 1)
if (condition == "homeEN") #home team pulled their goalie. There are no "SHOT"s
rows <- which(shot.data$ev.team == shot.data$hometeam &
shot.data$seasonblock == seasonblock &
shot.data$type == shottype &
shot.data$away.G > 1 & shot.data$home.G == 1)
if (condition == "homeOnEN") #home team pulled their goalie. There are no "SHOT"s
rows <- which(shot.data$ev.team == shot.data$hometeam &
shot.data$seasonblock == seasonblock &
shot.data$type == shottype &
shot.data$away.G == 1 & shot.data$home.G > 1)
if (condition == "awayESSH")
rows <- which(shot.data$home.sk >= shot.data$away.sk &
shot.data$ev.team == shot.data$awayteam &
shot.data$seasonblock == seasonblock &
shot.data$type == shottype &
shot.data$away.G > 1 & shot.data$home.G > 1)
if (condition == "awayPP")
rows <- which(shot.data$home.sk < shot.data$away.sk &
shot.data$ev.team == shot.data$awayteam &
shot.data$seasonblock == seasonblock &
shot.data$type == shottype &
shot.data$away.G > 1 & shot.data$home.G > 1)
if (condition == "awayEN")
rows <- which(shot.data$ev.team == shot.data$awayteam &
shot.data$seasonblock == seasonblock &
shot.data$type == shottype &
shot.data$away.G == 1 & shot.data$home.G > 1)
if (condition == "awayOnEN")
rows <- which(shot.data$ev.team == shot.data$awayteam &
shot.data$seasonblock == seasonblock &
shot.data$type == shottype &
shot.data$away.G > 1 & shot.data$home.G == 1)
return(rows)
}
make.shot.probs.simple <- function (grand.data) {
#load("nhlscrapr-probs.RData")
if (!("shot.prob.distance" %in% colnames(grand.data))) grand.data$shot.prob.distance <- NA
if (!("prob.goal.if.ongoal" %in% colnames(grand.data))) grand.data$prob.goal.if.ongoal <- NA
etypes <- c("GOAL","SHOT","MISS")
shot.rows <- which (grand.data$etype %in% etypes)
shot.data <- grand.data[shot.rows,]
shottypes <- unique(shot.data$type)
#Get all the unique types.
shot.tables <- cbind(expand.grid (season.block=1:4,
shottypes=shottypes,
condition=c("homeESSH", "homePP", "homeEN", "homeOnEN",
"awayESSH", "awayPP", "awayEN", "awayOnEN"),
stringsAsFactors = FALSE),
shotcount=0)
out.objects <- list()
for (rr in 1:nrow(shot.tables)) {
message (paste(shot.tables[rr,], collapse=" "))
rows <- shot.sub.rows(shot.data, shot.tables[rr,1], shot.tables[rr,2], shot.tables[rr,3])
shot.tables[rr,4] <- length(rows)
result.1 <- try(prob.score.simple.objects (shot.data[rows,]), TRUE)
if (class(result.1) != "try-error") {
#prob.ongoal <- result.1[[1]]$fitted.values
#print(c(length(result.1[[3]]), length(result.1[[4]])))
shot.data$prob.goal.if.ongoal[rows] <- result.1[[4]]
shot.data$shot.prob.distance[rows] <- result.1[[3]] * result.1[[4]]
result.1[[3]] <- result.1[[4]] <- NULL
out.objects[[rr]] <- result.1
} else {
#print(table(shot.data[rows,]$etype))
if (length(rows)>0) {
shot.data$prob.goal.if.ongoal[rows] <- 0
shot.data$shot.prob.distance[rows] <- 0
}
out.objects[[rr]] <- NULL
}
}
grand.data$shot.prob.distance[shot.rows] <- shot.data$shot.prob.distance
grand.data$prob.goal.if.ongoal[shot.rows] <- shot.data$prob.goal.if.ongoal
return(list(grand.data=grand.data, scoring.models=out.objects, shot.tables=shot.tables))
}
fit.shot.probs.simple <- function (grand.data,
scoring.models,
shot.tables) {
#load("nhlscrapr-probs.RData"); grand.data
if (!("shot.prob.distance" %in% colnames(grand.data))) grand.data$shot.prob.distance <- NA
if (!("prob.goal.if.ongoal" %in% colnames(grand.data))) grand.data$prob.goal.if.ongoal <- NA
etypes <- c("GOAL","SHOT","MISS")
shot.rows <- which (grand.data$etype %in% etypes)
shot.data <- grand.data[shot.rows,]
shot.data$cut.distance <- cut (shot.data$adjusted.distance, c(seq(0,100,by=5), Inf), include.lowest = TRUE)
shot.data$its.a.sog <- 1*(shot.data$etype %in% c("SHOT","GOAL"))
shot.data$its.a.goal <- 1*(shot.data$etype == "GOAL")
for (rr in 1:nrow(shot.tables)) {
message (paste(shot.tables[rr,], collapse=" "))
rows <- shot.sub.rows(shot.data, shot.tables[rr,1], shot.tables[rr,2], shot.tables[rr,3])
if (rr <= length(scoring.models)) if (!is.null(scoring.models[[rr]])) {
sog.1 <- expit(predict(scoring.models[[rr]][[1]], shot.data[rows,]))
gol.1 <- expit(predict(scoring.models[[rr]][[2]], shot.data[rows,]))
shot.data$prob.goal.if.ongoal[rows] <- gol.1
shot.data$shot.prob.distance[rows] <- gol.1 * sog.1
} else {
shot.data$prob.goal.if.ongoal[rows] <- 0
shot.data$shot.prob.distance[rows] <- 0
}
}
grand.data$shot.prob.distance[shot.rows] <- shot.data$shot.prob.distance
grand.data$prob.goal.if.ongoal[shot.rows] <- shot.data$prob.goal.if.ongoal
return(grand.data=grand.data)
}
game.team.breakdown <- function (single.game.data) {
#single.game.data=grand.data[grand.data$season=="20132014" & grand.data$gcode=="20001",]
esub.c <- single.game.data[abs(single.game.data$home.score - single.game.data$away.score) <= 1,]
esub.f <- single.game.data[abs(single.game.data$home.score - single.game.data$away.score) > 1,]
retval <- c(home.eg.c=sum(esub.c$shot.prob.distance[esub.c$ev.team==esub.c$hometeam], na.rm=TRUE),
away.eg.c=sum(esub.c$shot.prob.distance[esub.c$ev.team==esub.c$awayteam], na.rm=TRUE),
home.eg.f=sum(esub.f$shot.prob.distance[esub.f$ev.team==esub.f$hometeam], na.rm=TRUE),
away.eg.f=sum(esub.f$shot.prob.distance[esub.f$ev.team==esub.f$awayteam], na.rm=TRUE),
home.go.c=sum(esub.c$etype[esub.c$ev.team==esub.c$hometeam]=="GOAL", na.rm=TRUE),
away.go.c=sum(esub.c$etype[esub.c$ev.team==esub.c$awayteam]=="GOAL", na.rm=TRUE),
home.go.f=sum(esub.f$etype[esub.f$ev.team==esub.f$hometeam]=="GOAL", na.rm=TRUE),
away.go.f=sum(esub.f$etype[esub.f$ev.team==esub.f$awayteam]=="GOAL", na.rm=TRUE),
home.sh.c=sum(esub.c$etype[esub.c$ev.team==esub.c$hometeam]=="SHOT", na.rm=TRUE),
away.sh.c=sum(esub.c$etype[esub.c$ev.team==esub.c$awayteam]=="SHOT", na.rm=TRUE),
home.sh.f=sum(esub.f$etype[esub.f$ev.team==esub.f$hometeam]=="SHOT", na.rm=TRUE),
away.sh.f=sum(esub.f$etype[esub.f$ev.team==esub.f$awayteam]=="SHOT", na.rm=TRUE),
home.mi.c=sum(esub.c$etype[esub.c$ev.team==esub.c$hometeam]=="MISS", na.rm=TRUE),
away.mi.c=sum(esub.c$etype[esub.c$ev.team==esub.c$awayteam]=="MISS", na.rm=TRUE),
home.mi.f=sum(esub.f$etype[esub.f$ev.team==esub.f$hometeam]=="MISS", na.rm=TRUE),
away.mi.f=sum(esub.f$etype[esub.f$ev.team==esub.f$awayteam]=="MISS", na.rm=TRUE),
home.bl.c=sum(esub.c$etype[esub.c$ev.team==esub.c$hometeam]=="BLOCK", na.rm=TRUE),
away.bl.c=sum(esub.c$etype[esub.c$ev.team==esub.c$awayteam]=="BLOCK", na.rm=TRUE),
home.bl.f=sum(esub.f$etype[esub.f$ev.team==esub.f$hometeam]=="BLOCK", na.rm=TRUE),
away.bl.f=sum(esub.f$etype[esub.f$ev.team==esub.f$awayteam]=="BLOCK", na.rm=TRUE))
retval <- c(retval,
sum(retval[seq(5,19,by=2)]), sum(retval[seq(6,20,by=2)]), #corsifor <-
sum(retval[seq(5,15,by=2)]), sum(retval[seq(6,16,by=2)]), #fenwickfor
sum(retval[seq(5,13,by=4)]), sum(retval[seq(6,14,by=4)]), #fenwickclose
sum(retval[c(1,3)]), sum(retval[c(2,4)])) #weighted
names(retval)[21:28] <- c("home.corsifor","away.corsifor","home.fenwickfor","away.fenwickfor","home.fenwickclose","away.fenwickclose","home.expectedgoals","away.expectedgoals")
return(retval)
}
augment.game.stats <- function(grand.data, games) {
#add: expected goals, corsi, fenwick, fenwick close, fenwick far
#games$home.eg.c <- games$away.eg.c <- games$home.eg.f <- games$away.eg.f <-
# games$home.go.c <- games$away.go.c <- games$home.go.f <- games$away.go.f <-
# games$home.sh.c <- games$away.sh.c <- games$home.sh.f <- games$away.sh.f <-
# games$home.mi.c <- games$away.mi.c <- games$home.mi.f <- games$away.mi.f <-
# games$home.bl.c <- games$away.bl.c <- games$home.bl.f <- games$away.bl.f <-
# NA
oldgamecols <- 10
nameholder <- game.team.breakdown (grand.data[1,])
if (dim(games)[2] == oldgamecols) {
statpack <- array(NA, c(nrow(games), length(nameholder)))
colnames(statpack) <- names(nameholder)
games <- cbind(games, statpack)
}
hometeams <- unique(games$hometeam)
for (tt in hometeams[hometeams != ""]) {
message ("Augmenting team ",tt)
rowchoice <- which(games$hometeam == tt)
game.sub <- games[rowchoice,]
event.sub <- grand.data[grand.data$hometeam == tt &
grand.data$etype %in% c("GOAL","MISS","SHOT","BLOCK"),]
for (gg in 1:length(rowchoice)) {
#message(":",tt," ",gg,":")
single.game.data <- event.sub[event.sub$season == game.sub$season[gg] &
event.sub$gcode == game.sub$gcode[gg] ,]
entire.game <- min(which(games$season == game.sub$season[gg] & games$gcode == game.sub$gcode[gg]))
games[entire.game, oldgamecols + 1:28] <- game.team.breakdown (single.game.data)
#statpack[entire.game,] <- game.team.breakdown (single.game.data)
}
}
#games <- cbind(games, statpack)
#save(games, file="games-plus.RData")
return(games)
}
team.table <- function (games.aug) {
#games.aug <- games[games$season == "20132014" & !is.na(games$away.expectedgoals),]
hometeam.for <- games.aug[,seq(11, 37, by=2)]
hometeam.against <- games.aug[,1+seq(11, 37, by=2)]
restable <- t(sapply (unique(c(games.aug$awayteam, games.aug$hometeam)), function(tt) {
teamfor <- apply(hometeam.for[games.aug$hometeam==tt,], 2, sum) + apply(hometeam.against[games.aug$awayteam==tt,], 2, sum)
teamag <- apply(hometeam.against[games.aug$hometeam==tt,], 2, sum) + apply(hometeam.for[games.aug$awayteam==tt,], 2, sum)
c(teamfor, teamag)
}))
restable.df <- data.frame(restable)
#colnames(restable) <- unique(c(games.aug$awayteam, games.aug$hometeam))
thisplot <- function () {
par(mfrow=c(1,3))
plot(restable.df$home.expectedgoals, restable.df$home.go.c+restable.df$home.go.f, ty="n"); text(restable.df$home.expectedgoals, restable.df$home.go.c+restable.df$home.go.f, rownames(restable.df)); abline(a=0,b=1,col=2)
plot(restable.df$away.expectedgoals, restable.df$away.go.c+restable.df$away.go.f, ty="n"); text(restable.df$away.expectedgoals, restable.df$away.go.c+restable.df$away.go.f, rownames(restable.df)); abline(a=0,b=1,col=2)
plot(restable.df$home.expectedgoals - restable.df$away.expectedgoals,
restable.df$home.go.c+restable.df$home.go.f - restable.df$away.go.c-restable.df$away.go.f - (restable.df$home.expectedgoals - restable.df$away.expectedgoals),
ty="n");
text(restable.df$home.expectedgoals - restable.df$away.expectedgoals,
restable.df$home.go.c+restable.df$home.go.f - restable.df$away.go.c-restable.df$away.go.f - (restable.df$home.expectedgoals - restable.df$away.expectedgoals),
rownames(restable.df));
abline(a=0,b=0,col=2)
}
}
#games[games$season == "20132014" & !is.na(games$away.expectedgoals),]
player.summary <- function (grand.data, roster.unique) {
#grand.data=recent.data
events <- c("PENL", "SHOT", "GOAL", "MISS", "BLOCK")
#player in event (1,2,3); player on ice for; player on ice against. 5 deep.
columns <- 3+c(5:16, 18:20, 28:29)
involved.players <- NULL;
for (cc in columns) involved.players <- unique(c(involved.players, grand.data[,cc]))
involved.players <- sort(involved.players)
output <- array(0, c(length(involved.players), length(events), 5))
#Probably a faster way to do this, but OK for now.
for (ee in events) {
message(paste("Matching", ee))
little.data <- grand.data[grand.data$etype==ee,]
if (dim(little.data)[1]>0) {
for (cc in c("ev.player.1", "ev.player.2", "ev.player.3")) {
evs <- table(little.data[,cc])
rws <- match(as.numeric(names(evs)), involved.players)
output[rws, which(ee==events), cc-20] <-
output[rws, which(ee==events), cc-20] + evs
}
#away team
for (cc in c("a1","a2","a3","a4","a5","a6", "away.G")) {
evs <- table(little.data[little.data$ev.team==little.data$hometeam, cc])
rws <- match(as.numeric(names(evs)), involved.players)
output[rws, which(ee==events), 5] <-
output[rws, which(ee==events), 5] + evs
evs <- table(little.data[little.data$ev.team==little.data$awayteam, cc])
rws <- match(as.numeric(names(evs)), involved.players)
output[rws, which(ee==events), 4] <-
output[rws, which(ee==events), 4] + evs
}
#home team
for (cc in c("h1","h2","h3","h4","h5","h6", "home.G")) {
evs <- table(little.data[little.data$ev.team==little.data$hometeam, cc])
rws <- match(as.numeric(names(evs)), involved.players)
output[rws, which(ee==events), 4] <-
output[rws, which(ee==events), 4] + evs
evs <- table(little.data[little.data$ev.team==little.data$awayteam, cc])
rws <- match(as.numeric(names(evs)), involved.players)
output[rws, which(ee==events), 5] <-
output[rws, which(ee==events), 5] + evs
}
}
}
output <- output[involved.players > 0,,]
involved.players <- involved.players[involved.players > 0]
rownames(output) <- roster.unique$firstlast[involved.players]
colnames(output) <- events
return(output)
}
#net probability of goal scoring.
NP.score <- function(grand.data, seconds=20) {
#load("nhlscrapes-short.RData")
if (length(seconds)>1) stop ("seconds must have one entry.")
gt.home <- gt.away <- rep(3600, dim(grand.data)[1])
lastgoal.home <- lastgoal.away <- 100000
for (kk in (dim(grand.data)[1]-1):1) {
if (grand.data$seconds[kk+1] < grand.data$seconds[kk]) {lastgoal.home <- lastgoal.away <- 100000}
if (grand.data$etype[kk]=="GOAL") {
if (grand.data$ev.team[kk] == grand.data$hometeam[kk]) {
lastgoal.home <- grand.data$seconds[kk]
} else {
lastgoal.away <- grand.data$seconds[kk]
}
}
gt.home[kk] <- lastgoal.home - grand.data$seconds[kk]
gt.away[kk] <- lastgoal.away - grand.data$seconds[kk]
}
home.event <- grand.data$ev.team==grand.data$hometeam
counts.table <- NULL
for (ev in unique(grand.data$etype))
for (ht in unique(home.event))
for (zn in unique(grand.data$homezone)) {
events <- which(grand.data$etype==ev & home.event==ht & grand.data$zone==zn)
sub.home <- gt.home[events]
sub.away <- gt.away[events]
times <- c(sum(sub.away <= seconds), sum(sub.home <= seconds))
counts.table <- rbind(counts.table,
c(ev, ht, zn, length(events),
times))
#}
}
colnames(counts.table) <- c("etype", "home", "h.zone", "N.total", "G.away", "G.home")
counts.table <- as.data.frame(counts.table, stringsAsFactors=FALSE)
for (cc in 4:6) counts.table[,cc] <- as.numeric(counts.table[,cc])
counts.table$NP <- (counts.table$G.home - counts.table$G.away)/counts.table$N.total
return(counts.table)
}
add.game.adjacency <- function (games) {
games$homeafterhome <- games$homeafteraway <- games$awayafterhome <- games$awayafteraway <- 0
teams <- unique(c(games$hometeam, games$awayteam)); teams <- teams[nchar(teams)>0]
lastgame <- rep(as.Date("January 1 2000", format="%B %d %Y"), length(teams))
last.home <- rep(0, length(teams))
for (kk in 1:nrow(games)) if (nchar(games$hometeam[kk]) > 0 & nchar(games$awayteam[kk]) > 0 & !is.na(games$date[kk])){
if (games$date[kk] == lastgame[which(teams == games$hometeam[kk])] + 1) {
games$homeafterhome[kk] <- last.home[which(teams == games$hometeam[kk])]
games$homeafteraway[kk] <- 1-last.home[which(teams == games$hometeam[kk])]
}
if (games$date[kk] == lastgame[which(teams == games$awayteam[kk])] + 1) {
games$awayafterhome[kk] <- last.home[which(teams == games$awayteam[kk])]
games$awayafteraway[kk] <- 1-last.home[which(teams == games$awayteam[kk])]
}
lastgame[which(teams == games$hometeam[kk])] <- lastgame[which(teams == games$awayteam[kk])] <- games$date[kk]
last.home[which(teams == games$hometeam[kk])] <- 1
last.home[which(teams == games$awayteam[kk])] <- 0
}
return(games)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.