High School Swimming State-Off Tournament California (1) vs. Pennsylvania (5)

Boys

Swimmer_Of_Meet[[1]] %>%
  slice_head(n = 5) %>%
  select(-Gender) %>%
  ungroup() %>%
  flextable_style()

Turns out yes, Matt Brownstead from Pennsylvania joins Lillie in the multiple winners club. As we discussed previously Matt broke the national high school record in the 50 free, so that guaranteed him one win. He also won the 100 free – the only boy here to win two events. We don’t even need to go to the All-American tie breaker, but it is worth noting that Ethan Hu outperformed Matt by that metric. Pennsylvania also managed three of the top five finishers here – very nice!

Results_Final %>%
  filter(Name == "Brownstead, Matt") %>%
  select(Place, Name, Team, Finals_Time, Event) %>%
  arrange(desc(Event)) %>%
  ungroup() %>%
  flextable_style()

Girls

Swimmer_Of_Meet[[2]] %>%
  slice_head(n = 5) %>%
  select(-Gender) %>%
  ungroup() %>%
  flextable() %>%
  bold(part = "header") %>%
  bg(bg = "#D3D3D3", part = "header") %>%
  autofit()

Zoie Hartman heads a California sweep of the girls swimmer of the meet top 5 while also winning her second swimmer of the meet crown.

Results_Final %>%
  filter(Name == "Hartman, Zoie") %>%
  select(Place, Name, Team, Finals_Time, Event) %>%
  arrange(desc(Event)) %>%
  ungroup() %>%
  flextable_style()

Performances By Grade

It might be interesting to see what fraction of athletes from each grade compete in various events. We might hypothesize that sprint events, like the 50 freestyle in particular, would have a higher percentage of older athletes, who benefit from extra years of growth, muscle development etc. SwimmeR can capture grade (or age) values, assuming they’re present in the original results. In this case we do have grade values, so let’s take a look.

Results_Age <- Results_Final %>%
  filter(is.na(Age) == FALSE,
         Age %!in% c("ST", "1")) %>% # remove nonsense values
  mutate(
    Age = case_when(
      # regularize encoding of grade values
      Age == "9" ~ "FR",
      Age == "10" ~ "SO",
      Age == "11" ~ "JR",
      Age == "12" ~ "SR",
      TRUE ~ Age
    )
  ) %>%
  mutate(Age = factor(Age, levels = c("FR", "SO", "JR", "SR"))) %>% # factor to order grade levels
  filter(str_detect(Event, "Relay") == FALSE) %>% # remove relays since they don't have grades
  mutate(Event = str_remove(Event, "Girls |Boys "),
         Event = factor(Event, levels = rev(unique(
           # order events by meet order, in this case with diving first
           str_remove(unique(Results$Event), "Girls |Boys ")
         ))))

Results_Age_Sum <- Results_Age %>%
  group_by(Event, Gender, Age) %>%
  summarise(Numb = n()) %>% # number of athletes for each event/gender/grade combination
  ungroup() %>%
  group_by(Event, Gender) %>%
  mutate(Percentage = Numb / sum(Numb)) # percentage of athletes in each grade for each event/gender combination

Results_Age_Sum %>%
  ggplot() +
  geom_col(aes(x = Event, y = Percentage, fill = Age)) +
  coord_flip() +
  facet_wrap(. ~ Gender) +
  theme_bw() +
  labs(y = "Frequency")

That’s a lovely plot (if I do say so myself). Interestingly, the 50 freestyle doesn’t appear to be the most senior heavy event for boys or girls. It would be nice though to have the data in a table form to aid in taking a closer look, so let’s work on that.

Tables

# Split results by gender, creating a list of two dataframes
Results_Age_Gender <- Results_Age_Sum %>%
  ungroup() %>% 
  group_by(Gender) %>% 
  group_split()

# function to apply to both dataframes that will produce columns with percentages for each grade and event
Age_Fill <- function(x) {
  x <- x %>%
    mutate(Percentage = round(Percentage, 2)) %>% 
    pivot_wider(names_from = Age, values_from = Percentage) %>%
    select(-Numb) %>%
    group_by(Event) %>%
    fill(everything(), .direction = "updown") %>%
    unique() %>% 
    mutate(Event = factor(Event, levels = unique(str_remove(unique(Results$Event), "Girls |Boys ")))) %>% 
    mutate_if(is.numeric, ~replace(., is.na(.), 0))
  
  return(x)
}

# map Age_Fill function over list of dataframes
Results_Age_Gender <- Results_Age_Gender %>% 
  map(Age_Fill)

# print boys table
Results_Age_Gender[[1]] %>% 
  arrange(Event) %>% 
  flextable_style()

# print girls table
Results_Age_Gender[[2]] %>% 
  arrange(Event) %>% 
  flextable_style()

There’s been a rumor going around that “seniors rule” and I gotta say, these results are pushing me towards believing it. On the boys side seniors have the highest percentage representation in every event (although admittedly tied with sophomores (?) in diving). On the girls side seniors again dominated, although sophomores had the most representatives in the 100 butterfly and the 100 breaststroke was a three way tie between sophomores (again with the sophomores…), juniors and seniors.

Let’s check this out a bit further though. We can use prop.test to check whether or not a given population proportion matches what we expect. For starters let’s define “ruling” as being over represented in an event or in the meet. More formally, we can set up a null hypothesis, where the null value for population proportion (the percentage of athletes in a given event who are seniors) is 0.25. We can then accept or reject that null hypothesis based on a significance level. We’ll choose the standard 0.5 as a significance level. Running prop.test will give us (among other things) a p value, which we can compare to our significance level. If the p value is less than our significance level of 0.5 we can reject the null hypothesis and conclude that their are more seniors than we would expect. If there are more seniors than than an underlying 1/4 probability would suggest we can confirm an instance of seniors “ruling”.

Prop_Test_Results <- Results_Age_Sum %>%
  group_by(Event, Gender) %>%
  mutate(Total_Athletes = sum(Numb)) %>%
  filter(Age == "SR") %>% # only testing seniors
  rowwise() %>%
  mutate(P_Val = prop.test(Numb, Total_Athletes, p = 0.25)$p.value[1]) # run prop test and extract p values

Prop_Test_Results_Gender <- Prop_Test_Results %>% 
  ungroup() %>% 
  group_by(Gender) %>% 
  group_split()

We can look at each event for boys and girls, and highlight (in red) p values that are less than our significance value of 0.5, meaning that for those events. We’ll collect a list of rows meeting each criteria (greater or less than our significance value) and then use flextable::bg to provide the appropriate background fill color.

Please note, the number of athletes in an event can be more than 16 in the event of a tie, or less than 16 for the purposes of this analysis if an athlete didn’t have their grade specified.

Boys Proportion Test

row_id_accept_boys <- # values where P_Val is greater or equal to than the significance value, should be green, fail to reject null hypothesis
  with(Prop_Test_Results_Gender[[1]], round(P_Val, 2) >= 0.5)
row_id_reject_boys <- # values where P_Val is less than the significance value, should be red, reject null hypothesis
  with(Prop_Test_Results_Gender[[1]], round(P_Val, 2) < 0.5)
col_id <- c("P_Val") # which column to change background color in

Prop_Test_Results_Gender[[1]] %>%
  arrange(rev(Event)) %>%
  flextable_style() %>%
  bg(i = row_id_accept_boys,
     j = col_id,
     bg = "green",
     part = "body") %>%
  bg(i = row_id_reject_boys,
     j = col_id,
     bg = "red",
     part = "body") %>%
  colformat_num(j = "P_Val",
                big.mark = ",",
                digits = 3) %>%
  autofit()

Girls Proportion Test

row_id_accept_girls <- # values where P_Val is greater or equal to than the significance value, should be green, fail to reject null
  with(Prop_Test_Results_Gender[[2]], round(P_Val, 2) >= 0.5)
row_id_reject_girls <- # values where P_Val is less than the significance value, should be red, reject null hypothesis
  with(Prop_Test_Results_Gender[[2]], round(P_Val, 2) < 0.5)
col_id <- c("P_Val") # which column to change background color in

Prop_Test_Results_Gender[[2]] %>%
  arrange(rev(Event)) %>%
  flextable_style() %>%
  bg(i = row_id_accept_girls,
     j = col_id,
     bg = "green",
     part = "body") %>%
  bg(i = row_id_reject_girls,
     j = col_id,
     bg = "red",
     part = "body") %>%
  colformat_num(j = "P_Val",
                big.mark = ",",
                digits = 3) %>%
  autofit()

Overall Proportion Test

In 15/18 (0.83%) of events the p-value is less than 0.5, meaning we can reject the null hypothesis for those events. There really are more seniors than a simple 1/4 probability would indicate, so in 83% of events seniors really do rule. We can also check for the whole meet:

Results_Age_Sum %>%
  ungroup() %>%
  mutate(Total_Athletes = sum(Numb)) %>%
  filter(Age == "SR") %>%
  mutate(Total_Seniors = sum(Numb)) %>%
  select(Total_Seniors, Total_Athletes) %>%
  unique() %>%
  mutate(P_Val = prop.test(Total_Seniors, Total_Athletes, p = 0.25)$p.value[1]) %>%
  flextable_style()

The p value (2.24e-22) is much less than 0.5 so we can reject the null hypothesis and conclude that at least as far as this meet is concerned seniors really do rule. Now if only there was some way to find out if O’Doyle also actually rules…