Project 3

Introduction

In this project, you will work on various aspects related to the 2026 FIFA World Cup which is set to be hosted in North America starting on June 11, 2026.

You can submit this assignment as a team of up to five members. Enter the names (First Last) of each member below. Delete any unused name entries. Five points will be deducted from the final score for not completing this part correctly.

Also, obtain the seed to use during the project for any random sampling needs. To find your seed, go to the SML 201 Shiny App, click on ‘Our Project’, and find your name in the drop-down list to reveal your 5-digit seed value. If working as a team, choose the minimum of all the seed values from your team.

our.team = c(
  'Katharine Kalap',
  'Alice Patton',
  'Hanno Brach',
  'Matt Wagner'
)

our.seed = min(84751, 54050, 74539, 25114)

Please include your answers in the dedicated code chunks. You must render this file as an HTML file and then print to a PDF from your browser. You must submit a PDF file to be marked as complete.

Pay careful attention to the organization and layout of your final document. Sloppily-written code will cause point deductions, even if the code runs successfully. Commenting parts of your code will be helpful in understanding your thought process.

The necessary packages

library(tidyverse)
library(tidymodels)
library(leaflet)
library(highcharter)

The data connection

library(RPostgres)

con = dbConnect(
  drv = dbDriver('Postgres'),
  dbname = 'sml201',
  host = 'db-postgresql-nyc1-44203-do-user-8018943-0.b.db.ondigitalocean.com',
  port = 25061,
  user = 'tiger24a',
  password = 'AVNS_ryWfBbVwJUipscI_vpK',
  sslmode = 'require'
)

———————————

1. Qualifying Countries [25 total points]

# import the wccountries table
wccountries = dbGetQuery(con, 'SELECT * FROM wccountries')

As of April 4, 2024, there are 191 countries in the running to claim the 48 qualifying slots in the 2026 World Cup tournament. The rules by which the countries will be selected are governed by the confederations to which they belong. The confederations are determined by the geographic locations of the countries.

To start, the three host countries - USA, Mexico, and Canada - have each received an automatic qualification to the tournament. That leaves 45 open slots.

Each confederation is allocated a predetermined number of direct qualifying slots as shown below:

Confederation	Region	Direct Slots
AFC	Asia	8
CAF	Africa	9
CONCACAF	North, Central America & Caribbean	3
CONMEBOL	South America	6
OFC	Oceania	1
UEFA	Europe	16
	Total	43

There will then be a six-country playoff to determine the final two slots. The entries to this playoff tournament will be allocated by confederation (AFC 1, CAF 1, CONCACAF 2, CONMEBOL 1, and OFC 1). This will allow countries unable to qualify directly to have a second chance at qualifying.

1a. The Field [11 pts]

1a-0) Initial Qualifiers [3 pts]

For this project, you must select three additional countries to receive automatic qualifications. These three countries will count against the allowable direct slots for their respective confederations (e.g. if you choose Brazil as an auto-qualifying country, the CONMEBOL confederation will be allowed only five more direct slots).

Enter your three additional countries as elements to the countries.2 vector below. Be certain to spell the countries exactly as they appear in wccountries. You can (at your discretion) use data wrangling techniques to refer to these countries. One point will be deducted for each mismatched country.

Use this formula to create the column wt mentioned below:

\[ \mathrm{wt} = e^{(\mathrm{fifa\_ pts}-700)/200} \]

Round wt to two decimal places.

# assign the countries receiving the automatic bids
countries.1 = c('USA', 'Mexico', 'Canada')
countries.2 = c('North Korea', 'Palestine', 'Israel')
### North Korea (AFC down to 6 spots), Palestine (AFC down to 6 spots) Israel (UEFA down to 15 spots) # mutate a new column (wt) into wccountries containing the weights for being selected
wccountries <- mutate(wccountries,wt = exp((fifa_pts-700)/200))

1a-1) AFC Qualifiers [2 pts]

# number of allowable direct slots for AFC
# deduct any used slots from countries.1 & countries.2
n.afc = 6

# create the data frame (countries.afc) for all AFC countries
# do not include any countries already selected from countries.2
countries.afc = wccountries %>% 
  filter(confed == "AFC") %>% 
  filter(country != countries.1[1]) %>% 
  filter(country != countries.1[2]) %>% 
  filter(country != countries.1[3]) %>%
  filter(country != countries.2[1]) %>% 
  filter(country != countries.2[2]) %>% 
  filter(country != countries.2[3])

# determine the final countries for the AFC direct slots using a sampling method with the weights for each country
# use your seed value to lock in the selected countries
set.seed(our.seed[1])
sampled_df.afc <- countries.afc[sample(nrow(countries.afc), size = n.afc, replace = FALSE, prob = countries.afc$wt), ]
#sampled_df.afc
countries.afc <- countries.afc %>%
  filter(!country %in% sampled_df.afc$country)

1a-2) CAF Quaifiers [1 pt]

# number of allowable direct slots for CAF
# deduct any used slots from countries.1 & countries.2
n.caf = 9

# create the data frame (countries.caf) for all CAF countries
# do not include any countries already selected from countries.2
countries.caf = wccountries %>% 
  filter(confed == "CAF") |>
  filter(country != countries.1[1]) %>% 
  filter(country != countries.1[2]) %>% 
  filter(country != countries.1[3]) %>%
  filter(country != countries.2[1]) %>% 
  filter(country != countries.2[2]) %>% 
  filter(country != countries.2[3])

# determine the final countries for the CAF direct slots using a sampling method with the weights for each country
# use your seed value to lock in the selected countries
set.seed(our.seed[1])
sampled_df.caf <- countries.caf[sample(nrow(countries.caf), size = n.caf, replace = FALSE, prob = countries.caf$wt), ]
#sampled_df.afc
countries.caf <- countries.caf%>%
  filter(!country %in% sampled_df.caf$country)

1a-3) CONCACAF Qualifiers [1 pt]

# number of allowable direct slots for CONCACAF
# deduct any used slots from countries.1 & countries.2
n.concacaf = 3

# create the data frame (countries.concacaf) for all CONCACAF countries
# do not include any countries already selected from countries.1 & countries.2
countries.concacaf = wccountries %>% 
  filter(confed == "CONCACAF") |>
  filter(country != countries.1[1]) %>% 
  filter(country != countries.1[2]) %>% 
  filter(country != countries.1[3]) %>%
  filter(country != countries.2[1]) %>% 
  filter(country != countries.2[2]) %>% 
  filter(country != countries.2[3])

# determine the final countries for the CONCACAF direct slots using a sampling method with the weights for each country
# use your seed value to lock in the selected countries
set.seed(our.seed[1])
sampled_df.concacaf <- countries.concacaf[sample(nrow(countries.concacaf), size = n.concacaf, replace = FALSE, prob = countries.concacaf$wt), ]
#sampled_df.afc
countries.concacaf <- countries.concacaf%>%
  filter(!country %in% sampled_df.concacaf$country)

1a-4) CONMEBOL Qualifiers [1 pt]

# number of allowable direct slots for CONMEBOL
# deduct any used slots from countries.1 & countries.2
n.conmebol = 6

# create the data frame (countries.conmebol) for all CONMEBOL countries
# do not include any countries already selected from countries.2
countries.conmebol = wccountries %>% 
  filter(confed == "CONMEBOL") |>
  filter(country != countries.1[1]) %>% 
  filter(country != countries.1[2]) %>% 
  filter(country != countries.1[3]) %>%
  filter(country != countries.2[1]) %>% 
  filter(country != countries.2[2]) %>% 
  filter(country != countries.2[3])

# determine the final countries for the CONCACAF direct slots using a sampling method with the weights for each country
# use your seed value to lock in the selected countries
set.seed(our.seed[1])
sampled_df.conmebol <- countries.conmebol[sample(nrow(countries.conmebol), size = n.conmebol, replace = FALSE, prob = countries.conmebol$wt), ]
#sampled_df.afc
countries.conmebol <- countries.conmebol%>%
  filter(!country %in% sampled_df.conmebol$country)

1a-5) OFC Qualifiers [1 pt]

# number of allowable direct slots for OFC
# deduct any used slots from countries.2
n.ofc = 1

# create the data frame (countries.ofc) for all OFC countries
# do not include any countries already selected from countries.2
countries.ofc= wccountries %>% 
  filter(confed == "OFC") |>
  filter(country != countries.1[1]) %>% 
  filter(country != countries.1[2]) %>% 
  filter(country != countries.1[3]) %>%
  filter(country != countries.2[1]) %>% 
  filter(country != countries.2[2]) %>% 
  filter(country != countries.2[3])

# determine the final countries for the OFC direct slots using a sampling method with the weights for each country
# use your seed value to lock in the selected countries
set.seed(our.seed[1])
sampled_df.ofc <- countries.ofc[sample(nrow(countries.ofc), size = n.ofc, replace = FALSE, prob = countries.ofc$wt), ]
#sampled_df.afc
countries.ofc <- countries.ofc %>%
  filter(!country %in% sampled_df.ofc$country)

1a-6) UEFA Qualifiers [1 pt]

# number of allowable direct slots for UEFA
# deduct any used slots from countries.2
n.uefa = 16-1

# create the data frame (countries.uefa) for all UEFA countries
# do not include any countries already selected from countries.2
countries.uefa= wccountries %>% 
  filter(confed == "UEFA") |>
  filter(country != countries.1[1]) %>% 
  filter(country != countries.1[2]) %>% 
  filter(country != countries.1[3]) %>%
  filter(country != countries.2[1]) %>% 
  filter(country != countries.2[2]) %>% 
  filter(country != countries.2[3])

# determine the final countries for the UEFA direct slots using a sampling method with the weights for each country
# use your seed value to lock in the selected countries
set.seed(our.seed[1])
sampled_df.uefa <- countries.uefa[sample(nrow(countries.uefa), size = n.uefa, replace = FALSE, prob = countries.uefa$wt), ]
#sampled_df.afc
countries.uefa <- countries.uefa %>%
  filter(!country %in% sampled_df.uefa$country)

1a-7) Playoff Qualifiers [2 pts]

Now that the direct qualifiers have been determined, there are two remaining slots. Follow the steps outlined below to determine the playoff participants and the countries taking the final two spots.

# number of playoff slots
n.playoff = 2

# for each of the eligible confederations, determine which countries will qualify for the playoff tournament
# remember to not include any countries that have already qualified directly
# use a sampling method with the weights for each country
# use your seed value to lock in the playoff countries 

#make one big vector of possible countries for the playoff spots 
playoff_df = rbind(countries.afc, countries.caf, countries.concacaf, countries.conmebol, countries.ofc, countries.uefa)
set.seed(our.seed[1])

#randomly select 
playoff_countries <- playoff_df[sample(nrow(playoff_df), size = n.playoff, replace = FALSE, prob = playoff_df$wt), ]

1a-8) The Final Qualifiers [1 pt]

Combine all qualifying countries into one vector countries.48 that contains just the names of all qualifying countries.

Verify that there are exactly 48 countries in this vector.

#merging the current vectors/dfs
countries.48 = c(countries.1, countries.2, sampled_df.afc$country, sampled_df.caf$country, sampled_df.concacaf$country, sampled_df.conmebol$country, sampled_df.ofc$country, sampled_df.uefa$country, playoff_countries$country)

#duplicates <- countries.48[duplicated(countries.48)]

# Verfying number of distinct countries in the vector
number_of_countries <- countries.48 %>%
  n_distinct(countries.48)


#confirm there are 48 distinct 
if (number_of_countries == 48) {
  print("There are exactly 48 countries.")
} else {
  print("The number of countries is not 48.")
}

1b. The Draw [14 pts]

Now that the 48 qualifying countries have been determined, you will need to place each country in one of 12 groups (A through L) within which their group stage matches will be played.

1b-1) The Pots [4 pts]

A pot is a cluster of 12 countries grouped according to their skill ratings. Pot 1 will have the best 12 teams in terms of the probability of winning the whole World Cup. Pot 2 will have the next best 12, and so forth.

The column fifa_pts (the higher, the better) must be used to rank the countries.

Create a 12x4 matrix (pots) to contain the 48 qualifying countries such that pots[a,b] can be used to refer to a country in pot b with rank a (within its pot).

#create pots
pots = matrix(nrow = 12, ncol = 4)
#sort and filter df
world_cup_countries = wccountries |>
  filter(wccountries$country %in% countries.48) |>
  arrange(desc(fifa_pts))


#put into pots as appropriate 
pots[,1] <- as.matrix(world_cup_countries$country[1:12])
pots[,2] <- as.matrix(world_cup_countries$country[13:24])
pots[,3] <- as.matrix(world_cup_countries$country[25:36])
pots[,4] <- as.matrix(world_cup_countries$country[37:48])
pots

1b-2) The Groups [10 pts]

Create a looping process that will take each group and select the appropriate country from pots.

1. Each group must have four countries, exactly one from each pot.

2. No countries from countries.1 can belong to the same group.

3. A group cannot have more than one country from each confederation, except for UEFA. Since there will be 16 countries from UEFA, some groups can have up to two UEFA countries.

4. The group selection order will follow a “snake” pattern.

• Group A will select the highest-ranked country from pot 1. Group B will then select the next-highest-ranked country from pot 1. Repeat until Group L for pot 1.

• Then, Group L will select the highest-ranked country from pot 2. Group K will go next for pot 2. And so on. With each selection, the rules for conflicting countries within a group cannot be violated. If a selection does violate any rule, the group must select the next-highest-ranked country.

• Pot 3 allocation will start with group A and finish with group L.

• Pot 4 allocation will start with group L and finish with group A.

Create a 12x4 matrix (groups) to contain the 48 qualifying countries such that groups[a,b] can be used to refer to a country in group a from pot b.

#make groups matrix
groups <- matrix("", nrow = 12, ncol = 4)
groups[,1] <- pots[,1]

# Initialize UEFA count
UEFA_count <- 0

# Define a function to check conflicts
conflict_check <- function(country, group) {
  if (country == "" || country %in% group) {
    return(FALSE)  # No conflict if already in or blank 
  } else {
    conf <- world_cup_countries$confed[world_cup_countries$country == country]
    UEFA_count <- sum(group == "UEFA")
    if (conf == "UEFA") {
      UEFA_count <- UEFA_count + 1 #increase uefa count if this country also in uefa
    }
    if (UEFA_count > 2) {
      return(TRUE) #conflict as too many uefa countries
    }
    if (sum(group == conf) > 0) {
      return(TRUE)  # Conflict as more than 1 country in same league 
    }
  }
  return(FALSE) #can include country as doesn't conflict
}

# Loop through each pot and group to select countries
for (col in 1:4) {
  # Determine the order of selection based on the "snake" pattern
  if (col %% 2 == 1) {
    groups_order <- 1:12
  } else {
    groups_order <- 12:1
  }
  
  for (row in 1:12) {
    for (group_index in groups_order) {
      if (groups[group_index, col] == "") {
        # create new variable in case need to sleect next highest 
        rownumber <- row
        # Select the highest-ranked country from the pot
        selected_country <- pots[row, col]
        #check to see if it conflicts, while it conflicts 
        while (conflict_check(selected_country, groups[group_index, ])) {
          #keep adding one to the row number, choosing next best country until doesnt conflict
          rownumber <- rownumber + 1
          selected_country <- pots[rownumber, col]
        }
        #save non-conlicting country as that country in groups 
        groups[group_index, col] <- selected_country
        # next group 
        break 
      }
    }
  }
}


# Print the resulting matrix
print(groups)

#convert into dataframe for next bit 
wcgroups <- data.frame(grp = integer(), country = character())

# Iterate over each row of the matrix and bind it to wcgroups
for (i in 1:nrow(groups)) {
  wcgroups <- rbind(wcgroups, data.frame(grp = i, country = groups[i, ]))
}

———————————

2. Travel Planning [25 total points]

# import the wcvenues table
wcvenues = dbGetQuery(con, 'SELECT * FROM wcvenues')

# import the wcsched table
wcsched = dbGetQuery(con, 'SELECT * FROM wcsched')

# import the wcairports table
wcairports = dbGetQuery(con, 'SELECT * FROM wcairports')

# import the wcflights table
wcflights = dbGetQuery(con, 'SELECT * FROM wcflights')

2a. The Group Stage Schedule [12 pts]

During the group stage of the World Cup, each country will play three matches - one against each of the other countries within its group (round-robin format). Their performance during the group stage will dictate if they proceed to the knockout stage.

You will construct the schedule (date and location) of each group stage match.

Modify wcsched to include the countries for each of the group stage matches.

hosts = c('USA', 'Mexico', 'Canada')
#from above 
host.grps = c(9,12,5)


#get possible competitions hosts can be in 
host.comps = c(
  wcgroups |> filter(grp == host.grps[1] & country != hosts[1]) |> pull(country),
  wcgroups |> filter(grp == host.grps[2] & country != hosts[2]) |> pull(country),
  wcgroups |> filter(grp == host.grps[3] & country != hosts[3]) |> pull(country)
)

# assign host countries' matches in the scheudle 
for (i in 1:3) {
  host.matchnos = wcsched |> 
    filter(special == paste0('Must involve ', hosts[i])) |> 
    pull(match_no)
  wcsched$cntrya[host.matchnos[1:3]] = hosts[i]
  wcsched$cntryb[host.matchnos[1:3]] = host.comps[(i - 1) * 3 + 1:3]
  wcsched$grp[host.matchnos[1:3]] = LETTERS[host.grps[i]]
}
  


#all other countries 
countries.other.UMC = function(c, m) { # c country, m match no
  # c = 1 USA, 2 Mexico, 3 Canada
  grp.other = wcgroups |> 
    filter(grp == host.grps[c]) |> 
    filter(country != wcsched$cntrya[m]) |> 
    filter(country != wcsched$cntryb[m]) |> 
    pull(country)
  return(grp.other)
}



# match_no where special = 'Same group as *'
mat1 = c(c(6, 31, 60), c(2, 26, 54), c(5, 25, 52))
# match_no for UMC
mat2 = c(c(4, 32, 59), c(1, 28, 53), c(3, 27, 51))

# assign matches for countries in same group as UMC
for (i in 1:3) { # for each host
  for (j in 1:3) { # for each round
    wcsched$cntrya[mat1[(i - 1) * 3 + j]] = countries.other.UMC(i, mat2[(i - 1) * 3 + j])[1]
    wcsched$cntryb[mat1[(i - 1) * 3 + j]] = countries.other.UMC(i, mat2[(i - 1) * 3 + j])[2]
    wcsched$grp[mat1[(i - 1) * 3 + j]] = LETTERS[host.grps[i]]
  }
}




# groups other than those of UMC
grpsL.other = LETTERS[1:12][-host.grps]
grpsN.other = c(1:12)[-host.grps]

# match_no of all unassigned matches
round1.open = c(7:24)
round2.open = c(29:30, 33:48)
round3.open = c(49:50, 55:58, 61:72)
rounds = c(round1.open, round2.open, round3.open)

# assign group letters to open matches
wcsched$grp[round1.open] = grpsL.other[c(0:17) %/% 2 + 1]
wcsched$grp[round2.open] = grpsL.other[c(0:17) %/% 2 + 1]
wcsched$grp[round3.open] = grpsL.other[c(0:17) %/% 2 + 1]



# all combinations of matches in group stage
# c(1,2,3,4) 1v2 & 3v4
robins = c(c(1,2,3,4), c(1,3,2,4), c(1,4,2,3))

# assign countries to the open matches
for (i in 1:3) { # for each round
  for (j in 1:9) { # for each non-host grp
    k = grpsN.other[j] # grp # for selected non-host grp
    wcsched$cntrya[rounds[(i - 1) * 18 + 2 * j - 1]] = groups[k, robins[(i - 1) * 4 + 1]]
    wcsched$cntryb[rounds[(i - 1) * 18 + 2 * j - 1]] = groups[k, robins[(i - 1) * 4 + 2]]
    wcsched$cntrya[rounds[(i - 1) * 18 + 2 * j]] = groups[k, robins[(i - 1) * 4 + 3]]
    wcsched$cntryb[rounds[(i - 1) * 18 + 2 * j]] = groups[k, robins[(i - 1) * 4 + 4]]
  }
}
#print schedule
wcsched

2b. The Travel Itinerary [10 pts]

As your team members are avid fans of the sport and the magnitude of the events, you wish to create a function itinerary that will take as input a country and return a travel itinerary that will contain, for each leg of the flight schedule:

• the departure airport (name and code)

• the arrival airport (name and code)

• the date of travel

• the distance between (use dist_km function) the two airports

The flight details must be optimized for dates (at least one day before a match) and airport (nearest airport to the match venue).

# function to calculate distance in km between two sets of coordinates
dist_km = function(lat1, lng1, lat2, lng2) {
  R = 6378 # radius of earth in km
  r1 = lat1 * pi / 180
  r2 = lat2 * pi / 180
  d1 = (lat2 - lat1) * pi / 180
  d2 = (lng2 - lng1) * pi / 180
  a = sin(d1/2)^2 + cos(r1) * cos(r2) * sin(d2/2)^2
  return(2 * R * atan2(sqrt(a), sqrt(1-a)))
}

# home airport
airport0 = wcairports |> 
  filter(code == 'MCI') |> 
  select(name, code, lat, lng)
dows = c('SUN', 'MON', 'TUE', 'WED', 'THU', 'FRI', 'SAT')


#function 
itinerary = function(country) {
  
  # matches involving country
  cntry.matches = wcsched |> 
    filter(cntrya == country | cntryb == country)
  
  # dates of matches and travel (2 days before match)
  dates.matches = cntry.matches |> 
    mutate(dow = str_to_upper(wday(match_dt, label = TRUE))) |> 
    mutate(dow.travel = (wday(match_dt) - 3) %% 7 + 1)
  
  # venues coordinates
  venues.coord1 = wcvenues |> 
    filter(venue %in% cntry.matches$venue[1]) |> 
    select(lat, lng)
  venues.coord2 = wcvenues |> 
    filter(venue %in% cntry.matches$venue[2]) |> 
    select(lat, lng)
  venues.coord3 = wcvenues |> 
    filter(venue %in% cntry.matches$venue[3]) |> 
    select(lat, lng)
  
  # venue1 airport
  airport1 = wcairports |> 
    mutate(dist = dist_km(venues.coord1$lat, venues.coord1$lng, lat, lng)) |> 
    slice_min(dist, n = 1)
  # venue2 airport
  airport2 = wcairports |> 
    mutate(dist = dist_km(venues.coord2$lat, venues.coord2$lng, lat, lng)) |> 
    slice_min(dist, n = 1)
  # venue3 airport
  airport3 = wcairports |> 
    mutate(dist = dist_km(venues.coord3$lat, venues.coord3$lng, lat, lng)) |> 
    slice_min(dist, n = 1)

  # flight0 (airport0 to airport1)
  flight0 = wcflights |>
    filter(orig == airport0$code) |>
    filter(dest == airport1$code) |>
    filter(dow == dows[dates.matches$dow.travel[1]]) |>
    filter(dep > 800) |>
    slice_sample(n = 1) |>
    mutate(trav_dt = cntry.matches$match_dt[1] - 2) |>
    mutate(dist = dist_km(airport0$lat, airport0$lng,
                          airport1$lat, airport1$lng)) |>
    mutate(Leg = 0)

  # flight1 (airport1 to airport2)
  flight1 = wcflights |>
    filter(orig == airport1$code) |>
    filter(dest == airport2$code) |>
    filter(dow == dows[dates.matches$dow.travel[2]]) |>
    filter(dep > 800) |>
    slice_sample(n = 1) |>
    mutate(trav_dt = cntry.matches$match_dt[2] - 2) |>
    mutate(dist = dist_km(airport1$lat, airport1$lng,
                          airport2$lat, airport2$lng)) |>
    mutate(Leg = 1)

  # flight2 (airport2 to airport3)
  flight2 = wcflights |>
    filter(orig == airport2$code) |>
    filter(dest == airport3$code) |>
    filter(dow == dows[dates.matches$dow.travel[3]]) |>
    filter(dep > 800) |>
    slice_sample(n = 1) |>
    mutate(trav_dt = cntry.matches$match_dt[3] - 2) |>
    mutate(dist = dist_km(airport2$lat, airport2$lng,
                          airport3$lat, airport3$lng)) |>
    mutate(Leg = 2)

  # flight3 (airport3 to airport0)
  flight3 = wcflights |>
    filter(orig == airport3$code) |>
    filter(dest == airport0$code) |>
    filter(dep > 800) |>
    slice_sample(n = 1) |>
    mutate(trav_dt = cntry.matches$match_dt[3] + 1) |>
    mutate(dist = dist_km(airport0$lat, airport0$lng,
                          airport3$lat, airport3$lng)) |>
    mutate(Leg = 3)
  
  # flights
  return(
    bind_rows(
      flight0, flight1, flight2, flight3
    )
  )
  
}

2c. The Flight Map [3 pts]

With leaflet, map the locations of the venues at which your favorite country will be playing its group stage matches.

Create markers (addAwesomeMarkers) such that they are labeled 1, 2, or 3 in the chronological order of matches to be played.

#look at itinerary for england
legs = itinerary('England')

#make diagram 
wcairports |> 
  inner_join(legs, by = join_by(code == orig)) |> 
  arrange(Leg) |> 
  select(name, code, lat, lng) |> 
  bind_rows(airport0) |> 
  leaflet() |> 
  addTiles() |> 
  addAwesomeMarkers(
    lat = ~lat,
    lng = ~lng,
    popup = ~name,
    icon = awesomeIcons(
      markerColor = 'red',
      text = 0:3
    )
  ) |> 
  addPolylines(lat = ~lat, lng = ~lng, weight = 2)

———————————

3. Soccer Strategy [25 total points]

From the World Cup held in 2022 in Qatar, every shot attempt has been gathered in a dataset called wcshots. It utilizes a grid system overlaid on the pitch. The origin of this grid is the center of the goal line. The units of the coordinates are yards. See image below.

# import the wcshots table
wcshots = dbGetQuery(con, 'SELECT * FROM wcshots')

The columns of wcshots are defined as:

• shot_type: the outcome of the shot (block, goal, miss, post, save)

• situation: the circumstance under which the shot was taken (assisted, corner, fast-break, free-kick, penalty, regular, set-piece, shootout, throw-in-set-piece)

• body_part: the body part by which the ball was struck (head, left-foot, other, right-foot)

• xg: the expected goal metric (the probability of the shot becoming a goal under the given scenario)

• pos: the position of the player taking the shot (D = defender, F = forward, M = midfielder)

• x: the x coordinate of the location from where the shot was taken

• y: the y coordinate of the location from where the shot was taken

3a. Expected Goals (xG) [13 pts]

Create a linear regression model (model1) of expected goal as a function of the shot distance (\(d\)) from the origin and the angle (\(\theta\)) from the y-axis.

• You will have to mutate new columns (d & theta) in order to build this model. d is the Euclidean distance (in yards) from the origin. theta is measured in degrees. Both d and theta must be positive values.

• Remove penalty kicks from your training data.

• Use a 75/25 split of training/testing data. Be sure to use your seed during sampling.

• Just use one training set as determined by your data split.

• The effect of d and theta on xg is curvilinear. Choose the best curvature (nth-degree polynomial or exponential) to model the relationship. You must explain why you chose your final model for model1.

data1 = wcshots |>
  mutate(d = sqrt((x*x)+(y*y))) |>
  mutate(theta = abs(sin(x/y))) |>
  filter(!(situation == "penalty"))

# Set seed for reproducibility
set.seed(our.seed[1])

# Split data into training and testing sets
train_index <- sample(1:nrow(data1), 0.75 * nrow(data1))
train_data <- data1[train_index, ]
test_data <- data1[-train_index, ]

# Create linear regression model
model1 =  lm(xg ~ d + theta + I(d^2) + I(theta^2) + I(d^3) + I(theta^3), data = train_data)
#lm(exp(xg) ~ d + theta, data = train_data)



# Print summary of the model
summary(model1)

# Predict on test data
test_predictions <- predict(model1, newdata = test_data)

# Evaluate model performance (e.g., RMSE)
rmse <- sqrt(mean((test_data$xg - test_predictions)^2))
print(paste("Root Mean Squared Error (RMSE):", rmse))


#Root Mean Squared Error (RMSE) for linear model on test set : 0.145760006230988
#Root Mean Squared Error (RMSE) for quadratic model on test set : 0.138317912572916
# Root Mean Squared Error (RMSE) for cubic model on test set : 0.133814669561873
#Root Mean Squared Error (RMSE) for 4 degree polynomial on test set : 0.150339834705657
#Root Mean Squared Error (RMSE) for an exponentuial model on test set : 1.05135485354176


# so q cubic model was the decision for best model/3rd degree polynomial was best to model the relationship as it provided the lower RMSE

3b. Game Scenarios [12 pts]

Create a LASSO regression model (model2) of xg as a function of the game situation (situation) and body part (body_part).

• You will have to create new dummy variables in order to build this model.

• Remove penalty kicks from your training data.

• Use a 80/20 split of training/testing data. Use player position (pos) as a stratum. Be sure to use your seed during sampling.

• Use a 10-fold cross validation to train the model.

• Determine the penalty and the final model.

• Evaluate xg using this model for all the possible permutations of situation and body_part.

#preprocess data
data2 = wcshots |> 
  filter(!situation %in% c('penalty', 'shootout')) |> 
  select(xg, pos, situation, body_part)

set.seed(our.seed)
data.split2 = initial_split(data = data2, prop = 0.8, strata = pos)
train2 = training(data.split2)
test2 = testing(data.split2)


#define recipe for model 
rec = recipe(formula = xg ~ situation + body_part, data = train2) |> 
  step_dummy(all_nominal(), one_hot = TRUE)

lin_spec = linear_reg(penalty = tune()) |> 
  set_engine('glmnet')

# define flow 
flow = workflow() |> 
  add_recipe(rec) |> 
  add_model(lin_spec)

# number of folds for cross validation 
k.fold = vfold_cv(data = train2, v = 10, strata = 'pos', repeats = 1)

# Tune the model
tune.result <- tune_grid(
  object = flow,
  resamples = k.fold,
  grid = 10,
  metrics = yardstick::metric_set(yardstick::rmse)
)

# use tune results to determine the best model 
lambda.champion = tune.result |> 
  select_by_one_std_err(metric = 'rmse', desc(penalty))
# show the champion lambda
show_best(tune.result, metric = 'rmse', n = 1)

———————————

4. Match Outcomes [25 total points]

You will build a model to generate potential outcomes of all the matches to be played. To accomplish this, you will create a game model that will be executed for every scheduled match. Ultimately, one final country will be crowned the champion.

Note that the words ‘game’ and ‘match’ are used interchangeably, but mean the same thing.

# import the wcplayers table
wcplayers = dbGetQuery(con, 'SELECT * FROM wcplayers')

4a. The Game Model [15 pts]

The variables that will determine the outcomes of each match are:

• fifa_pts (from wccountries)

• presence of key players (from wcplayers)

• avg goals scored per match (from wccountries)

• avg goals allowed per match (from wccountries)

Create a function called game_model which has as input the two countries that will be playing. The output will be a vector of the goals scored by each of the competing countries.

The model will construct a simulation of a game where each side will take turns in possessing the ball. Each possession will occupy an amount of time and produce a binary outcome - score a goal or do not score a goal. When the time of all the possessions exceeds 90 minutes, the game will end.

The winner of a group stage match will receive three points. The loser receives no points. If a match ends in a draw, each team will receive one point.

#add new columns to wsched
wcsched = wcsched |> 
  mutate(
    goalsA = 0,
    goalsB = 0,
    ptsA = 0,
    ptsB = 0,
    played = FALSE
  )


# make the game model function which models a game between 2 countries 
game_model = function (a, b) {
  # get details for countries 
  game = wccountries |> 
    filter(country %in% c(a,b))
  # set offense and defense 
  offense = game$goals_for_pg
  defense = game$goals_against_pg
  # intiiate goals
  goals = c(0,0)
  # initiate time
  t = 5400
  # start w a random pass 
  poss = sample(c(a,b), 1)
  # create a loop while the time hasnt run out
  while (t > 0) {
    t = t - rnorm(1, 45, 15)
    r = runif(2)

    if (poss == a) {
      ctrl = if_else(
        r[1] < offense[1] / (offense[1] + defense[2]),
        offense[1],
        defense[2]
      )
      goals[1] = goals[1] + (r[2] < (ctrl / 100))
      poss = b
    } else {
      ctrl = if_else(
        r[1] < offense[2] / (offense[2] + defense[1]),
        offense[2],
        defense[1]
      )
      goals[2] = goals[2] + (r[2] < (ctrl / 100))
      poss = a
    }
    
  }
  # return a tibble of the number of goals scored and which team won the match (and hence their points in the playoff round)
  return(
    tibble(
      goalsA = goals[1],
      goalsB = goals[2],
      ptsA = if_else(goals[1] > goals[2], 3, if_else(goals[1] < goals[2], 0, 1)),
      ptsB = if_else(goals[1] < goals[2], 3, if_else(goals[1] > goals[2], 0, 1))
    )
  )
  
}

# practice by simulating a match between england and france 
game_model('England', 'France')

4b. The Matches [10 pts]

4b-1) The Group Stage [6 pts]

Run your game model for all 72 group stage matches.

Determine the knockout stage bracket from the results of the group stage.

The two countries with the most points per group will advance to the knockout stage. The next eight best point-scoring countries will receive the remaining eight knockout stage invites.

Ties in points will be broken according to FIFA rules. Refer to this page for a good explanation of them.

# create a tibble of the different pots, groups, countries, and confederations
wcgroups = tibble(pot = 1, grp = 1:12, country = 0, confed = 0) |> 
  bind_rows(tibble(pot = 2, grp = 1:12, country = 0, confed = 0)) |> 
  bind_rows(tibble(pot = 3, grp = 1:12, country = 0, confed = 0)) |> 
  bind_rows(tibble(pot = 4, grp = 1:12, country = 0, confed = 0))



for (i in 1:12) {
  wcgroups$country[i] = pots[i, 1]
  wcgroups$confed[i] = wccountries |> 
    filter(country == pots[i, 1]) |> 
    pull(confed)
} 

for (i in 24:13) {
  wcgroups$country[i] = pots[25 - i, 2]
  wcgroups$confed[i] = wccountries |> 
    filter(country == pots[25 - i, 2]) |> 
    pull(confed)
} 

for (i in 25:36) {
  wcgroups$country[i] = pots[i - 24, 3]
  wcgroups$confed[i] = wccountries |> 
    filter(country == pots[i - 24, 3]) |> 
    pull(confed)
} 

for (i in 48:37) {
  wcgroups$country[i] = pots[49 - i, 4]
  wcgroups$confed[i] = wccountries |> 
    filter(country == pots[49 - i, 4]) |> 
    pull(confed)
} 

# create groups matrix
groups = matrix(wcgroups$country, nrow = 12, ncol = 4)


# create wccountries.48 matrix (eccountries only in the 48 stage round, ordered descending fifa points)
wccountries.48 = wccountries |> 
  filter(country %in% countries.48) |> 
  arrange(desc(fifa_pts))

# create pots matrix, mae of the ordered 48 teams
pots = matrix(wccountries.48$country, nrow = 12, ncol = 4)



#add appropriate columns to the scheduling dataframe 
wcsched = wcsched |> 
  mutate(
    goalsA = 0,
    goalsB = 0,
    ptsA = 0,
    ptsB = 0,
    played = FALSE
  )


# play the 72 matches 
for (i in 1:72) {
  game = game_model(wcsched$cntrya[i], wcsched$cntryb[i])
  wcsched$goalsA[i] = game$goalsA
  wcsched$goalsB[i] = game$goalsB
  wcsched$ptsA[i] = game$ptsA
  wcsched$ptsB[i] = game$ptsB
  wcsched$played[i] = TRUE
}

# create a dataframe (grp.table) which shows the teams which advance 
grp.table.a = wcsched |> 
  filter(stage == 'group') |> 
  select(cntry = cntrya, grp, glsF = goalsA, glsA = goalsB, pts = ptsA)

grp.table.b = wcsched |> 
  filter(stage == 'group') |> 
  select(cntry = cntryb, grp, glsF = goalsB, glsA = goalsA, pts = ptsB)
# bind the 2 groups together 
grp.table = bind_rows(
  grp.table.a,
  grp.table.b
) |> 
  group_by(grp, cntry) |> 
  summarize(goalsF = sum(glsF), goalsA = sum(glsA), points = sum(pts)) |> 
  mutate(goalsDiff = goalsF - goalsA) |> 
  arrange(-points, -goalsDiff, -goalsF) |> 
  mutate(rank = rank(-points, ties.method = 'first')) |> 
  arrange(rank, -goalsDiff, -goalsF) |> 
  ungroup() |> 
  slice_head(n = 32) |> 
  mutate(seed = row_number())

#show the 32 teams to advance 
grp.table

4b-1) The Knockout Stage [4 pts]

Run your game model for the 31 knockout stage matches. Omit the consolation 3rd-place match.

You will need to append to the game_model the logic for extra time and/or a penalty shootout as each match must produce a winner (i.e. no ties allowed).

# seeds matrix 
seeds = c(1,8,4,5,2,7,3,6)

#seed the teams for the knockout stages from the ordered list of the 32 teams 
for (i in 1:8) {
  wcsched$cntrya[71 + 2*i] = grp.table$cntry[seeds[i]]
  wcsched$cntryb[71 + 2*i] = grp.table$cntry[33 - seeds[i]]
  wcsched$cntrya[72 + 2*i] = grp.table$cntry[17 - seeds[i]]
  wcsched$cntryb[72 + 2*i] = grp.table$cntry[16 + seeds[i]]
}

# play round 1 
for (i in 1:16) {
  cntrya = wcsched$cntrya[72 + i]
  cntryb = wcsched$cntryb[72 + i]
  game = game_model(cntrya, cntryb)
  wcsched$goalsA[72 + i] = game$goalsA
  wcsched$goalsB[72 + i] = game$goalsB
  wcsched$played[72 + i] = TRUE
  if (i %% 2 == 1) {
    wcsched$cntrya[88 + (i %/% 2) + 1] = if_else(
      game$goalsA > game$goalsB,
      cntrya,
      cntryb
    ) 
  } else {
    wcsched$cntryb[88 + (i / 2)] = if_else(
      game$goalsA > game$goalsB,
      cntrya,
      cntryb
    )
  }
}

# play round 2
for (i in 1:8) {
  cntrya = wcsched$cntrya[88 + i]
  cntryb = wcsched$cntryb[88 + i]
  game = game_model(cntrya, cntryb)
  wcsched$goalsA[88 + i] = game$goalsA
  wcsched$goalsB[88 + i] = game$goalsB
  wcsched$played[88 + i] = TRUE
  if (i %% 2 == 1) {
    wcsched$cntrya[96 + (i %/% 2) + 1] = if_else(
      game$goalsA > game$goalsB,
      cntrya,
      cntryb
    ) 
  } else {
    wcsched$cntryb[96 + (i / 2)] = if_else(
      game$goalsA > game$goalsB,
      cntrya,
      cntryb
    )
  }
}


# play qtrs
for (i in 1:4) {
  cntrya = wcsched$cntrya[96 + i]
  cntryb = wcsched$cntryb[96 + i]
  game = game_model(cntrya, cntryb)
  wcsched$goalsA[96 + i] = game$goalsA
  wcsched$goalsB[96 + i] = game$goalsB
  wcsched$played[96 + i] = TRUE
  if (i %% 2 == 1) {
    wcsched$cntrya[100 + (i %/% 2) + 1] = if_else(
      game$goalsA > game$goalsB,
      cntrya,
      cntryb
    ) 
  } else {
    wcsched$cntryb[100 + (i / 2)] = if_else(
      game$goalsA > game$goalsB,
      cntrya,
      cntryb
    )
  }
}



# play semis
for (i in 1:2) {
  cntrya = wcsched$cntrya[100 + i]
  cntryb = wcsched$cntryb[100 + i]
  game = game_model(cntrya, cntryb)
  wcsched$goalsA[100 + i] = game$goalsA
  wcsched$goalsB[100 + i] = game$goalsB
  wcsched$played[100 + i] = TRUE
  if (i == 1) {
    wcsched$cntrya[104] = if_else(
      game$goalsA > game$goalsB,
      cntrya,
      cntryb
    ) 
    wcsched$cntrya[103] = if_else(
      game$goalsA > game$goalsB,
      cntryb,
      cntrya
    ) 
  } else {
    wcsched$cntryb[104] = if_else(
      game$goalsA > game$goalsB,
      cntrya,
      cntryb
    )
    wcsched$cntryb[103] = if_else(
      game$goalsA > game$goalsB,
      cntryb,
      cntrya
    )
  }
}




# play final
cntrya = wcsched$cntrya[104]
cntryb = wcsched$cntryb[104]
game = game_model(cntrya, cntryb)
wcsched$goalsA[104] = game$goalsA
wcsched$goalsB[104] = game$goalsB
wcsched$played[104] = TRUE
#print the winner
if (game$goalsA > game$goalsB) {
  print(paste0(cntrya, ' is the winner!'))
} else {
  print(paste0(cntryb, ' is the winner!'))
}


# combine the results of the 2 dataframes into one table
knockout.a = wcsched |> 
  filter(stage == 'knockout') |> 
  filter(match_no > 88) |> 
  filter(match_no != 103) |> 
  mutate(cntry = cntrya)

knockout.b = wcsched |> 
  filter(stage == 'knockout') |> 
  filter(match_no > 88) |> 
  filter(match_no != 103) |> 
  mutate(cntry = cntryb)

knockout = knockout.a |> 
  bind_rows(knockout.b) |> 
  mutate(
    x = case_when(
      match_no <= 96 ~ 1,
      match_no <= 100 ~ 2,
      match_no <= 102 ~ 3,
      match_no == 104 ~ 4
    ),
    y = case_when(
      match_no <= 96 ~ (96 - match_no) * 2 + 2,
      match_no <= 100 ~ (100 - match_no) * 4 + 3,
      match_no <= 102 ~ (102 - match_no) * 8 + 5,
      match_no == 104 ~ 9
    )
  ) |> 
  select(x, y, cntry) |> 
  bind_rows(
    tibble(
      x = 5,
      y = 9,
      cntry = if_else(
        wcsched$goalsA[104] > wcsched$goalsB[104], 
        wcsched$cntrya[104],
        wcsched$cntryb[104]
      )
    )
  ) |> 
  arrange(x)


## play 3rd place consolation round
#cntrya = wcsched$cntrya[103]
#cntryb = wcsched$cntryb[103]
#game = game_model(cntrya, cntryb)
#wcsched$goalsA[103] = game$goalsA
#wcsched$goalsB[103] = game$goalsB
#wcsched$played[103] = TRUE
#if (game$goalsA > game$goalsB) {
 # print(paste0(cntrya, ' is the 3rd place winner!'))
#} else {
 # print(paste0(cntryb, ' is the 3rd place winner!'))
#}

Generate a chart in highcharter to visualize the outcomes of your predictions.

# plot the results of the knockout dataframe 
hchart(
  object = knockout,
  hcaes(
    x = x,
    y = y,
    group = cntry
  ),
  type = 'line'
) |> 
  hc_yAxis(
    min = 2,
    max = 16
  ) 

———————————

End of Project