Hatena::ブログ(Diary)

驚異のアニヲタ社会復帰への道

Prima Project

2018-06-25

MikuHatsune2018-06-25

W杯の試合観戦中にトイレはいついくべきか

こんなツイートを観測した。

 

ハーフタイムに水道使用料が増えているのがわかる。

試合中に離席すると一番盛り上がる得点シーンを見逃してしまうため、試合中はなかなかトイレやお風呂にいけない。

というわけで試合中に離席するにはどの時間帯が一番よいかを調べる。

 

高校サッカーの点差を解析したときと同様に、過去のW杯の試合結果から得点が入った時刻を取得する。ここで、1930年から2014年大会までの20大会(1942年と1946年は中止)について、836試合あり、得点シーンは2373だった(wikiFIFA W杯のページをパースしたため、本当にそうなのかはわからない)。

1970年大会が6ゴール取得できてなかったようである。

1930 1934 1938 1950 1954 1958 1962 1966 1970 1974 1978 1982 1986 1990 1994 1998 2002 2006 2010 2014 
  70   70   84   88  140  126   89   89   89   97  102  146  132  115  141  171  161  147  145  171 

 

いつ得点が入るかをベタに分布をとると、高校サッカー選手権とほぼ同様で、どの時間帯でもほぼ一様な感じである。ただし、アディショナルタイムはすべて45分もしくは90分に換算しており、後半90分はほかの時間帯に比べて突出して得点が入っているので、試合終了間際は離席せずに見届けたほうがよい。

前半では全体の44%、後半では56% の得点が分布するので、どちらかというと前半のほうに離席するのがよい。

f:id:MikuHatsune:20180625210132p:image

 

ある時間帯に得点が入ってから、次の得点が入るまでの時間の分布は、ガンマ分布のようになる。このため、ガンマ分布で推定すると、パラメータ(1.266, 0.0554) をもつ以下のようなガンマ分布になる。

得点が入ってから17分間で、50% の確率で次の点がはいるようなので、得点が入った直後は油断しないほうがよい。

f:id:MikuHatsune:20180625210136p:image

 

ある時間帯にN点差がついているときに、そのままリードして試合終了する確率も選手権の解析と同様にしてみたが、ほとんど高校サッカーと同じ結果になった。試合終了間際まで1点リードしているとき、劇的ゴールで追いつくのは2.4% しかない(89分時点で1点リードしてそのまま90分=試合終了までリードを保つ確率が97.6%)。

勝ったな(確信)と思って風呂にはいったり寝たりするのは、90%の確信度でいくならば1点差なら後半75分あたり、2点差なら前半30分あたりでよい。

f:id:MikuHatsune:20180625210139p:image

 

今回のデータ取りはstringr を使ってR 内で完結させた。

# データとり
# wiki から
# W杯のトップページより、各グループステージ、決勝トーナメントの
# ページからデータをパースするほうが、フォーマットが整っていて効率がよい

url <- NULL
y1 <- seq(2014, 1998, -4)
lab <- c(sprintf("_Group_%s", LETTERS[1:8]), "_knockout_stage")
url <- c(url, mapply(function(z) sprintf("https://en.wikipedia.org/wiki/%d_FIFA_World_Cup%s", z, lab), y1))

y1 <- seq(1994, 1986, -4)
lab <- c(sprintf("_Group_%s", LETTERS[1:6]), "_knockout_stage")
url <- c(url, mapply(function(z) sprintf("https://en.wikipedia.org/wiki/%d_FIFA_World_Cup%s", z, lab), y1))

y1 <- 1982
lab <- c(sprintf("_Group_%s", c(1:6, LETTERS[1:4])), "_knockout_stage")
url <- c(url, mapply(function(z) sprintf("https://en.wikipedia.org/wiki/%d_FIFA_World_Cup%s", z, lab), y1))

y1 <- c(1978, 1974)
lab <- c(sprintf("_Group_%s", c(1:4, LETTERS[1:2])), "_knockout_stage")
url <- c(url, mapply(function(z) sprintf("https://en.wikipedia.org/wiki/%d_FIFA_World_Cup%s", z, lab), y1))

y1 <- c(seq(1970, 1954, -4), 1930)
lab <- c(sprintf("_Group_%s", 1:4), "_knockout_stage")
url <- c(url, mapply(function(z) sprintf("https://en.wikipedia.org/wiki/%d_FIFA_World_Cup%s", z, lab), y1))

y1 <- 1950
lab <- c(sprintf("_Group_%s", 1:4), "_final_round")
url <- c(url, mapply(function(z) sprintf("https://en.wikipedia.org/wiki/%d_FIFA_World_Cup%s", z, lab), y1))

y1 <- c(1938, 1934)
lab <- c(sprintf("_Group_%s", 1:4), "_final_tournament")
url <- c(url, mapply(function(z) sprintf("https://en.wikipedia.org/wiki/%d_FIFA_World_Cup%s", z, lab), y1))
write(url, "list.txt")

# パース
library(stringr)
fi <- list.files(pattern="FIFA")
Res <- NULL
g <- 0
for(f in fi){
  txt <- readLines(f)
  flag <- c("score"=0, "right"=1)
  res <- NULL
  for(tmp in txt){
    #if(str_detect(tmp, "<th style.*\\d+&#8211;\\d+.*</th>")){
    if(str_detect(tmp, "<th style.*&#8211;.*</th>")){ # 1986年のグループステージが半角スペースがあっておかしい
      flag["score"] <- 1
      goaltime <- vector("list", 2)
    }
    if(flag["score"] == 1){
      if(str_detect(tmp, "[\\d+]+'")){
        goaltime[[ flag["right"] ]] <- c(goaltime[[ flag["right"] ]], gsub("'", "", str_extract_all(tmp, "[\\d+]+'")[[1]]))
      }
      if(str_detect(tmp, "Report")){
        flag["right"] <- 2
      }
      if(str_detect(tmp, "</table>")){
        res <- c(res, list(goaltime))
        flag <- c("score"=0, "right"=1)
      }
    }
  }
  year <- as.numeric(str_extract(f, "\\d+"))
  for(i in seq(res)){
    g <- g + 1
    for(j in seq(res[[i]])){
      for(k in res[[i]][[j]]){
        l <- as.numeric(strsplit(k, "\\+")[[1]])
        hoge <- c(year, g, j, l, rep(0, 2-length(l)))
        Res <- rbind(Res, hoge)
      }
    }
  }
}
colnames(Res) <- c("year", "gameID", "HA", "time", "extra")
# 解析
dat <- read.table("score.txt", header=TRUE)
# 試合数の確認
Ngame <- c(18, 17, 18, 22, 26, 35, rep(32, 3), 38, 38, rep(52, 4), rep(64, 5))
mapply(function(z) length(unique(z$gameID)), split(dat, dat$year))

# 得点時間分布
sb <- subset(dat, time <= 90)
t1 <- 1:45
t2 <- 46:90
tab <- table(factor(sb$time, c(t1, t2)))/nrow(sb) * 100

cols <- c("red", "green")
par(mar=c(5, 5, 2, 2), cex.lab=1.6, cex.main=2)
b <- barplot(tab, col=c(mapply(rep, cols, each=sapply(list(t1, t2), length))), las=1, main="得点時間分布", ylab="頻度[%]", ylim=c(0, 3))
mtext("前半(分)", 1, line=3, at=mean(t1))
mtext("後半(分)", 1, line=3, at=mean(t2)+15)

# 得点間隔
sb <- dat
Tgoal <- lapply(split(sb$time, sb$gameID), sort)
difftime <- lapply(Tgoal, function(z) tail(c(0, z), -1) - head(c(0, z), -1))
difftime <- unlist(difftime)

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

# ガンマ分布による得点時間間隔
code <- "
data{
  int N;
  vector<lower=0>[N] Time;
}
parameters{
  real<lower=0, upper=50> p[2];
}
model{
  Time ~ gamma(p[1], p[2]);
}
"

m <- stan_model(model_code=code)
standata <- list(N=length(difftime), Time=difftime)
fit <- sampling(m, data=standata, iter=6000, warmup=1500, seed=1234)
ex <- extract(fit)

tab <- table(factor(difftime, 0:max(difftime)))/length(difftime) * 100
b <- barplot(tab, las=1)
ps <- apply(ex$p, 2, median)
x0 <- seq(0, max(difftime), length=1000)
y0 <- dgamma(x0, ps[1], ps[2])

alpha <- c(0.25, 0.5, 0.75, 0.9)
d0 <- c(5, 0.2)
par(mar=c(5, 5, 2, 2), cex.lab=1.6, cex.main=2)
plot(tab, xlab="前の得点からの経過時間(分)", ylab="頻度[%]", las=1)
lines(x0, y0*100, col=2, lwd=3)
for(i in seq(alpha)){
  x1 <- qgamma(alpha[i], ps[1], ps[2])
  y1 <- dgamma(x1, ps[1], ps[2])*100
  arrows(x1+d0[1], y1+d0[2], x1, y1, length=0.1, lwd=3, col=4)
  points(x1, y1, pch=16, col=4)
  text(x1+d0[1], y1+d0[2], sprintf("%2d %s (%.1f min)", alpha[i]*100, "%", x1), pos=4)
  title("次の得点の時間の分布")
}

# 得点差勝利確率
sb <- subset(dat, time <= 90)
mat <- mat0 <- mat1 <- mat2 <- matrix(0, max(dat$gameID), 90)
idx <- c(1, -1)
for(i in unique(sb$gameID)){
  tmp <- subset(sb, gameID==i)
  tmp <- tmp[order(tmp$time),]
  for(j in 1:nrow(tmp)){
    mat[i, tmp$time[j] ] <- mat[i, tmp$time[j]] + idx[tmp$HA[j]]
  }
}

mat0[,1] <- mat[,1]
for(j in 2:ncol(mat)){
  mat0[,j] <- mat0[, j-1] + mat[, j]
}

# 1点差以上
mat1[abs(mat0) > 0] <- 1
prob1 <- prob2 <- rep(0, 89)
for(j in 1:89){
  j1 <- mat1[, j] > 0
  prob1[j] <- mean(sapply(apply(mat1[j1, j:90], 1, unique), length) <= 1)
}

mat2 <- abs(mat0)
for(j in 1:89){
  j1 <- mat2[, j] > 1
  prob2[j] <- mean(apply(mat2[j1, j:90] > 0, 1, all))
}

p <- cbind(prob1, prob2)
par(mar=c(5, 5, 2, 4), cex.lab=1.6, cex.main=2, las=1)
matplot(p, xlab="時間", ylab="勝利確率", col=cols, pch=16, xaxp=c(0, 90, 6))
abline(v=45, lty=3)
legend("bottomright", legend=sprintf("%d 点差", 2:1), col=rev(cols), pch=16, cex=2)
text(par()$usr[2], tail(p[,1], 1), sprintf("%.1f %s", tail(p[,1], 1)*100, "%"), pos=4, xpd=TRUE)

スパム対策のためのダミーです。もし見えても何も入力しないでください
ゲスト


画像認証

トラックバック - http://d.hatena.ne.jp/MikuHatsune/20180625/1529929672