piątek, 22 czerwca 2018

Czy mamy jeszcze szanse?

Mundial zaczął się dla jak zwykle w tym milenium, od porażki w żenującym stylu. Rozsądek podpowiada, że przed nami kolejna porażka i koniec emocji. Serce przekonuje, że szanse jeszcze przecież są. Rozsądek na to: sprawdźmy jak duże.
Można to zrobić m.im. odwołując się do danych historycznych. Znajdziemy je np. tutaj https://github.com/openfootball/world-cup. Są w formacie txt. Niestety nie do końca spójnym z imprezy na imprezę, ale wystarczająco, żeby zautomatyzować ich obróbkę. Choć dostępne dane sięgają 1930 r. ograniczam się do 1998-2014, gdyż tylko w tych latach imprezy miały ten sam format - osiem czterodrużynowych grup, z których awansują dwie najlepsze.
Pobieranie danych i ich obróbkę załatwił poniższy kod w R:


 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
library(tidyverse)
library(RCurl)
library(tidyr)
library(glue)


# do testowania impreza = "2002--south-korea-n-japan"
#do testowania lewe_ciecie = ".*[0-9]+\\s[A-z]+"

ZrobTabele <- function(impreza,lewe_ciecie){
page_url <- glue("https://raw.githubusercontent.com/openfootball/world-cup/master/{impreza}/cup.txt")
my_data <- read.delim(page_url)

my_data <- as.vector(my_data$X............................)
mecze <- my_data[grepl("@", my_data)]
nr.meczu <- as.numeric(gsub(".*\\(([0-9]+)\\).*","\\1",mecze)) #ma zastapic dzien bo ten jest w roznych formatach
mecze <- gsub("@.*","",mecze)
mecze <- gsub(lewe_ciecie,"",mecze)
mecze <- gsub("\\(.-.\\)","",mecze)
mecze <- gsub(" ","",mecze)
mecze <- gsub("Republicof","",mecze) #bo w 2002 irlandia jest zapisana raz tak raz tak
wynik <- gsub(".*([0-9]-[0-9]).*","\\1",mecze)
p.druzyna <- gsub("(.*)[0-9]-[0-9].*","\\1",mecze)
d.druzyna <- gsub(".*[0-9]-[0-9](.*)","\\1",mecze)
grupa <- sort(rep(LETTERS[1:8],6))
tabela <- data.frame(grupa, nr.meczu, p.druzyna,d.druzyna,wynik)
tabela$p.gole <- as.numeric(substr(tabela$wynik,1,1))
tabela$d.gole <- as.numeric(substr(tabela$wynik,3,3))
tabela$roz.gole <- (tabela$p.gole - tabela$d.gole)
tabela$p.wynik <- ifelse(tabela$p.gole>tabela$d.gole,3,ifelse(tabela$p.gole<tabela$d.gole,0,1)) 
tabela$d.wynik <- ifelse(tabela$p.gole<tabela$d.gole,3,ifelse(tabela$p.gole>tabela$d.gole,0,1)) 

pierwsze <- tibble(grupa=tabela$grupa, nr.meczu=tabela$nr.meczu, druzyna=tabela$p.druzyna, 
                   goleF=tabela$p.gole, goleA=tabela$d.gole, goleR=tabela$roz.gole, 
                   punkty=tabela$p.wynik, przeciwnik=tabela$d.druzyna)
drugie <- tibble(grupa=tabela$grupa, nr.meczu=tabela$nr.meczu, druzyna=tabela$d.druzyna, 
                 goleF=tabela$d.gole, goleA=tabela$p.gole, goleR=-tabela$roz.gole, 
                 punkty=tabela$d.wynik, przeciwnik=tabela$p.druzyna)
tabela <- rbind(pierwsze, drugie)
tabela <- tabela[order(tabela$druzyna,tabela$nr.meczu),] #ulozenie wg druzyny i daty
mecz <- rep(c("fst","snd", "trd"),32) #tworzy ciąg 1,2,3,1,2,3 itd.
tabela$k.mecz <- as.factor(mecz) #przypisanie trzem meczom kazdej druzyny kolejnosci 1,2,3

#tworze tabele 'long' czyli tylko kolumny powtarzajace + jedna do rozciągnięcia w 'wide'
tabela_long <- tibble(grupa=tabela$grupa, druzyna=tabela$druzyna, 
                      punkty=tabela$punkty, k.mecz=tabela$k.mecz)
#przerobienie long na wide
tabela_wide <- spread(tabela_long,k.mecz,punkty)
tabela_wide <- tabela_wide %>% mutate(pkt=fst+snd+trd)


#tworzy z pierwszej tabeli sumaryczna roznice goli dla kazzdej druzyny
tabela_gr <- tabela %>% group_by(druzyna) %>% summarise(goleF = sum(goleF), goleA = sum(goleA)) %>%
  mutate(roznica=goleF-goleA) %>% select(druzyna, roznica)
# i dodaje taka kolumnę do table_wide
tabela_wide <- merge(tabela_wide, tabela_gr ,by.x = "druzyna", by.y = "druzyna")
# sortowanie wg grupy i punktów
tabela_wide <- tabela_wide[order(tabela_wide$grupa,-tabela_wide$pkt,-tabela_wide$roznica),]

pozycja <- rep(seq(1:4),8) #tworzy ciąg 1-4 pozycji w grupie
awans <- rep(c("T","T","N","N"),8) #tworzy ciąg 1-4 pozycji w grupie
tabela_wide$pozycja <- as.numeric(pozycja)
tabela_wide$awans <- awans

return(tabela_wide)
} #koniec funkcji ZrobTabele

RPA <- ZrobTabele("2010--south-africa",".*:[0-9]{2}")
Brazylia <- ZrobTabele("2014--brazil",".*:[0-9]{2}")
Niemcy <- ZrobTabele("2006--germany",".*/[0-9]+")
KorJap <- ZrobTabele("2002--south-korea-n-japan",".*[0-9]+\\s[A-z]+")
Francja <- ZrobTabele("1998--france",".*[0-9]+\\s[A-z]+")

zbiorcza <- rbind(Brazylia,RPA,Niemcy,KorJap,Francja)

To daje nam zbiorczą tabelę z wynikami wszystkich meczów grupowych ostatnich lat w następującym formacie:


1
2
3
4
5
6
7
      druzyna grupa fst snd trd pkt roznica pozycja awans
6       Brazil     A   3   1   3   7       5       1     T
23      Mexico     A   3   1   3   7       3       2     T
12     Croatia     A   0   3   0   3       0       3     N
8     Cameroon     A   0   0   0   0      -8       4     N
24 Netherlands     B   3   3   3   9       7       1     T
9        Chile     B   3   3   0   6       2       2     T

Więc teraz wystarczy policzyć ile razy drużyna przegrywająca pierwszy mecz (fst=0) dawała radę awansować (awans=T). Dodatkowo sprawdźmy jak szanse te zmieniają się w zależności od wyniku drugiego meczu.



1
2
3
4
5
6
7
8
#jaki % pregranych w pierwszym meczu awansowal
zbiorcza %>% count(fst,awans) %>% filter(fst==0) %>% mutate(procenty = n/ sum(n)) 
#jaki procent przegranych w pierwszym wygranych w drugim awansowal
zbiorcza %>% count(fst,snd,awans) %>% filter(fst==0 & snd==3) %>% mutate(procenty = n/ sum(n))
#jaki procent przegranych w pierwszym remis w drugim awansowal
zbiorcza %>% count(fst,snd,awans) %>% filter(fst==0 & snd==1) %>% mutate(procenty = n/ sum(n))
#jaki procent przegranych w pierwszym przegranych w drugim awansowal
zbiorcza %>% count(fst,snd,awans) %>% filter(fst==0 & snd==0) %>% mutate(procenty = n/ sum(n))

No więc tak - szanse są :) ale prawdopodobieństwo nie napawa optymizmem. Podsumować je można poniższym schematem.


Jeśli powtórzy się scenariusz z poprzednich dwóch imprez, w których Polacy brali udział, to po drugim meczu wszystko będzie jasne :)

czwartek, 14 czerwca 2018

Alternatywne historie mistrzostw świata w piłce nożnej

Na stronie Economist.com można znaleźć wykres prezentujący wszystkie gole strzelone na wszystkich dotychczasowych mistrzostwach świata. Fajna wizualizacja pokazuje kto, komu, w której minucie, fazie i jaki był ostateczny wynik. Wygląda to mniej więcej tak:


Gole nie są rozłożone równomiernie - są takie minuty w których padło więcej niż 40 goli i takie, w których mniej niż 10. Zatem czy jest to rozkład losowy, czy też jednak piłką rządzi jakaś prawidłowość?
Żeby to sprawić wygenerowałem alternatywne, zupełnie losowe historie mistrzostw świata. Zadane kryteria - ta sama liczba goli, karnych i samobójczych, ale dla uproszczenia usunąłem minuty dodatkowe - wszystko co ponad 45 w pierwszej połowie i 90 w drugiej (również dogrywki). Oczywiście odpowiednio zmniejszyłem liczbę goli.

Generowanie losowych historii i umieszczenie ich na wykresie zrobiłem w R.  Poniżej kod:


 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
library(ggplot2)
library(gridExtra)

kolory <- c("lightblue", "red", "yellow", "green") #wektor kolorow, zeby wykresy mialy rozne kolory
kolory1 <- c("#FF0000", "pink", "#000000")
kolory2 <- c("#FF0000", "yellow", "#000000")
kolory3 <- c("#FF0000", "lightgreen", "#000000")
kolory4 <- c("#FF0000", "lightblue", "#000000")
kolory <- list(kolory1, kolory2, kolory3, kolory4)

for(wykres in 1:4){ #petla robi 4 wykresy
x <- sample(1:90, 2259, replace=TRUE)  # losowy szereg z zakesu 1-90 o dlugosci 2259

x1 <- as.data.frame(table(x)) #przerobienie wektora szeregu na tabele z liczebnosciami i df
x1$x <- strtoi(x1$x)     #zamiana char na integer, bo w table pierwsza zmienna to char. z tego beda pobrane dane do petli 

x2 <- as.data.frame(x)    ##przerobienie wektora szeregu na df
x2 <- as.data.frame(x2[order(x),])   #sortowanie - do tego beda dodane sekwencje z petli. znowu as.data.frame, bo traci sie 
colnames(x2) <- "minuty" #nadanie nazwy kolumny, bo jakas dziwna powstaje


calosciowy <- vector()   #inicjacja wektora do petli


#petla tworz9ca wektory z sekwencjami od 1 do dlugosci rownej liczebnosci kazdej z minut

#nastjpnie sumowanie tych wektorow do jednego, ktory bedzie dodany jako kolumna do x2
for (wiersz in 1:90){      
minuta <- x1[wiersz, "x"]
ilosc <- x1[wiersz, "Freq"]
kolejny <- seq(1,ilosc)
calosciowy <- c(calosciowy,kolejny)}

x2$liczbagoli <- calosciowy

karny <- rep("karny", 174)
samob <- rep("samob", 38)
normalny <- rep("normalny", 2047)
rodzajgola <- c(karny,samob,normalny)
numerki <- seq(1,2259)
numerki <- sample(numerki)  #losowe ulozenie
typgola <- as.data.frame(rodzajgola)
typgola$numerki <- numerki
typgola <- as.data.frame(typgola[order(numerki),])
x2$typgola <- typgola$rodzajgola

assign(paste("p",wykres,sep=""), ggplot(x2, aes(minuty, liczbagoli, color=typgola)) +
   geom_point(size = 1.5) +
   theme(panel.border = element_blank(),
          panel.grid.major = element_line(size = 0.3, linetype = 'solid',
                                          colour = "#444444"),
          panel.grid.minor = element_blank(),
          panel.background = element_rect(fill="white")) +
   scale_color_manual(values=kolory4,guide=FALSE))
}

grid.arrange(p1, p2, p3, p4)



A tak wyglądają wyniki, bardzo podobnie do tych rzeczywistych. również są minuty z 30-40 golami i więcej, jak i takie poniżej 20.

Wniosek - nie ma żadnych prawidłowości gole padają i będą padać od 1 do ostatniej minuty i nie mamy jak tego przewidzieć. Przynajmniej jeśli chodzi o całą historię i wszystkie reprezentacje. Na pojedynczych przypadkach może to wyglądać inaczej, o czym niedługo we wpisie na FB @ZabawaDanymi.

Szukaj na tym blogu

Archiwum bloga