Albert (2008) 打者の調子の波のモデル化

モチベーション

野球にはまったく興味ないんだけど、Albert (2008) "Streaky Hitting in Baseball"を読んでた。

http://citeseerx.ist.psu.edu/viewdoc/download?rep=rep1&type=pdf&doi=10.1.1.150.5808

スポーツデータ解析に関する論文を探すには Journal of Quantitative Analysis in Sports という雑誌が良さそう。

下記はカルロス・ギーエンという選手の2005年の打撃成績のデータで、ヒットを 1、アウトを 0 とコード化してある。

GuillenC <- c(0,1,0,1,1,0,0,0,1,0,0,0,0,0,0,1,0,0,0,0,1,1,1,0,0,0,0,0,0,1,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,0,1,0,1,0,0,1,1,0,1,0,1,1,0,1,0,1,1,0,0,0,0,0,1,1,1,1,0,0,1,0,1,0,0,1,1,0,0,0,1,0,1,0,0,0,1,1,1,0,1,1,1,1,0,0,1,1,1,1,0,0,1,0,0,1,0,1,0,0,0,1,0,1,0,0,0,0,0,1,1,1,0,0,1,0,0,0,0,0,0,1,1,1,0,1,0,0,0,0,1,1,1,1,0,1,0,0,0,1,0,0,0,0,0,0,1,0,0,0,0,1,1,0,1,0,0,0,0,0,0,0,0,0,1,1,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1,1,0,1,0,0,1,0,0,0,1,0,1,0,0,0,0,0,0,0,0,1,0,1,0,0,1,1,1,1,0,0,0,0,0,1,1,0,1,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,1,0,0,1,0,0,0,1,1,0,0,1,0,0,0,1,0,0,0,0,1,0,0,0,0,1,1,0,1,1,1,0,1,0,0,0,0,0,1,0,1,1,0,0,0,1,0,0,0,1)

年間通しての打率は役 3 割 2 分。

(ybar <- mean(GuillenC))#batting average#0.3203593

上記のデータの30打席ごとの移動平均をとってみる。

ma <-function(x, n){
  m <- stats::filter(x, rep(1,n))/ n
  m <- as.numeric(m)
  m[!is.na(m)]}
m <-ma(GuillenC,30)#####moving average graph for Carlos Guillen.
m2 <-c(ybar,m,ybar)#plot.ts(m2,ylab="moving average", main="2005 Carlos Guillen") #abline(h=ybar,lty=2)library(ggplot2)
df4plot <-data.frame(time=1:length(m2), MA=m2)
df4plot$lower <- ifelse(m2<=ybar,m2,ybar)
ggplot(df4plot,aes(x=time,y=MA))+
  geom_line()+
  geom_polygon(aes(x=time, ymin=lower,ymax=MA),alpha=0.3)+
  geom_hline(yintercept=ybar)+theme_bw()

f:id:abrahamcow:20160406012937p:plain

こうして見てみるとある時期には 5 割を超えていたり、またある時期には 1 割を下回っていたりする。

これはギーエンという打者に調子の波が存在する証拠だ、と言っていいだろうか。

パラメトリックブートストラップによる検定

調子の波が存在しない選手は、常にコンスタントな打率でヒットを出すから、その打撃成績を上記のように 0 か 1 かに符号化すると、それはベルヌーイ過程になる。

このコンスタントバッターを乱数でシミュレーションしてみる。

n <- length(GuillenC)
set.seed(1)
Chitter <- rbinom(n,size=1,prob=ybar)
m_C <-ma(Chitter,30)
m2_C <-c(ybar,m_C,ybar)
df4plot_C <-data.frame(time=1:length(m2_C), MA=m2_C)
df4plot_C$lower <- ifelse(m2<=ybar,m2,ybar)
ggplot(df4plot_C,aes(x=time,y=MA))+
  geom_line()+
  geom_polygon(aes(x=time, ymin=lower,ymax=MA),alpha=0.3)+
  geom_hline(yintercept=ybar)+theme_bw()

f:id:abrahamcow:20160406225927p:plain

これはこれで意味ありげな波が出来てしまった。

こうなってくるとちゃんと検定したくなるのが人情だろう。

帰無仮説：
“ギーエンの0-1のプロセスがベルヌーイ過程である。”

対立仮説：
“ギーエンの0-1のプロセスがベルヌーイ過程でない。”

帰無分布は乱数で生成するので思いつく限りの統計量で仮説検定を試すことができる。

アウトの連長の最大値（the length of the longest run of failures）
ヒットの連長の最大値（the length of the longest run of successes）
アウトの平均連長（the mean length of the lengths of runs of failures）
ヒットの平均連長（the mean length of the lengths of runs of success）

ここで連（run）とは 0 や 1 が連続するひとかたまりのことである。

モチベーションとなった例で出した移動平均からも統計量を作ってみる。

移動平均のレンジ（the range of the moving averages） $R = \max_j m_j − \min_j m_j$
移動平均のシーズン平均からの平均変動（the mean variation of the moving averages about the season average）

$\displaystyle B =\frac{1}{n-w-1}\sum^{n-w+1}_{j=1}|m_j-\bar y|$

この Bは冒頭のグラフの黒く塗りつぶした部分の面積に比例する量である。

(R <- diff(range(m)))#0.5(B <-sum(abs(ma(GuillenC,30)-mean(GuillenC)))/length(m))#"black" statistic#####
runs <-rle(GuillenC)(lengthRunOf0 <-  max(runs$lengths[runs$value==0]))#19(lengthRunOf1 <-  max(runs$lengths[runs$value==1]))#4(averageRunOf0 <- mean(runs$lengths[runs$value==0]))#3.242857(averageRunOf1 <- mean(runs$lengths[runs$value==1]))#1.528571#########simulation
boot_lengthRunOf0 <- boot_lengthRunOf1 <-
  boot_averageRunOf0 <- boot_averageRunOf1 <-
  boot_B <- boot_R<-numeric(10000)for(i in1:10000){
  simv <-rbinom(n,1,ybar)
  runs_sim <-rle(simv)
  boot_lengthRunOf0[i]<-  max(runs_sim$lengths[runs_sim$value==0])
  boot_lengthRunOf1[i]<-  max(runs_sim$lengths[runs_sim$value==1])
  boot_averageRunOf0[i]<- mean(runs_sim$lengths[runs_sim$value==0])
  boot_averageRunOf1[i]<- mean(runs_sim$lengths[runs_sim$value==1])
  boot_m <-ma(simv,30)
  boot_ybar <-mean(simv)
  boot_B[i]<-sum(abs(boot_m-boot_ybar))/length(boot_m)
  boot_R[i]<- diff(range(boot_m))}
hist(boot_lengthRunOf0)
abline(v=lengthRunOf0,col="red2",lwd=2)
hist(boot_lengthRunOf1)
abline(v=lengthRunOf1,col="red2",lwd=2)
hist(boot_averageRunOf0)
abline(v=averageRunOf0,col="red2",lwd=2)
hist(boot_averageRunOf1)
abline(v=averageRunOf1,col="red2",lwd=2)
hist(boot_B)
abline(v=B,col="red2",lwd=2)
hist(boot_R)
abline(v=R,col="red2",lwd=2)

検定統計量の分布をヒストグラムで示した。

赤い線はギーエンの打席結果から求めた統計量の実現値である。

f:id:abrahamcow:20160409014902p:plain
f:id:abrahamcow:20160409014900p:plain

f:id:abrahamcow:20160409014908p:plain
f:id:abrahamcow:20160409014859p:plain

f:id:abrahamcow:20160409014911p:plain
f:id:abrahamcow:20160409014904p:plain

それぞれの経験 p-値は以下のようになった。

> sum(boot_lengthRunOf0>=lengthRunOf0)/10000[1]0.063> sum(boot_lengthRunOf1>lengthRunOf1)/10000[1]0.5318> sum(boot_averageRunOf0>averageRunOf0)/10000[1]0.3266> sum(boot_averageRunOf1>averageRunOf1)/10000[1]0.2612> sum(boot_R>R)/10000[1]0.0133> sum(boot_B>B)/10000[1]0.0069

統計量	p-値
アウトの連長の最大値	0.063
ヒットの連長の最大値	0.5318
アウトの平均連長	0.3266
ヒットの平均連長	0.2612
R	0.0133
B	0.0069

Bだけが 5%水準で有意となった。

この結果からギーエンには調子の波があると言えそうである。

分割表の独立性の検定

ギーエンが直前の打席の結果をひきずっているとしたら、アウトの直後にヒットを打つ割合と、ヒットの直後にヒットを打つ割合は変化することになる。

直前＼直後	アウト	ヒット
アウト	157	70
ヒット	69	37

この分割表に対して独立性の検定を行う

帰無仮説：
”直前の結果と直後の結果は独立である。”

対立仮説：
”直前の結果と直後の結果は独立でない。”

検定してみると p-値は十分に大きく、ギーエンは直前の結果をひきずっているとは考えにくい。

> chisq.test(tab1)

	Pearson's Chi-squared test with Yates' continuity correction

data:  tab1
X-squared =0.3778, df =1, p-value =0.5388

ベータ二項モデル

統計量 B からはギーエンには調子の波があるといえそうなことはわかったがどのように調子の波があるかはわからない。例えば選手間で調子の波を比較したりしたくても B は打率に依存するため、そのような比較には不向きである。

そこでベータ二項モデルを導入してギーエンのヒットの数をモデル化することを考える。

表のように打席を 20 ごとに区切って集計する。

20 はおよそ 4 試合ごとの打席数とのこと。

ヒットの数	打席数
5	20
5	20
7	20
10	20
10	20
10	20
6	20
9	20
4	20
4	20
6	20
7	20
4	20
2	20
6	20
12	34

ヒットの数は二項分布に従うと仮定する。

さらに二項分布の成功確率 pはベータ分布に従うとする。

ここでの工夫はベータ分布を以下のようにパラメタライズすること。

$\displaystyle \frac{1}{B(K\eta,K(1-\eta))}p^{K\eta-1}(1-p)^{K(1-\eta)-1}$

こうすると ηは打率に対応するパラメータ、Kは打率の精度に関するパラメータと解釈できる。

Kが大きいほどばらつきが小さくなる。

Albert (2008) では ηと Kに対して無情報的事前分布を仮定しているが、それだとパラメータが収束してくれなかったのではここでは ηに区間 [0,1] の一様分布、Kにパラメータ 0.01 の指数分布を仮定することにする。

推定には最近はやりの Stan を使うことにする。

Stan のコードはこう。

data {
	int<lower=0> n;
	int<lower=0> m;
	int<lower=0> x[m];}
parameters {#  real<lower=0, upper=1> p[m];
  real<lower=0> K;
  real<lower=0, upper=1> eta;}
model {for(i in1:m){
		x[i]~ beta_binomial(n, K*eta, K*(1-eta));}//  increment_log_prob(-(log(eta)+log(1-eta))-2*log(1+K));
  K ~ exponential(0.01);}

R のコードはこう。

n <-length(GuillenC)
m <- n %/%20
datp12 <-numeric(m)
j<-0for(i in1:(m-1)){
  datp12[i]<- sum(GuillenC[seq(j+1,j+20,by=1)])
  j <- j+20}
datp12[m]<- sum(GuillenC[(j+1):n])#datp12d <- rep(20,m)#datp12d[m] <- 34#dat <- cbind(datp12,datp12d)library(rstan)
dat4stan <-list(x=datp12,n=20,m=length(datp12))#
n_chains <-4
init_ll <- lapply(1:n_chains,function(id)list(K=100,eta=0.3))
fitbetabinom <- stan("~/Documents/dotR/betabinom.stan",data = dat4stan,
                     init=init_ll,chains=n_chains,iter=4000)#traceplot(fitbetabinom,pars=c("K","eta"))
dbeta2 <-function(x,K,eta)dbeta(x,K*eta,K*(1-eta))

dbeta_binom <-function(y,n,K,eta){
  choose(n,y)*beta(K*eta+y,K*(1-eta)+n-y)/beta(K*eta,K*(1-eta))}
ex <-extract(fitbetabinom)
K_hat <-get_posterior_mean(fitbetabinom,"K")[,5]
eta_hat <-get_posterior_mean(fitbetabinom,"eta")[,5]
hist(datp12,freq =FALSE,breaks="FD",ylim = c(0,0.2))
lines(0:15,dbinom(0:15,20,ybar),type="b",col="blue")
lines(0:15,dbeta_binom(0:15,n=20,K=K_hat,eta=eta_hat),type="b",col="red")
legend("topright",c("binomial","beta-binomial"),lty=1,col=c("blue","red"))