Introduction

• The Olympics is an international event that brings together the best athletes in the world every 4 years.
• Athletes compete for titles across a number of different sporting disciplines to be ultimately crowned the best in their field globally.
• The 2020 Olympics was set to be held in Tokyo however the global outbreak of COVID-19 meant that the renowned event was to be postponed until a vaccine was created and athlete safety could be guaranteed at the event.
• Now we arrive in 2021 where vaccines have been rolled out globally and The Olympics has been given the green light to go ahead over July and August ths year.

Introduction Cont.

With the 2021 Olympic games nearing, I have choen to investigate the question of the probability of winning gold at the Rio 2016 Olympics given age range, gender and sport. For each athlete, I will consider a number of factors including: - Sex - Age - Height - Weight - Sport - Medal Count

A lot of emphasis is always put on an athlete being in their “prime” age for competition therefore these variables will be used to calculate probability of winning gold, given an athlete’s age and gender for their respective sport. I have chosen the probability investigation for these specific variables as I believe the probability of winning gold in 2021 may have some different outcomes to the 2016 dataset as a result of the delayed olympic event. This may mean that some athletes that scraped into the ideal age range for their sport in 2016 might now overshoot this range in 2021 as they are a year older. Additionally, athletes are thought to be more likely to succeed if they have genetic advantages such as height in basketball or weight in weightlifting, thus genetic factors will be analysed as well. I am interested specifically in female athletes who are in their “prime age” as this group most closely reflects my personal athlete profile. I am also specifically interested in the weight variable as this can be controlled to some extent by athletes as height and age cannot.

Problem Statement

• What is the probability of winning gold at the 2016 Olympics based on being a “prime aged” female? And is it possible to predict weight in specific sports for future olympic athletes?
• I will use probability laws to calculate the probability for a number of different age ranges and for height and weight
• I will use probability distributions to visualise the spread of data and make accurate estimations based on mean, median and standard deviation
• The final output will be a number of probability tables with a number of age ranges, height (greater than or less than the median) and weight as the columns and each country as the rows
• To continue my investigation I will then compare my results with the 2012 olympic athlete dataset
  • Here I will take a sample of this dataset and assign likelihoods of winning as per probability in the 2016 dataset
  • I will use sampling to estimate confidence intervals
  • I will also use critical value hypothesis testing to compare the control group (2016 dataset) to the new dataset (2012)

Data

In this assigment I am using 2 complete files (no samples) called 2016athletes.csv and 2012athletes.csv. They were pulled from Kaggle and TopEndSports respectively with URL’s as follows: https://www.kaggle.com/rio2016/olympic-games & https://www.topendsports.com/events/summer/science/anthropometry-2012.htm

To preprocess the data, I will first load the dataset and do some exploratory data analysis: - Review format of the data - Rename columns in each dataset to match - Drop the ID column as it adds no benefit to finding the problem statement (noise). Also drop additional columns in 2012 dataset that aren’t in 2016 dataset - Check shape - Check variable types and change to factor and date variables for some - Convert M to male and F to Female in 2012 set to match 2016 set - Convert height to cm for 2016 dataset - Observe lowest and highest date of birth - no outliers observed - Check for missing values and input averages for that gender and sport - Check for obvious outliers and complete a google search these athletes to see if the data is entered incorrectly or if they are a physical anomaly - Complete feature construction and make a column with bins for age groups - each athlete is assigned an age range

#import data using the readr package, (file is located in the working directory)
athletes2016 <- read_csv("2016athletes.csv")
athletes2012 <- read_csv("2012athletes.csv")


#view the header of the data tables and view top 5 rows
head(athletes2016)

head(athletes2012)

Data Cont.

###understand and inspect the data - Data pre-processing

#check data types of the variables
lapply(athletes2016, class)

## $id
## [1] "numeric"
## 
## $name
## [1] "character"
## 
## $nationality
## [1] "character"
## 
## $sex
## [1] "character"
## 
## $dob
## [1] "character"
## 
## $height
## [1] "numeric"
## 
## $weight
## [1] "numeric"
## 
## $sport
## [1] "character"
## 
## $gold
## [1] "numeric"
## 
## $silver
## [1] "numeric"
## 
## $bronze
## [1] "numeric"

lapply(athletes2012, class)

## $Name
## [1] "character"
## 
## $Country
## [1] "character"
## 
## $Age
## [1] "numeric"
## 
## $`Height, cm`
## [1] "numeric"
## 
## $Weight
## [1] "numeric"
## 
## $Sex
## [1] "character"
## 
## $`Date of birth`
## [1] "character"
## 
## $`Birth Month`
## [1] "numeric"
## 
## $`Place of birth`
## [1] "character"
## 
## $Gold
## [1] "numeric"
## 
## $Silver
## [1] "numeric"
## 
## $Bronze
## [1] "numeric"
## 
## $Total
## [1] "numeric"
## 
## $Sport
## [1] "character"
## 
## $Event
## [1] "character"

#check dimensions
dim(athletes2016)

## [1] 11538    11

dim(athletes2012)

## [1] 10384    15

#check the structure
str(athletes2016)

## tibble [11,538 × 11] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
##  $ id         : num [1:11538] 7.36e+08 5.32e+08 4.36e+08 5.21e+08 3.39e+07 ...
##  $ name       : chr [1:11538] "A Jesus Garcia" "A Lam Shin" "Aaron Brown" "Aaron Cook" ...
##  $ nationality: chr [1:11538] "ESP" "KOR" "CAN" "MDA" ...
##  $ sex        : chr [1:11538] "male" "female" "male" "male" ...
##  $ dob        : chr [1:11538] "10/17/69" "9/23/86" "5/27/92" "1/2/91" ...
##  $ height     : num [1:11538] 1.72 1.68 1.98 1.83 1.81 1.8 2.05 1.93 1.8 1.65 ...
##  $ weight     : num [1:11538] 64 56 79 80 71 67 98 100 62 54 ...
##  $ sport      : chr [1:11538] "athletics" "fencing" "athletics" "taekwondo" ...
##  $ gold       : num [1:11538] 0 0 0 0 0 0 0 0 0 0 ...
##  $ silver     : num [1:11538] 0 0 0 0 0 0 0 0 0 0 ...
##  $ bronze     : num [1:11538] 0 0 1 0 0 0 1 0 0 0 ...
##  - attr(*, "spec")=
##   .. cols(
##   ..   id = col_double(),
##   ..   name = col_character(),
##   ..   nationality = col_character(),
##   ..   sex = col_character(),
##   ..   dob = col_character(),
##   ..   height = col_double(),
##   ..   weight = col_double(),
##   ..   sport = col_character(),
##   ..   gold = col_double(),
##   ..   silver = col_double(),
##   ..   bronze = col_double()
##   .. )

str(athletes2012)

## tibble [10,384 × 15] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
##  $ Name          : chr [1:10384] "Hiroshi Hoketsu" "Ian Millar" "Afanasijs Kuzmins" "Carl Bouckaert" ...
##  $ Country       : chr [1:10384] "Japan" "Canada" "Latvia" "Belgium" ...
##  $ Age           : num [1:10384] 71 65 65 58 57 57 56 56 56 54 ...
##  $ Height, cm    : num [1:10384] 168 185 178 181 173 185 177 190 180 175 ...
##  $ Weight        : num [1:10384] 61 76 89 78 63 88 76 82 78 77 ...
##  $ Sex           : chr [1:10384] "M" "M" "M" "M" ...
##  $ Date of birth : chr [1:10384] "3/28/1941" "1/6/1947" "3/22/1947" "4/19/1954" ...
##  $ Birth Month   : num [1:10384] 3 1 3 4 12 3 9 3 6 12 ...
##  $ Place of birth: chr [1:10384] "CHUO (JPN)" "Halifax (CAN)" "BIKERNIEKI PARISH (LAT)" "WAREGEM (BEL)" ...
##  $ Gold          : num [1:10384] 0 0 0 0 0 0 0 0 0 0 ...
##  $ Silver        : num [1:10384] 0 0 0 0 0 0 0 0 0 0 ...
##  $ Bronze        : num [1:10384] 0 0 0 0 0 0 0 1 0 0 ...
##  $ Total         : num [1:10384] 0 0 0 0 0 0 0 1 0 0 ...
##  $ Sport         : chr [1:10384] "Equestrian" "Equestrian" "Shooting" "Equestrian" ...
##  $ Event         : chr [1:10384] "Individual Dressage, WHISPER" "Individual Jumping, Team Jumping, STAR POWER" "Men's 25m Rapid Fire Pistol" "Individual Eventing, Team Eventing, CYRANO Z" ...
##  - attr(*, "spec")=
##   .. cols(
##   ..   Name = col_character(),
##   ..   Country = col_character(),
##   ..   Age = col_double(),
##   ..   `Height, cm` = col_double(),
##   ..   Weight = col_double(),
##   ..   Sex = col_character(),
##   ..   `Date of birth` = col_character(),
##   ..   `Birth Month` = col_double(),
##   ..   `Place of birth` = col_character(),
##   ..   Gold = col_double(),
##   ..   Silver = col_double(),
##   ..   Bronze = col_double(),
##   ..   Total = col_double(),
##   ..   Sport = col_character(),
##   ..   Event = col_character()
##   .. )

#drop additional columns in both sets

#first drop ID in 2016
athletes2016 <- select(athletes2016, -1)
head(athletes2016)

#next drop columns in 2012 dataframe that are not in 2016 dataframe
athletes2012 <- select(athletes2012, -3, -8, -9, -13, -15)
head(athletes2012)

#check current column names
colnames(athletes2016)

##  [1] "name"        "nationality" "sex"         "dob"         "height"     
##  [6] "weight"      "sport"       "gold"        "silver"      "bronze"

colnames(athletes2012)

##  [1] "Name"          "Country"       "Height, cm"    "Weight"       
##  [5] "Sex"           "Date of birth" "Gold"          "Silver"       
##  [9] "Bronze"        "Sport"

#rename the columns
colnames(athletes2016) <- c("Athlete Name", "Nationality", "Gender", "Date_of_Birth" ,
                        "Height", "Weight", "Sport", 
                        "Gold Medals","Silver Medals","Bronze Medals" )

colnames(athletes2012) <- c("Athlete Name", "Nationality",
                        "Height", "Weight", "Gender", "Date_of_Birth",
                        "Gold Medals","Silver Medals","Bronze Medals", "Sport")

#check the new column names
colnames(athletes2016)

##  [1] "Athlete Name"  "Nationality"   "Gender"        "Date_of_Birth"
##  [5] "Height"        "Weight"        "Sport"         "Gold Medals"  
##  [9] "Silver Medals" "Bronze Medals"

colnames(athletes2012)

##  [1] "Athlete Name"  "Nationality"   "Height"        "Weight"       
##  [5] "Gender"        "Date_of_Birth" "Gold Medals"   "Silver Medals"
##  [9] "Bronze Medals" "Sport"

#convert some categorical variables to factors
athletes2016$Gender <- as.factor(athletes2016$Gender)
athletes2012$Gender <- as.factor(athletes2012$Gender)
athletes2016$Sport <- as.factor(athletes2016$Sport)
athletes2012$Sport <- as.factor(athletes2012$Sport)


#Transform date of birth from character to date
athletes2016$Date_of_Birth <-as.Date(athletes2016$Date_of_Birth, format = "%m/%d/%y")
class(athletes2016$Date_of_Birth)

## [1] "Date"

x <-athletes2016$Date_of_Birth
foo <- function(x, year=1950){
  m <- year(x) %% 100
  year(x) <- ifelse(m > year %% 100, 1900+m, 2000+m)
  x
}

athletes2016$Date_of_Birth <- foo(x, 1950)
athletes2016

athletes2012$Date_of_Birth <-as.Date(athletes2012$Date_of_Birth, format = "%m/%d/%Y")
class(athletes2012$Date_of_Birth)

## [1] "Date"

#check for null values
lapply(athletes2016,function(x) { length(which(is.na(x)))})

## $`Athlete Name`
## [1] 0
## 
## $Nationality
## [1] 0
## 
## $Gender
## [1] 0
## 
## $Date_of_Birth
## [1] 1
## 
## $Height
## [1] 330
## 
## $Weight
## [1] 659
## 
## $Sport
## [1] 0
## 
## $`Gold Medals`
## [1] 0
## 
## $`Silver Medals`
## [1] 0
## 
## $`Bronze Medals`
## [1] 0

lapply(athletes2012,function(x) { length(which(is.na(x)))})

## $`Athlete Name`
## [1] 0
## 
## $Nationality
## [1] 0
## 
## $Height
## [1] 561
## 
## $Weight
## [1] 1280
## 
## $Gender
## [1] 0
## 
## $Date_of_Birth
## [1] 20
## 
## $`Gold Medals`
## [1] 0
## 
## $`Silver Medals`
## [1] 0
## 
## $`Bronze Medals`
## [1] 0
## 
## $Sport
## [1] 0

#calculate mean height and weight per sport and gender and fill empty values with these
athletes2016 <- athletes2016 %>% 
                      group_by(Gender, Sport) %>% 
                      mutate(Weight = ifelse(is.na(Weight), mean(Weight, na.rm = TRUE), Weight))

athletes2016 <- athletes2016 %>% 
                     group_by(Gender, Sport) %>% 
                     mutate(Height = ifelse(is.na(Height), mean(Height, na.rm = TRUE), Height))


#do the same for the 2012 dataset
athletes2012 <- athletes2012 %>% 
                      group_by(Gender, Sport) %>% 
                      mutate(Weight = ifelse(is.na(Weight), mean(Weight, na.rm = TRUE), Weight))

athletes2012 <- athletes2012 %>% 
                     group_by(Gender, Sport) %>% 
                     mutate(Height = ifelse(is.na(Height), mean(Height, na.rm = TRUE), Height))


#all boxing athletes have no entry for weight so I will replace these values with the average weight per their nationality and gender
athletes2016 <- athletes2016 %>% 
                      group_by(Nationality, Gender) %>% 
                      mutate(Weight = ifelse(is.na(Weight), mean(Weight, na.rm = TRUE), Weight))

lapply(athletes2016,function(x) { length(which(is.na(x)))})

## $`Athlete Name`
## [1] 0
## 
## $Nationality
## [1] 0
## 
## $Gender
## [1] 0
## 
## $Date_of_Birth
## [1] 1
## 
## $Height
## [1] 0
## 
## $Weight
## [1] 0
## 
## $Sport
## [1] 0
## 
## $`Gold Medals`
## [1] 0
## 
## $`Silver Medals`
## [1] 0
## 
## $`Bronze Medals`
## [1] 0

#we still have one DOB entry empty, I will analyse this particular athlete
missing_dob <- athletes2016[rowSums(is.na(athletes2016)) > 0,]
missing_dob

#The athlete is a well known russian sailor and his date of birth is publicly available so I will replace it with the public data
athletes2016[is.na(athletes2016)] <- c(as.Date("12/25/1987", format = "%m/%d/%Y"))

#convert height to cm for 2016 dataset
athletes2016$Height <- (athletes2016$Height) * 100
head(athletes2016)

#convert M to male and F to Female in 2012 set to match 2016 set
athletes2012$Gender <- as.character(athletes2012$Gender)
athletes2012$Gender[athletes2012$Gender == "M"] <- "male"
athletes2012$Gender[athletes2012$Gender == "F"] <- "female"
athletes2012$Gender <- as.factor(athletes2012$Gender)
head(athletes2012)

#observe Height variable range
min(athletes2016[,"Height"])

## [1] 121

which(athletes2016$Height == 121)

## [1] 7847

athletes2016[7847,]

max(athletes2016[,"Height"])

## [1] 221

which(athletes2016$Height == 221)

## [1] 5691

athletes2016[5691,]

#after searching online, this value of height is incorrect. I will replace it with his actual height 196cm
athletes2016[5691, 5] = 196
athletes2016[5691,]

#the new maximum is a Chinese basketballer and is correct
which(athletes2016$Height == 217)

## [1] 8770

athletes2016[8770,]

#Observe range of weight - no need to replace or change
min(athletes2016[,6])

## [1] 31

which(athletes2016$Weight == 31)

## [1] 3430

athletes2016[3430,]

max(athletes2016[,6])

## [1] 170

which(athletes2016$Weight == 170)

## [1] 1388 2338

athletes2016[2338,]

#Observe lowest and highest date of birth - no outliers observed
min(athletes2016$Date_of_Birth)

## [1] "1954-05-20"

max(athletes2016$Date_of_Birth)

## [1] "2002-11-26"

#create age bracket bins - we know the youngest athlete is 12 and the oldest is 62
#brackets will be 12 - 21, 22 - 31, 32 - 41, 42 - 51 and 52 - 62

#first add a column for age
a <- as.Date(athletes2016$Date_of_Birth)
b <- as.Date("8/5/2016", format = "%m/%d/%Y")

athletes2016$Age <- floor(age_calc(a, enddate = b, units = "years", precise = FALSE))
athletes2016

#Now create age bins
athletes2016$AgeBracket <- cut(athletes2016$Age, breaks=c(12, 21, 31, 41, 51, 61, 71), labels=c("12-21","22-31", "32-41", "42-51", "52-61", "62+"))
athletes2016

#count how many athletes fall into each ge bracket
count(athletes2016, vars = AgeBracket)

#we can see that most athletes (7907) are 22-31 years old.

#check null values
lapply(athletes2016,function(x) { length(which(is.na(x)))})

## $`Athlete Name`
## [1] 0
## 
## $Nationality
## [1] 0
## 
## $Gender
## [1] 0
## 
## $Date_of_Birth
## [1] 0
## 
## $Height
## [1] 0
## 
## $Weight
## [1] 0
## 
## $Sport
## [1] 0
## 
## $`Gold Medals`
## [1] 0
## 
## $`Silver Medals`
## [1] 0
## 
## $`Bronze Medals`
## [1] 0
## 
## $Age
## [1] 0
## 
## $AgeBracket
## [1] 0

lapply(athletes2012,function(x) { length(which(is.na(x)))})

## $`Athlete Name`
## [1] 0
## 
## $Nationality
## [1] 0
## 
## $Height
## [1] 0
## 
## $Weight
## [1] 804
## 
## $Gender
## [1] 0
## 
## $Date_of_Birth
## [1] 20
## 
## $`Gold Medals`
## [1] 0
## 
## $`Silver Medals`
## [1] 0
## 
## $`Bronze Medals`
## [1] 0
## 
## $Sport
## [1] 0

Details of the 2016athletes variables [1]:

• id: numeric variable, nominal, unique athlete ID
• name: athlete full name, nominal character variable
• nationality: athlete’s nationality, nominal character variable, represented as a 3-letter code for each country
• sex: Male or Female categrical variable
• dob: date of birth for each athlete in the form of mm/dd/yy (1 missing value)
• height: height of athlete in metres, numerical variable (330 missing values)
• weight: weight of athlete in kilograms, numerical variable (659 missing values)
• sport: the sport the athlete is competing in, categorical variable
• gold: tally of gold medals won by the athlete at the games, numerical variable
• silver: tally of silver medals won by the athlete at the games, numerical variable
• bronze:tally of bronze medals won by the athlete at the games, numerical variable

Details of the 2012athletes variables [2]:

• Name: athlete full name, nominal character variable
• Country: athlete’s nationality, nominal character variable, full name of the country of representation
• Age: age at time of competition
• Height, cm: height of athlete in centimetres, numerical variable (561 missing values)
• Weight: weight of athlete in kilograms, numerical variable (1280 missing values)
• Sex: Male or Female categrical variable represented as M or F (26 missing values)
• Date of birth: date of birth for each athlete in the form of mm/dd/yyyy
• Birth Month: number of the month of the year (1-12) that the athlete was born, ordinal variable
• Place of birth: city of birth for the athlete, categorical variable represented as city(XXX) (where X = 3-letter country code) (2690 missing values)
• Gold: tally of gold medals won by the athlete at the games, numerical variable
• Silver: tally of silver medals won by the athlete at the games, numerical variable
• Bronze: tally of bronze medals won by the athlete at the games, numerical variable
• Total: total tally of all medals won by the athlete at the games, numerical variable
• Sport: the sport the athlete is competing in, categorical variable
• Event: event within the sport that the athlete competed in, categorical variable

Sport and sex will need to be factor variables, date will need to be in the date format and birth month for the second dataset will also have to be factor. The levels for these are self explanatory, it will be a simple 1 & 2 for sex, it will be 1-12 for birth month and 1-n for sport where n is the number of different sports in the dataset.

Some variables such as height and weight are continuous numerical variables even though in this dataset they are represented as whole numbers. Other variables such as gold, silver and bronze medal tally will be discrete numerical variables as they only represent whole numbers of medals won (you can’t win half a medal)

Descriptive Statistics and Visualisation

Now that my data is ready to be used and is clean, I will complete some descriptive statistics and visualisations. In the above data cleaning section I have checked for any missing variables. With regards to height and weight, I used the average for that sport and the athlete’s gender. For a missing DOB variable, I obtained this from an online search of the athlete profile.

The important variables in my investigation will be sport, height, weight, age and medals won

First we observe the percentage of athletes in each sport. We can see that athletics has the overwhelming majority of athletes sitting at around 20% of total. All other sports make up around 5% or lower for each.

#Handle null values

#calculate mean height and weight per sport and gender and fill empty values with these
athletes2016 <- athletes2016 %>% 
                      group_by(Gender, Sport) %>% 
                      mutate(Weight = ifelse(is.na(Weight), mean(Weight, na.rm = TRUE), Weight))

athletes2016 <- athletes2016 %>% 
                     group_by(Gender, Sport) %>% 
                     mutate(Height = ifelse(is.na(Height), mean(Height, na.rm = TRUE), Height))


#do the same for the 2012 dataset
athletes2012 <- athletes2012 %>% 
                      group_by(Gender, Sport) %>% 
                      mutate(Weight = ifelse(is.na(Weight), mean(Weight, na.rm = TRUE), Weight))

athletes2012 <- athletes2012 %>% 
                     group_by(Gender, Sport) %>% 
                     mutate(Height = ifelse(is.na(Height), mean(Height, na.rm = TRUE), Height))


#all boxing athletes have no entry for weight so I will replace these values with the average weight per their nationality and gender
athletes2016 <- athletes2016 %>% 
                      group_by(Nationality, Gender) %>% 
                      mutate(Weight = ifelse(is.na(Weight), mean(Weight, na.rm = TRUE), Weight))

lapply(athletes2016,function(x) { length(which(is.na(x)))})

## $`Athlete Name`
## [1] 0
## 
## $Nationality
## [1] 0
## 
## $Gender
## [1] 0
## 
## $Date_of_Birth
## [1] 0
## 
## $Height
## [1] 0
## 
## $Weight
## [1] 0
## 
## $Sport
## [1] 0
## 
## $`Gold Medals`
## [1] 0
## 
## $`Silver Medals`
## [1] 0
## 
## $`Bronze Medals`
## [1] 0
## 
## $Age
## [1] 0
## 
## $AgeBracket
## [1] 0

#we still have one DOB entry empty, I will analyse this particular athlete
missing_dob <- athletes2016[rowSums(is.na(athletes2016)) > 0,]
missing_dob

#The athlete is a well known russian sailor and his date of birth is publicly available so I will replace it with the public data
athletes2016[is.na(athletes2016)] <- c(as.Date("12/25/1987", format = "%m/%d/%Y"))

#Visualisations: - First I view the height and weight relationship for all the atheletes - there appears to be some outliers as people who are very tall with low weight and people who are very short with high weight - we can also observe that the trend of the data exists that as height increases so does weight however there is a point where the data plateaus and athletes don’t get any taller however do get heavier.

• Next lets view the proportion of our athletes in each sport
• Then visualise proportion of athletes in each age bracket -> we can see the overwhelming majority of athletes are aged 22-31
• Next visualise proportion of athletes that win gold -> again we can see the overwhelming majority of athletes win 0 gold medals.
• lets dive deeper and see the exact percentage of winners of 1 - 5 gold medals.

• we observe that roughly 5.3% of athletes win 1 Gold medal or more

• Create box plots to view the relationship between height and winning gold.
  • It appears a taller athlete is more lilely than a smaller athlete to win 1 (or 5) gold medals
• Now compare athlete weight and winning gold
  • Here we see that a lighter athlete is more likely to win than a heavier athlete.
  • There are some outliers for the winners of 1 gold medal (where some very heavy athletes won)

#VISUALISATIONS

#First lets view the height and weight relationship for all the atheletes
plot(Height ~ Weight,  data = athletes2016)

#there appears to be some outliers as people who are very tall with low weight and people who are very short with high weight
#we can also observe that the trend of the data exists that as height increases so does weight however there is a point where the data plateaus and athletes don't get any taller however do get heavier.

#now lets view the proportion of our athletes in each sport
freqSports <- athletes2016$Sport %>% table() %>% prop.table()*100
barplot(freqSports, main = "Athlete Sport Participation - Percentage",ylab="Percent", xlab="Sport", cex.names=0.7, las=2)

#next visualise proportion of athletes in each age bracket
freqAges <- athletes2016$AgeBracket %>% table() %>% prop.table()*100
barplot(freqAges, main = "Athlete Age Brackets - Percentage",ylab="Percent", xlab="Age Bracket", cex.names=0.7, las=2)

#Again we can see the overwhelming majority of athletes are aged 22-31

#next visualise proportion of athletes that win gold
freqMedals <- athletes2016$`Gold Medals` %>% table() %>% prop.table()*100
barplot(freqMedals, main = "Athlete Gold Medal Winners - Percentage",ylab="Percent", xlab="Gold Medal Count", cex.names=0.7, las=2)

#Again we can see the overwhelming majority of athletes win 0 gold medals.

#lets dive deeper and see the exact percentage of winners of 1 - 5 gold medals.
#we observe that roughly 5.3% of athletes win 1 Gold medal or more
freqMedals

## .
##            0            1            2            3            4            5 
## 94.635118738  5.061535795  0.234009360  0.043335067  0.017334027  0.008667013

#Create box plots to view the relationship between height and winning gold. It appears a taller athlete is more lilely than a smaller athlete to win 1 (or 5) gold medals
athletes2016 %>% boxplot(Height ~ `Gold Medals`, data = ., main="Box Plot of Gold Medals by Height", 
        ylab = "Height", xlab = "Gold Medals", col="grey")

#Now compare athlete weight and winning gold
#Here we see that a lighter athlete is more likely to win than a heavier athlete. There are some outliers for the winners of 1 gold medal (where some very heavy athletes won)
athletes2016 %>% boxplot(Weight ~ `Gold Medals`, data = ., main="Box Plot of Gold Medals by Weight", 
        ylab = "Weight", xlab = "Gold Medals", col="grey")

Decsriptive Statistics Cont.

• Create 3 descriptive statistic tables:
  1. For age by each sport
  2. For height by each sport and gender
  3. Weight by each sport and gender, including calculations for normal distribution
  • In this table we can see those that have a distNorm value of 0 follow a normal distribution for weight
  • Therefore I will find these specific groups: Male and Female volleyball, female rowing, male football and male cycling

I will use male cycling weight as an example and plot a histogram with a normal overlay

#Create a table with the descriptive statistics for age by each sport
athletes2016 %>% group_by(Sport, `Gold Medals`) %>% summarise(Min = min(Age,na.rm = TRUE),
                                           Q1 = quantile(Age,probs = .25,na.rm = TRUE),
                                           Median = median(Age, na.rm = TRUE),
                                           Q3 = quantile(Age,probs = .75,na.rm = TRUE),
                                           Max = max(Age,na.rm = TRUE),
                                           Mean = mean(Age, na.rm = TRUE),
                                           SD = sd(Age, na.rm = TRUE),
                                           Range = Max - Min,
                                           IQR = Q3 - Q1,
                                           n = n()) -> table1
knitr::kable(table1)

#Now create a table with the descriptive statistics for height by each sport and gender
athletes2016 %>% group_by(Sport, Gender) %>% summarise(Min = min(Height,na.rm = TRUE),
                                           Q1 = quantile(Height,probs = .25,na.rm = TRUE),
                                           Median = median(Height),
                                           Q3 = quantile(Height,probs = .75,na.rm = TRUE),
                                           Max = max(Height,na.rm = TRUE),
                                           Mean = mean(Height, na.rm = TRUE),
                                           SD = sd(Height, na.rm = TRUE),
                                           Range = Max - Min,
                                           IQR = Q3 - Q1,
                                           n = n()) -> table2
knitr::kable(table2)

#Now create a table with the descriptive statistics for Weight by each sport and gender, including calculations for normal distribution
athletes2016 %>% group_by(Sport, Gender) %>% summarise(Min = min(Weight,na.rm = TRUE),
                                           Q1 = quantile(Weight,probs = .25,na.rm = TRUE),
                                           Median = median(Weight),
                                           Q3 = quantile(Weight,probs = .75,na.rm = TRUE),
                                           Max = max(Weight,na.rm = TRUE),
                                           Mean = mean(Weight, na.rm = TRUE),
                                           SD = sd(Weight, na.rm = TRUE),
                                           Variance = var(Weight),
                                           Range = Max - Min,
                                           IQR = Q3 - Q1,
                                           n = n(),
                                           valNorm = SD * 1.33,
                                           distNorm = IQR - valNorm) -> table3
knitr::kable(table3)

#I will use male cycling as an example and plot
maleCyc <- athletes2016 %>% 
                      group_by(Gender, Sport) %>% 
                      filter(Sport == "cycling" , Gender == "male")

#Plot histogram with normal overlay - Male cyclists weight
h<-hist(maleCyc$Weight,breaks=15, main = "Normal Distribution of Male Cyclists' weight")

weight.plot <-c(min(h$breaks),h$breaks)
freq<-c(0,h$density,0)
xfit<-seq(min(maleCyc$Weight),max(maleCyc$Weight),length=40)
yfit<-dnorm(xfit,mean=mean(maleCyc$Weight),sd=sd(maleCyc$Weight)) 
plot(weight.plot,freq,type="s",ylim=c(0,max(freq,yfit)), main="Normal pdf and histogram - Male Cyclist weights")
lines(xfit,yfit, col="red")
maleCyc$Weight %>% mean() %>% abline(v=.,col='red',lw=2)

#Complete probability testing as per research problem

1. Find the gold medal count and therefore probability of winning gold per sport and gender
2. Find probability of winning in your sport based on gender, number of medals and athletes - we observe that the highest probability sports to win for athletes based on being female are swimming and rowing (both higher than 9%) whilst the lowest probabilities are in golf and triathlon where there is little over 1% change of winning by gender
3. Now complete the same for males - In the male competitions we see the highest probability of winning in gymnastics which is > 11%, and the lowest probabilities in golf and triathlon again. - It is noted that the reason for this is there is only one event (one medal) for each of these sports so athletes cannot participate in multiple events, therefore lowering their chances.
4. Now I know that the most athletes are in age bracket 22-31 so I will calculate the probability of winning based on gender and age - We have found the probability of winning gold if you are in the age bracket 22-31 compared to a different age bracket. - The highest values are for the events where there is only 1 medal and the athlete fell in this age bracket e.g golf and triathlon as well as a number of other events where all gold medals were won by people in this age bracket. - The lowest probabilities are in shooting, gymnastics and boxing. - Total probabilites can be found in the final table per sport for females

#Probability testing

library(janitor)

#Find the gold medal count and therefore probability of winning gold per sport and gender
m1 <- as.matrix(tabyl(athletes2016, Gender, Sport))
m2 <- as.numeric(c(m1[1, 2:29]))
m3 <- as.numeric(c(m1[2, 2:29]))

athletes2016 %>%
  group_by(Sport)%>%
  filter(`Gold Medals` > 0 , Gender == "female") %>% 
  summarise(totalGoldMedals = sum(`Gold Medals`)) -> table4

knitr::kable(table4)

#Find probability of winning in your sport based on gender, number of medals and athletes
as.data.frame(table4)

table4$TotalFemaleAthletes <- m2
table4$ProbWin <- ((table4$totalGoldMedals / table4$TotalFemaleAthletes) * 100)
table4

#Now complete for males
athletes2016 %>%
  group_by(Sport)%>%
  filter(`Gold Medals` > 0 , Gender == "male") %>% 
  summarise(totalGoldMedals = sum(`Gold Medals`)) -> table5

knitr::kable(table5)

as.data.frame(table5)

table5$TotalMaleAthletes <- m3
table5$ProbWin <- ((table5$totalGoldMedals / table5$TotalMaleAthletes) * 100)
table5

#Now I know that the most athletes are in age bracket 22-31 so I will calculate the probability of winning based on gender and age
as.matrix(tabyl(athletes2016, AgeBracket, Sport))

##      AgeBracket aquatics archery athletics badminton basketball boxing canoe
## [1,] "12-21"    "529"    "32"    " 350"    " 14"     " 19"      " 50"  " 38"
## [2,] "22-31"    "848"    "76"    "1668"    "138"     "209"      "219"  "238"
## [3,] "32-41"    " 68"    "17"    " 339"    " 20"     " 60"      " 17"  " 54"
## [4,] "42-51"    "  0"    " 3"    "   6"    "  0"     "  0"      "  0"  "  1"
## [5,] "52-61"    "  0"    " 0"    "   0"    "  0"     "  0"      "  0"  "  0"
## [6,] "62+"      "  0"    " 0"    "   0"    "  0"     "  0"      "  0"  "  0"
##      cycling equestrian fencing football golf gymnastics handball hockey judo 
## [1,] " 56"   " 8"       " 21"   "180"    "17" "165"      " 23"    " 51"  " 37"
## [2,] "385"   "63"       "172"   "412"    "64" "150"      "265"    "345"  "317"
## [3,] " 81"   "78"       " 53"   " 19"    "30" "  9"      " 74"    " 36"  " 38"
## [4,] "  3"   "53"       "  0"   "  0"    " 9" "  0"      "  1"    "  0"  "  0"
## [5,] "  0"   "19"       "  0"   "  0"    " 0" "  0"      "  0"    "  0"  "  0"
## [6,] "  0"   " 1"       "  0"   "  0"    " 0" "  0"      "  0"    "  0"  "  0"
##      modern pentathlon rowing rugby sevens sailing shooting table tennis
## [1,] "10"              " 47"  " 29"        " 43"   " 44"    "29"        
## [2,] "57"              "429"  "243"        "261"   "169"    "97"        
## [3,] " 5"              " 68"  " 28"        " 71"   "128"    "42"        
## [4,] " 0"              "  2"  "  0"        "  4"   " 42"    " 2"        
## [5,] " 0"              "  1"  "  0"        "  1"   "  7"    " 2"        
## [6,] " 0"              "  0"  "  0"        "  0"   "  0"    " 0"        
##      taekwondo tennis triathlon volleyball weightlifting wrestling
## [1,] "34"      " 12"  " 5"      " 32"      " 50"         " 29"    
## [2,] "85"      "143"  "86"      "288"      "194"         "286"    
## [3,] " 9"      " 39"  "19"      " 64"      " 14"         " 38"    
## [4,] " 0"      "  2"  " 0"      "  0"      "  0"         "  0"    
## [5,] " 0"      "  0"  " 0"      "  0"      "  0"         "  0"    
## [6,] " 0"      "  0"  " 0"      "  0"      "  0"         "  0"

table4$totalGoldMedals

##  [1] 65  4 32  4 12  3  9 13  5 11 18  1 17 15 16  7  1 20 12  7  6  4  4  4  1
## [26] 14  7  6

athletes2016 %>%
  group_by(Sport, Gender)%>%
  filter(`Gold Medals` >0, AgeBracket == "22-31" , Gender == "female") %>% 
  summarise(AgeBracketGoldMedals = sum(`Gold Medals`)) -> table6

knitr::kable(table6)

as.data.frame(table6)

table6$totalGoldMedals <- as.numeric(c(table4$totalGoldMedals))

table6

#Now we have found the probability of winning gold if you are in the age bracket 22-31 compared to a different age bracket. The highest values are for the events where there is only 1 medal and the athlete fell in this age bracket e.g golf and triathlon as well as a number of other events where all gold medals were won by people in this age bracket. The lowest probabilities are in shooting, gymnastics and boxing.
table6$ProbGoldAge <- (table6$AgeBracketGoldMedals/table6$totalGoldMedals) * 100
table6$totalProbWin <- ((table4$totalGoldMedals / table4$TotalFemaleAthletes) * (table6$ProbGoldAge/100))*100
table6

#Now complete cluster sampling on the 2012 dataset and see if male cyclists also follow the same normal distribution for weight

1. Take all 2012 male road cyclists into a dataframe
2. Complete simple random sampling without replacement on the male cylcists 2012 dataframe
3. Check for normal distribution in the sample set using IQR = 1.33 * SD - We can see that 1.33 * SD is higher than IQR therefore the sample is not normally distributed
4. Now plot the distribution - In the 2016 dataset we see mean 72.57605, SD 9.065853 and variance 82.18970 therefore it makes sense we see different SD and variance however a similar mean as the sample population is a lot fewer
5. Calculate the confidence interval for this mean as a representative sample of the whole dataset
6. Finalise 95% CI for the sample

#take all male cyclists into a dataframe

maleCyc2012 <- athletes2012 %>% group_by(Sport, Gender) %>% 
                                           filter(Sport == "Cycling - Road", Gender == "male")
maleCyc2012

#complete simple random sampling without replacement on the male cylcists 2012 dataframe
index <- sample(1:nrow(maleCyc2012), 50) #take 50 samples
cycleSamp <- maleCyc2012[index,]
cycleSamp

#check for normal distribution in the sample set
summary(cycleSamp$Weight)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   58.00   65.25   69.50   70.65   76.00   86.00

IQR(cycleSamp$Weight)

## [1] 10.75

#we can see that 1.33 * SD is higher than IQR therefore the sample is not normally distributed
normCycSamp <- sd(cycleSamp$Weight) * 1.33
print(normCycSamp)

## [1] 9.212591

#now plot the distribution
h<-hist(cycleSamp$Weight,breaks=15, main = "Distribution of 2012 Sample group: Male Cyclists' weight")

weight.plot <-c(min(h$breaks),h$breaks)
freq<-c(0,h$density,0)
xfit<-seq(min(cycleSamp$Weight),max(cycleSamp$Weight),length=40)
yfit<-dnorm(xfit,mean=mean(cycleSamp$Weight,sd=sd(cycleSamp$Weight))) 
plot(weight.plot,freq,type="s",ylim=c(0,max(freq,yfit)), main="Normal pdf and histogram - Male Cyclist weights")
lines(xfit,yfit, col="red")
cycleSamp$Weight %>% mean() %>% abline(v=.,col='red',lw=2)

cycleSamp$Weight %>% mean() #mean is 71.89kg

## [1] 70.65168

cycleSamp$Weight %>% var() #variance is 34

## [1] 47.98

cycleSamp$Weight %>% sd() #SD is 5.83

## [1] 6.92676

#in the 2016 dataset we see mean 72.57605, SD 9.065853 and variance 82.18970 therefore it makes sense we see different SD and variance however a similar mean as the sample population is a lot fewer

#calculate the confidence interval for this mean as a representative sample of the whole dataset:
tcrit<- qt(p = 0.975, df = 50 -1)
CI95<- tcrit*(cycleSamp$Weight %>% sd()/sqrt(50))
CI95

## [1] 1.968563

#Therefore 95% CI for the sample is:
floorCI <- cycleSamp$Weight %>% mean() - CI95
roofCI <- cycleSamp$Weight %>% mean() + CI95
floorCI

## [1] 68.68312

roofCI

## [1] 72.62024

Hypothesis Testing

I will use a critical value approach as the goal is to ascertain if the mean of the 2012 sample population is outside of the critical values determined for mean in comparison to the mean of the 2016 dataset. This allows comparison of the 2 datasets and assumes the null hypothesis is true. I will use a two-tailed approach as it will be also important to consider the upper critical mean boundary as it is just as likely a sample population mean will be heavier than it is they will be lighter.

The critical mean now sits between 70.922 and 74.24, this means Pr(70.92 <= x¯<= 74.24)=0.05. A such, assuming the population mean = 72.58, sampling 50 people from the population and finding a mean to be less than 70.92 and greater than 74.24 would happen less than 5% of the time. In the case of our sample dataset we have a mean of 71.89kg which falls within the 95% of mean values we’d expect. Therefore we can say that the mean of the 2012 dataset sample is statistically insignificant.

cycleSamp %>% summarise(Min = min(Weight,na.rm = TRUE),
                        Q1 = quantile(Weight,probs = .25,na.rm = TRUE),
                        Median = median(Weight, na.rm = TRUE),
                        Q3 = quantile(Weight,probs = .75,na.rm = TRUE),
                        Max = max(Weight,na.rm = TRUE),
                        Mean = mean(Weight, na.rm = TRUE),
                        SD = sd(Weight, na.rm = TRUE),
                        n = n(),
                        Missing = sum(is.na(Weight)))

#sample mean is 71.89kg
cycleSamp$Weight %>% boxplot(ylab = "Weight (Kg)")

#hypothesis is Mean = 72.57605 as per 2016 dataset

#This means the sample mean sits 1.68 SEs below the population mean of 72.576. 
qt(p = 0.05/2, df = 50-1, lower.tail = TRUE)

## [1] -2.009575

#Write a short R function, named ttox to convert this back to a critical mean.
tcrittomean <- function(t ,mu, s, n) {
  se <- s/sqrt(n)
  x_bar <- mu + (t*se) #Determine critical mean
  return(x_bar)
}
#lower critical mean - 70.922
tcrittomean(t = qt(0.05/2,50-1,lower.tail = TRUE),
            mu = 72.58, 
            s = sd(cycleSamp$Weight),
            n = length(cycleSamp$Weight))

## [1] 70.61144

#upper critical mean - 74.24
tcrittomean(t = qt(1-(0.05/2),50-1,lower.tail = TRUE),
            mu = 72.58, 
            s = sd(cycleSamp$Weight),
            n = length(cycleSamp$Weight))

## [1] 74.54856

Discussion

First I cleaned the data, then did some visual analysis on the variables. After completing this I went on to complete some probability calculations with regard to the probability of winning gold based on athlete specific data. I did this by putting athletes in age brackets and grouping by sport and gender. I then calculated probability of winning based on your sport and gender, and also if female athletes were in the main age bracket as opposed to any other bracket. I created tables with final probabilities of winning. Most sports were around 5% chance if you were a female and aged 22-31 however this also ranged from 1-7% depending on the sport and how many gold medals/events were up for grabs.

This probability would be significantly lower for the other age brackets as most medals were won by people in this age bracket.

I then went on to complete sampling and hypothesis testing on the 2012 dataset. I used cluster sampling methods to sample male cyclists as this group of athletes had normal weight distribution in the 2016 dataset and I wanted to explore the weight of the same group of athletes in a different dataset.

I chose a sample size of 50 athletes as this is considered fairly large and to be a better representative sample than a smaller sample set of the total group (there were 325 male cyclists in the 2016 dataset). I completed a number of statistical summaries and did critical value hypothesis testing to come to the final conclusion that the sample mean was within 95% confidence of a reflective mean of the population. Therefore the mean of the 2012 dataset sample is statistically insignificant.

The strengths of the investigation lie in that there is strong evidence from these 2 datasets to identify the mean weight of olympic level male cyclists and therefore it is also likely the other normally distributed weights for gender and sport can be easily predicted.

However the limitiations lie with the data where weights are not normally distributed. This leaves room for future investigation. There may be rationale to combine a number of olympic datasets just by sport and gender for the specific sport and gender to analyse. Therefore a larger representative sample can be calculated and compared.

In response to my problem statement, calculating the probability of winning gold within a dataset is simple and I have created a table of probability of winning gold in each sport if you’re a “prime aged” female. However when it comes to predicting specific weight (or other continuous variable) of a separate group such as a future dataset there comes uncertainty with non-normal data. This data would have to be collected, collated and handled in a different manner.

References

[1] “2016 Olympics in Rio de Janeiro”, Kaggle.com, 2021. [Online]. Available: https://www.kaggle.com/rio2016/olympic-games. [Accessed: 12- May- 2021].

[2] R. Wood, “Anthropometry of Olympic Athletes 2012”, Topend Sports Website, 2012. [Online]. Available: https://www.topendsports.com/events/summer/science/anthropometry-2012.htm. [Accessed: 09- May- 2021].