Statistika výsledků hráčů hokejové reprezentace ČR na MS 2019

V této úloze budu zpracovávat data z MS v hokeji z roku 2019, konkrétně o data české reprezentace.

Původ dat

Data jsem získala z https://www.quanthockey.com/whc/en/teams/team-czech-republic-players-2019-whc-stats.html a propojila je s údaji získanými z https://www.iihf.com/pdf/690/ihm6900cze_33_5_0_cze

Struktura dat

Data jsou tvořena řádky obsahující údaje pro jednotlivé hráče. A to konkrétně číslo, jméno, pozici (GK - brankář, F - útočník, D - obránce), stranu (levá, pravá), výšku v metrech, váhu v kilogramech, datum narození, klub, věk, počet odehraných zápasů, počet gólů, počet asistencí, počet trestných minut, statistika +/-, počet gólů v přesilové hře, počet gólů v oslabení, počet rozdílových gólů, průměrný počet gólů za utkání, průměrný počet asistencí za utkání a průměrný počet bodů za utkání

Načtení dat

library(ggplot2)

Warning messages:
1: In readChar(file, size, TRUE) : truncating string with embedded nuls
2: In readChar(file, size, TRUE) : truncating string with embedded nuls
3: In readChar(file, size, TRUE) : truncating string with embedded nuls
4: In readChar(file, size, TRUE) : truncating string with embedded nuls
5: In readChar(file, size, TRUE) : truncating string with embedded nuls
6: In readChar(file, size, TRUE) : truncating string with embedded nuls
7: In readChar(file, size, TRUE) : truncating string with embedded nuls
8: In readChar(file, size, TRUE) : truncating string with embedded nuls
9: In readChar(file, size, TRUE) : truncating string with embedded nuls

library(dplyr)
library(ggpubr)
data <-  read.csv("hokej2019.csv", sep = ";")
head(data)

NA

1

V tomto testu budu zkoumat, zda existuje vztah mezi počtem odehraných utkání a celkovým počtem získaných bodů. Očekávám, že čím více zápasů hráč odehrál, tím větší počet bodů získal. Provedu tedy lineární regresi. Nulová hypotéza: mezi počtem odehraných utkání a počtem získaných bodů není lineární vztah.

Nejprve si z dat vyberu vektory obsahující počty získaných bodů a počty odehraných utkání pro jednotlivé hráče mimo brankářů

players_no_gk <- data %>%
  filter(POS != "GK")
points <- players_no_gk$P; points

 [1]  4 14  4  3 11  2  4  6 10 12  2  1  2  7  3 12  1 16  5  1  0  1

games <- players_no_gk$GP; games

 [1]  7 10 10  6 10  5 10 10 10 10  8 10 10 10 10 10  9 10  9  5  8  9

Podívám se, jak data vypadají.

ggplot(players_no_gk, aes(x=GP, y=P)) + 
  geom_point(size=2, alpha=0.8)

Poté spočítám průměrný počet získaných bodů a průměrný počet odehraných zápasů.

points_mean = mean(points); points_mean

[1] 5.5

games_mean = mean(games); games_mean

[1] 8.909091

Spočítám a a b pro regresi.

a = sum((games-games_mean)*(points-points_mean))/sum((games-games_mean)^2); a

[1] 1.370821

b = pointsm - a*gamesm; b

[1] -6.712766

Vynesu přímku do grafu

ggplot(players_no_gk, aes(x=GP,y=P)) + 
  geom_point(size=2) + 
  geom_abline(slope=a, intercept=b, color="red")

Přímka docela dobře sedí pro hráče, kteří nehráli ve všech zápasech. U hráčů, kteří hráli všech 10 zápasů a kterých je největší množství jsou poměrně velké rozdíly - někdo neskóroval téměř žádné body, někteří hráči zas skórovali nadprůměrně.

relation <- lm(points~games)

summary(relation)

Call:
lm(formula = points ~ games)

Residuals:
   Min     1Q Median     3Q    Max 
-5.995 -3.745 -0.310  2.718  9.005 

Coefficients:
            Estimate Std. Error t value Pr(>|t|)  
(Intercept)  -6.7128     5.0732  -1.323   0.2007  
games         1.3708     0.5599   2.448   0.0237 *
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 4.331 on 20 degrees of freedom
Multiple R-squared:  0.2306,    Adjusted R-squared:  0.1921 
F-statistic: 5.994 on 1 and 20 DF,  p-value: 0.02371

relation$coefficients 

(Intercept)       games 
  -6.712766    1.370821 

p-hodnota vyšla 0,02371, což je méně než hladina významnosti 0,05, takže nulovou hypotézu můžeme zamítnout.

2

V tomto testu budu zkoumat, zda je věk hráčů dobře modelovaný normálním rozdělením.

Budu k tomu používat chi-kvadrát test. Nulová hypotéza: Data jsou modelována normálním rozdělením. Hladina významnosti alfa bude 0.05

Postup

Nejprve si načtu vektor věku hráčů a podívám se, jak data vypadají na histogramu.

age <- data$Age
ggplot(data.frame(age), aes(x = age)) + 
  geom_histogram(bins=6, fill="#FF67A4", color="#e9ecef", alpha=0.8) +
  ggtitle("Histogram věku hráčů")

Histogram vzpadá celkem nadějně, že by se skutečně mohlo jednat o normální rozdělení.

Spočítám průměr, rozptyl a směrodatnou odchylku.

age_mean <- mean(age); age_mean

[1] 26.68

age_var <- var(age); age_var

[1] 12.31

age_sd <- sd(age); age_sd

[1] 3.508561

Vytvořím věkové intervaly: <20, <23, <26, <29, <32, >= 32 Spočítám počet hráčů zastoupených v jednotlivých věkových intervalech a dále pro každý interval spočítám z-skóre. Z skóre počítám jako podíl, kde v čitateli je rozdíl horní hranice intervalu a průměru, ve jmenovateli je směrodatná odchylka

k <- 6
bounds <- c(20,23,26,29,32)

observed <- rep(0,6)
observed[1] <- sum(age < bounds[1])
observed[6] <- sum(age >= bounds[5])
for (i in 2:5) {
  observed[i] <- sum(age < bounds[i]) - sum(age < bounds[i-1])
}

z_scores <- rep(0,5)
for (i in 1:5){
  z_scores[i] <-  (bounds[i] - age_mean) / age_sd
}

Ze z skóre spočítám plochu pod křivkou normální distribuce N(0,1)

area_under <- rep(0,6)
for (i in 1:5) {
  area_under[i] = pnorm(z_scores[i])
}
area_under[6] = 1

Dále spočítám plochu v rámci intervalů

area_inside <- rep(0,6)
area_inside[1] = area_under[1]
for (i in 2:6){
  area_inside[i] = area_under[i] - area_under[i-1]
}

Z toho spočítám očekávané počty hráčů v jednotlivých věkových intervalech

expected <- rep(0,6)
for (i in 1:6) {
  expected[i] <- area_inside[i] * 25
}

Když mám spočítané pozorované a očekávané hodnoty pro jednotlivé intervaly, mohu provést chi-squared test. Počet stupňů volnosti je 5 (6 intervalů - 1)

chi <- 0
for (i in 1:6) {
  chi <- chi + ((observed[i] - expected[i])^2)/expected[i]
}

Závěr

Pro hladinu významnosti a 5 stupňů volnosti je kritická hodnota 11.070. Protože hodnota vyšla menší nemůžeme hypotézu zamítnout.

Další možnosti

Ještě je možné podívat se na Q-Q plot (quantile - quantile plot)

ggqqplot(age)

Z grafu je vidět, že body jsou poměrně blízko přímce, což naznačuje, že by se mohlo jednat o normální rozdělení.

Dále je možné použít Shapiro-Wilkův test normality, pro který v R existuje funkce.

shapiro.test(age)

    Shapiro-Wilk normality test

data:  age
W = 0.98158, p-value = 0.9146

Protože vyšla p-hodnota vyšší než 0,05, nelze hypotézu zamítnout.