こんなツイートを観測した。
ハーフタイムに水道使用料が増えているのがわかる。
試合中に離席すると一番盛り上がる得点シーンを見逃してしまうため、試合中はなかなかトイレやお風呂にいけない。
というわけで試合中に離席するにはどの時間帯が一番よいかを調べる。
高校サッカーの点差を解析したときと同様に、過去のW杯の試合結果から得点が入った時刻を取得する。ここで、1930年から2014年大会までの20大会（1942年と1946年は中止）について、836試合あり、得点シーンは2373だった（wikiのFIFA 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% の得点が分布するので、どちらかというと前半のほうに離席するのがよい。
ある時間帯に得点が入ってから、次の得点が入るまでの時間の分布は、ガンマ分布のようになる。このため、ガンマ分布で推定すると、パラメータ(1.266, 0.0554) をもつ以下のようなガンマ分布になる。
得点が入ってから17分間で、50% の確率で次の点がはいるようなので、得点が入った直後は油断しないほうがよい。
ある時間帯にN点差がついているときに、そのままリードして試合終了する確率も選手権の解析と同様にしてみたが、ほとんど高校サッカーと同じ結果になった。試合終了間際まで1点リードしているとき、劇的ゴールで追いつくのは2.4% しかない（89分時点で1点リードしてそのまま90分=試合終了までリードを保つ確率が97.6%）。
勝ったな（確信）と思って風呂にはいったり寝たりするのは、90%の確信度でいくならば1点差なら後半75分あたり、2点差なら前半30分あたりでよい。
今回のデータ取りは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+–\\d+.*</th>")){ if(str_detect(tmp, "<th style.*–.*</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)
