# Program to simulate 100,000 badminton matches in a format of three pairs for each team comparing playing each rubber in a fixed order against a flexible order.

# teams A B, players 1,2,3 represented as A1, B3 etc
# two options evaluated: option 1 is where players play in strict order; option 2 is where any available players play as soon as possible

# The program uses a dataframe called 'track' which has columns for recording the cumulative court time, the status of each player (resting or playing), which rubber is currenly playing on each of two courts, 
# and the time remaining to be played on each of those courts

# It also sets up a dataframe called rubbers which lists each of the 9 rubbers to be played and the pair from each team corresponding to that rubber.  
# Rows from this table are deleted as each rubber is put on court to be played.

# set number of iterations to simulate
Iterations <- 100000

# define results table
results <- data.frame(
  index = 0,
  cumulative_time = 0,
  wait_counter = 0,
  option_applied = 0
)

results_row <- 0


#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Define the function AVAILABLE
# function to check if players for the next rubber are available
# looks at next rubber in the list
# if no rubbers remaining, then returns complete flag
# tests to see if players available

# no rubbers remaining is where there is only one rubber not ticked off as having been played and that rubber is currently on court playing

# [option 1] returns 'next rubber to put on court' but if none available returns 'wait' and increments wait counter

# [option 2] returns 'next rubber to put on court' but if none available looks for the next available rubbber and checks to see if those players are available
# if exhausted all looped rubbers, returns 'wait'and increments 'wait counter'
# reports either 'wait' or 'next rubber to put on court'

# pass to the function the dataframes: rubbers, track, option selected, and current row
# returns nextgame = 0 if waiting, or nextgame = rubber to play next
# returns the complete flag (TRUE if all rubbers have been put on court, FALSE if there are still rubbers to put on court)

available <- function(ru,tr,op,cu){

  rubbers_remaining <-  ru[,"rubber"]
  pl <- c(tr[cu,"Playing1"],tr[cu,"Playing2"])

  if(nrow(ru) == 1){
    if(rubbers_remaining == pl[1] || rubbers_remaining == pl[2]){
      complete <- TRUE
      next_game <-0 
      return(c(next_game,wait.counter,complete))
      break
    }
  }
  

if(op == 1){
  game_not_playing <- rubbers_remaining[!rubbers_remaining %in% pl]
  if(complete == FALSE){
    game_not_playing <- game_not_playing[1]
  }
}

if(op == 2){
  game_not_playing <- rubbers_remaining[!rubbers_remaining %in% pl]
}

players_to_test <- subset(ru,rubber %in% game_not_playing,select = c(rubber,teamA, teamB), drop = FALSE) 
  for(row in game_not_playing){
    #retrieve teamA player for rubber == row
    teamA_player_to_test <- subset(players_to_test,rubber == row, select = teamA, drop = TRUE)
    #retrieve teamB player for rubber == row
    teamB_player_to_test <- subset(players_to_test,rubber == row, select = teamB, drop = TRUE)
    #look up whether team A player is rest or play
    teamA_available <- tr[cu,teamA_player_to_test+1]
    #look up whether team B player is rest or play
    teamB_available <- tr[cu,teamB_player_to_test+4]
    
    if(teamA_available == "rest"
       &&
       teamB_available == "rest"){
      next_game <- subset(players_to_test,rubber == row, select = rubber, drop = TRUE)
      break
    }else{next_game <- 0}
  }
if(next_game == 0){
  wait.counter <- wait.counter + 1   
}

return(c(next_game,wait.counter,complete))

# end function}
}

#-----------------------------------------------

# +++++++++++++++++++++++++++++++++++++++++++++
# Define function PUT_ON_COURT 
# function to put next game on court
# marks players now playing
# uses next_game 
# outputs track dataframe

put_on_court <- function(ru,tr,cu,ne){

# create new row in track dataframe (copy down from previous row)
cu <- cu + 1
tr[cu,] <- tr[cu - 1,]

# look up which players are to play from rubbers and next_game
next_rubber <- subset(ru,rubber == ne)

# mark those players as playing in track dataframe
# look up duration of next_game
# check which game currently has zero time
# put next duration into that game time
# put next game into corresponding playing slot
tr[cu,next_rubber[1,2]+1] <- "play"
tr[cu,next_rubber[1,3]+4] <- "play"
if(tr[cu,"Time1"] == 0){
  tr[cu,"Time1"] <- next_rubber[1,"duration"]
  tr[cu,"Playing1"] <- next_rubber[1,"rubber"]
}else if(tr[cu,"Time2"] == 0){
  tr[cu,"Time2"] <- next_rubber[1,"duration"]
  tr[cu,"Playing2"] <- next_rubber[1,"rubber"]
}else break #there's a problem

return(tr)

#end function}
}

#-------------------------------------

#+++++++++++++++++++++++++++++++++++++++
# Define function INCREMENT_PLAYING
# function to increment cumulative time to next game finish
# increment = min of rubbers being played
# creates new row in track table, and decrements time of rubbers currently being played - one becomes zero
# mark players where rubber time is zero as resting
# return track table - one of the rubber times will be zero

increment_playing <- function(ru,tr,cu){

increment <- min(tr[cu,"Time1"],tr[cu,"Time2"])

cu <- cu + 1
tr[cu,] <- tr[cu - 1,]

tr[cu,"cum.time"] <- tr[cu - 1,"cum.time"] + increment
tr[cu,"Time1"] <- tr[cu - 1,"Time1"] - increment
tr[cu,"Time2"] <- tr[cu - 1,"Time2"] - increment

if(tr[cu,"Time1"] == 0){
  game_off <- tr[cu,"Playing1"]
  playerA_off <- subset(ru,rubber == game_off,select = "teamA", drop = TRUE)
  playerB_off <- subset(ru,rubber == game_off,select = "teamB", drop = TRUE)
  
  tr[cu,playerA_off +1] <- "rest"
  tr[cu,playerB_off +4] <- "rest"
  
  tr[cu,"Playing1"] <- "0"
  
}else if(tr[cu,"Time2"] == 0){
  game_off <- tr[cu,"Playing2"]
  playerA_off <- subset(ru,rubber == game_off,select = "teamA", drop = TRUE)
  playerB_off <- subset(ru,rubber == game_off,select = "teamB", drop = TRUE)
  
  tr[cu,playerA_off +1] <- "rest"
  tr[cu,playerB_off +4] <- "rest"
  
  tr[cu,"Playing2"] <- "0"
  
}else {break} # something's gone wrong

return(tr)

#end function}
}

#-----------------------------------------

#++++++++++++++++++++++++++++++++++++++++++
# Define function INCREMENT_WAITING
# function to increment cumulative time when 'waiting'
# increment = max of two rubbers being played, because one of them is zero
# creates new row in track table
# calculate new cumulative time, and decrement times of rubbers currently being played, except the one already zero
# mark players where rubber time is zero as resting
# return track table - one of the rubber times will be zero 

increment_waiting <- function(ru,tr,cu){
  
  increment <- max(tr[cu,"Time1"],tr[cu,"Time2"])
  
  cu <- cu + 1
  tr[cu,] <- tr[cu - 1,]
  
  tr[cu,"cum.time"] <- tr[cu - 1,"cum.time"] + increment
  tr[cu,"Time1"] <- tr[cu - 1,"Time1"] - increment
  tr[cu,"Time2"] <- tr[cu - 1,"Time2"] - increment
  
  if(tr[cu,"Time1"] == 0){
    game_off <- tr[cu,"Playing1"]
    playerA_off <- subset(ru,rubber == game_off,select = "teamA",drop = TRUE)
    playerB_off <- subset(ru,rubber == game_off,select = "teamB",drop = TRUE)
    tr[cu,"Time2"] <- 0
    
    tr[cu,playerA_off +1] <- "rest"
    tr[cu,playerB_off +4] <- "rest"
    
    tr[cu,"Playing1"] <- "0"
    
  }else if(tr[cu,"Time2"] == 0){
    game_off <- tr[cu,"Playing2"]
    playerA_off <- subset(ru,rubber == game_off,select = "teamA", drop = TRUE)
    playerB_off <- subset(ru,rubber == game_off,select = "teamB", drop = TRUE)
    tr[cu,"Time1"] <- 0
    
    tr[cu,playerA_off +1] <- "rest"
    tr[cu,playerB_off +4] <- "rest"
    
    tr[cu,"Playing2"] <- "0"
    
  }else {break} # something's gone wrong
  
  return(tr)
  
  #end function}
}

#-------------------------------------------

# +++++++++++++++++++++++++++++++++++++++++++
# Define function TICK_OFF
# function to tick completed rubbers off
# checks to see if any rubber row has zero duration
# removes that row from rubber table

tick_off <- function(ru, tr, cu){

if(cu > 1){ #ignore first row in track as there is no preceding game in play
  if(tr[cu-1,"Playing1"] != 0 || tr[cu-1,"Playing2"] != 0 || tr[cu,"Playing1"] != 0 || tr[cu,"Playing2"] != 0){
    
  if(tr[cu-1,"Playing1"] != 0 && tr[cu,"Playing1"] == 0){
    rubber_complete <- tr[cu - 1,"Playing1"]
  }else if(tr[cu-1,"Playing2"] != 0 && tr[cu,"Playing2"] == 0){
    rubber_complete <- tr[cu - 1,"Playing2"]
    } else {break} # something's gone wrong
  } 
  else  
  {rubber_complete <- 0}
}
  
ru <- ru[ru$rubber != rubber_complete,]

return(ru)
# end of function}
}

#-----------------------------------


#\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
#MAIN PROGRAM FLOW

# LOOP ITERATIONS
for (i in 1:Iterations){
  
  # define probability distribution, normal distribution but with minimum duration for each game (to avoid negative durations arising)

  library(truncnorm)

  first_games = c(rtruncnorm(
    n = 9,
    mean = 25,
    sd = 7,
    a = 12,
    b = Inf
  ))
    
  third_game = c(rtruncnorm(
    n = 9,
    mean = 13,
    sd = 5,
    a = 5,
    b = Inf
  ))

  # assume 25% of rubbers go to three sets
  set_percentage <- 0.25
  setted <- c(sample(c(TRUE, FALSE), size = 9, prob = c(set_percentage, 1-set_percentage), replace = TRUE))
  duration <- first_games + setted * third_game
  

  # define rubbers to play
  rubbers <- data.frame(
    rubber = c(1:9),
    teamA = c(1,2,3,2,3,1,3,1,2),
    teamB = c(1,2,3,1,2,3,1,2,3),
    duration
  )

# make a copy of these rubber durations for use in option 2  
rubbers_copy <- rubbers

# LOOP OPTIONS
for (x in 1:2){
  option <- x
  
  #set rubber, or reset rubber for next option
  if(option == 1){
    rubbers <- rubbers
  }else{
    rubbers <- rubbers_copy
  }
  
  #set initial data for new match
  track <- data.frame(
    cum.time = 0,
    A1 = "rest",
    A2 = "rest",
    A3 = "rest",
    B1 = "rest",
    B2 = "rest",
    B3 = "rest",
    Playing1 = 0,
    Playing2 = 0,
    Time1 = 0,
    Time2 = 0
  )
  
  wait.counter <- 0
  
  complete <- FALSE
  
  next_game <- 0
  
  current <- 1


while(complete == 0){

  while(track[current,"Playing1"] == 0 || track[current,"Playing2"] == 0){
    
    #function AVAILABLE
    result <- available(rubbers,track,option,current)
    next_game <- result[1]
    wait.counter <- result[2]
    complete <- result[3]
    
    
    if(next_game == 0){
      break
    }
    
    if(complete == TRUE){
      break
    }
    
    #********************************
    
    #function PUT_ON_COURT
    track <- put_on_court(rubbers,track,current,next_game)
    current <- current + 1
    
    #end while 0 or 1 game is playing
  }
  
  if(next_game == 0){
    
    # function INCREMENT_WAITING
    track <- increment_waiting(rubbers,track,current)
    current <- current + 1
  }else{
    
    # increment track times when both games are playing
    # function INCREMENT_PLAYING
    track <- increment_playing(rubbers,track,current)
    current <- current + 1
    
    }
  
  # tick off completed rubbers
  # function TICK_OFF
  rubbers <- tick_off(rubbers, track, current)
  
  #end complete loop
}
  # capture example where option 1 and 2 are different because a game had to wait
  if(wait.counter >0){
  if(option == 1){
    example_option1 <- track
  }else{
    example_option2 <- track
  }
  }
  
  # write to results table
  results_row <- results_row + 1
  results[results_row,] <- c(results_row,track[current,"cum.time"],wait.counter,option)
  
# end for loop for options
}
# end loop for iterations
}


#rearrange results table to show differences

library(dplyr)
library(tidyr)

results_with_difference <- results %>%
  select(option_applied,cumulative_time) %>%
  mutate(row_id = ceiling(row_number() / 2)) %>%   # groups each pair
  pivot_wider(
    names_from = option_applied,
    values_from = cumulative_time,
    names_prefix = "time"
  )  %>%
  mutate(difference = time2 - time1)

# plot various histograms to illustrate results

library(ggplot2)

ggplot(results_with_difference, aes(x = difference)) +
  geom_histogram(
    bins = 50,
    fill = "steelblue",
    color = "white"
  ) +
  coord_cartesian(ylim = c(0, 4000))
    labs(
    title = "Difference in overall match times (fixed order - flexible order)",
    x = "difference (minutes)",
    y = "Count"
  )

    ggplot(results_with_difference, aes(x = difference)) +
      geom_histogram(
        bins = 50,
        fill = "steelblue",
        color = "white"
      ) +
#      coord_cartesian(ylim = c(0, 100))
    labs(
      title = "Difference in overall match times (fixed order - flexible order)",
      x = "difference (minutes)",
      y = "Count"
    )
    
    ggplot(results_with_difference, aes(x = difference)) +
      geom_histogram(
        bins = 100,
        fill = "steelblue",
        color = "white"
      ) +
      coord_cartesian(ylim = c(0, 4000))
    labs(
      title = "Difference in overall match times (fixed order - flexible order)",
      x = "difference (minutes)",
      y = "Count"
    )
    
    ggplot(results_with_difference, aes(x = difference)) +
      geom_histogram(
        bins = 100,
        fill = "steelblue",
        color = "white"
      ) +
      #      coord_cartesian(ylim = c(0, 100))
      labs(
        title = "Difference in overall match times (fixed order - flexible order)",
        x = "difference (minutes)",
        y = "Count"
      )
    
 
results_with_difference %>%
  pivot_longer(
    cols = c(time1, time2),
    names_to = "time_type",
    values_to = "time_value"
  ) %>%
  ggplot(aes(x = time_value, fill = time_type)) +
  geom_histogram(
    alpha = 0.5,
    position = "identity",
    bins = 100
  ) +
  scale_fill_manual(
    values = c("time1" = "steelblue", "time2" = "tomato")
  ) +
  labs(
    title = "Overall match duration - flexible order in red and fixed order in blue",
    x = "Time",
    y = "Count",
    fill = "Time Type"
  ) +
  theme_minimal()

# summarise results tables to show number of matches in each cateory and average times etc

results %>%
  group_by(option_applied) %>%
  summarise(
    count = n(),
    avg_cumulative_time = mean(cumulative_time, na.rm = TRUE),
    avg_wait_counter = mean(wait_counter, na.rm = TRUE),
    .groups = "drop"
  )

results_with_difference %>%
  summarise(
    negative_count = sum(difference < 0),
    positive_count = sum(difference > 0),
    total_count    = n()
  )    


# export results table to a spreadsheet file for any further analysis required    
        
write.csv(results, "results100000-30Apr.csv", row.names = FALSE)


# END OF MAIN PROGRAM
#\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\