Solving analytically

The function we want is binomial(n::Integer, k::Integer), which returns the binomial coefficient – the number of ways to choose k out of n items.

Let’s look at some examples. First, if we try 4C1 (4 choose 1), we expect to just get 4 – there are 4 different ways to choose 1 item from a group of 4 items.

binomial(4, 1)

4

Now imagine we choose 2 different items from a group of 4. We expect to get 6 (assuming we don’t care about order, i.e. that 1,2 is the same as 2,1):

1. 1, 2
2. 1, 3
3. 1, 4
4. 2, 3
5. 2, 4
6. 3, 4

binomial(4, 2)

6

So let’s solve the actual problem now. A full house is 5 cards comprising 3-of-a-kind and a pair. There are 52 cards in a deck – 4 suits comprising 13 unique values (2, 3, …, Ace) each.

The approach here is to calculate the number of ways to get a full house and divide that by the number of ways to draw 5 cards from a deck. We can start with the number of ways to draw 5 cards from a deck (the denominator) first, since it’s the most straightforward:

denom = binomial(52, 5)

2598960

Then let’s calculate the number of ways we can get three of a kind. There are 13 different card values and 4 different suits. We need to choose 1 value with 3 different suits:

• binomial(13, 1) gives us the number of ways to choose 1 value from 13 options (which is just 13)
• binomial(4, 3) gives us the number of ways to choose 3 different suits from 4 possible options

And then since this is probability, we multiply everything together:

three_kind = binomial(13, 1) * binomial(4, 3)

52

Then we do the same thing for drawing a pair. There are now 12 different card values (we can’t get a pair of the value that we already drew three-of-a-kind for), and we need to choose 1 value with 2 different suits:

two_kind = binomial(12, 1) * binomial(4, 2)

72

And from here, we can estimate the probability of a full house by multiplying and dividing:

(three_kind * two_kind) / denom

0.0014405762304921968

So there’s a 0.144% chance of drawing a full house from a typical 52-card deck.

Solving with simulation

We could also take a simulation-approach to solving this. First, let’s create a deck of cards.

using Random
using StatsBase

Random.seed!(0408)

deck = collect(repeat(1:13, 4))

52-element Vector{Int64}:
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
  ⋮
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13

Then we’ll create a few functions to help us with the simulation:

1. make_hands() will draw n 5-card hands from the deck;
2. is_full_house() will check whether any given hand is a full house;
3. count_full_house() takes a vector of hands and counts the number of them that have a full house

function make_hands(deck::AbstractVector{<:Integer}, n::Int64)
    v = Vector{Vector{Int64}}(undef, n)
    for i in 1:n
        v[i] = sample(deck, 5; replace=false)
    end
    return v
end

function is_full_house(hand::AbstractVector{<:Integer})
    return extrema(values(countmap(hand))) == (2, 3)
end

function count_full_house(hands::Vector{Vector{Int64}})
    s = 0
    for i in eachindex(hands)
        if is_full_house(hands[i])
            s += 1
        end
    end
    return s
end

count_full_house (generic function with 1 method)

Then from here we just run our simulation.

n = 1_000_000

hands = make_hands(deck, n);

count_full_house(hands) / n

0.001446

And we see that we get roughly the same answer as we did previously.

Top Finishers

First, let’s look at the top finishers for the men and women. We’ll start with the women:

women_lb |>
  slice_min(score, n = 10) |>
  select(-div) |> 
  gt() |> 
  tab_header(
    title = "Top 10 Women",
    subtitle = "2024 CF Open"
  )

One thing to keep in mind here is that lower scores are better in the Open, since your score is the sum of your rankings for each workout. Since there are 3 workouts, the best score possible would be 3.

On the women’s side, the most recognizable names are Loewen and Saunders, and a lot of the bigger names (Tia, Laura, Emma Lawson) are absent. This shouldn’t be concerning, but it’s potentially interesting.

And moving to the men’s side:

men_lb |>
  slice_min(score, n = 10) |>
  select(-div) |> 
  gt() |> 
  tab_header(
    title = "Top 10 Men",
    subtitle = "2024 CF Open"
  )

The story is a little different here – lots of noticeable names that have historically done well at the games. Vellner, Adler, Ohlsen, Koski, Panchik, and Crouch.

Men and Women Scores by Rank

Another way we might look at the data is to compare the scores of the men to those of the women. This can give us a sense of the “depth” or level of competition across the field.

For instance, we can plot each athlete’s rank (overall placement) against the total score for men and women:

ggplot(all_lb, aes(y = rank, x = score, color = div)) +
  geom_point(alpha = .5) +
  scale_y_reverse() +
  labs(
    x = "Score",
    y = "Rank (Overall Place)",
    title = "Score by Overall Rank",
    subtitle = "Top 100 Men and Women"
  ) +
  scale_color_discrete(name = "Division")

In cases where, for any given rank, the women’s score is less than the men’s score, we can assume (sort of) the women outperformed the men. For example, the 100th place woman had considerably fewer points than the 100th place man. This might tell us that, relative to the rest of the field, the 100th place woman is “better” than the 100th place man. Of course it’s not that straightforward – we could just as reasonably conclude that the men’s field is deeper than the women’s field – but it’s a fun thought exercise.

What is interesting, though, is that the score gap between the 1st and 100th woman is much smaller than the gap between the 1st and 100th point man. And that we see separation between the men and women around ~50th place.

Variance in Workouts – Women

Another interesting datapoint we can look at is the spread between an athlete’s best finish and their worst finish. Since the open is only 3 events, this rank will explain a lot of their overall variance (at the Games, where there are more events, the best-to-worst spread is kinda less important). Obviously, all of these athletes finished top 100 overall, so nobody completely bombed anything.

Let’s start with the women:

women_best_worst <- women_workout_res |>
  group_by(athlete) |>
  summarize(
    worst = max(workout_place),
    best = min(workout_place),
    spread = worst - best
  ) |>
  left_join(women_lb, by = "athlete")

women_best_worst |>
  ggplot(aes(y = rank, x = best)) +
  geom_segment(aes(xend = worst, yend = rank), color = "steelblue") +
  scale_y_reverse() +
  labs(
    x = "Finish Position (Spread)",
    y = "Rank (Overall Place)",
    title = "Best and Worst Finishes by Overall Rank",
    subtitle = "Women"
  )

Ok, so the way you interpret this plot:

• The athlete’s overall rank is on the y-axis (the vertical axis)
• The blue bar represents the spread of their performance. The left end is their best performance, the right end is their worst performance, and the width is the gap between best and worst

Keep in mind that having a small spread between your best and worst finish isn’t necessarily a good thing if your best finish is relatively high.

All in all, though, we tend to see bigger spreads the further down we get in the rankings, which kinda makes sense because a single bad event can crush your overall score with just 3 total events.

From here, we might want to look at which women had the largest best-to-worst even spreads:

women_best_worst |>
  slice_max(spread, n = 10) |>
  select(-div) |> 
  gt() |> 
  tab_header(
    title = "Largest Differences between Best and Worst Event",
    subtitle = "Women, CF Open 2024"
  )

We see Laura on here, and I think she did (relatively) poorly on the first event compared to her other 2 event finishes, hence the large spread:

women_workout_res |> 
  filter(athlete == "Laura Horvath") |> 
  select(-div) |> 
  gt() |> 
  tab_header(
    title = "Laura Horvath Open Finishes"
  )

Right, so she finished 395th in event 1, but then 6th and 7th.

Variance in Workouts – Men

And we can do the same thing for the men:

men_best_worst <- men_workout_res |>
  group_by(athlete) |>
  summarize(
    worst = max(workout_place),
    best = min(workout_place),
    spread = worst - best
  ) |>
  left_join(men_lb, by = "athlete")

men_best_worst |>
  ggplot(aes(y = rank, x = best)) +
  geom_segment(aes(xend = worst, yend = rank), color = "steelblue") +
  scale_y_reverse() +
  labs(
    x = "Finish Position (Spread)",
    y = "Rank (Overall Place)",
    title = "Best and Worst Finishes by Overall Rank",
    subtitle = "Men"
  )

So the point about having a small spread not necessarily being ideal is illustrated here – we see whoever finished in 98th has a teeny spread, but all of his finishes were ~250ish.

men_best_worst |>
  slice_max(spread, n = 10) |>
  gt() |> 
  tab_header(
    title = "Largest Differences between Best and Worst Event",
    subtitle = "Men, CF Open 2024"
  )

These spreads are wider than the ones we saw for the women, which again maybe suggests that the men’s field is more variable than the women’s field?

24.1

Now let’s look briefly at individual workout results. Obviously, we’ll start with 24.1. You can see the workout here.

wk1 <- all_workouts |>
  filter(workout_num == 1) |>
  mutate(time_score = period_to_seconds(ms(score)))

wk1 |>
  ggplot(aes(x = time_score, y = workout_place, color = div)) +
  geom_point(alpha = .5) +
  scale_y_reverse() +
  scale_color_discrete(name = "Division") +
  labs(
    x = "Time (Seconds)",
    y = "Workout Place",
    title = "Time to Complete 24.1 by Workout Place",
    subtitle = "Top 100 Overall Men and Women"
  )

I think this is a pretty cool plot in that it shows the “shape” of the performances by these athletes. The waterfall shape suggests that there’s more separation (horizontal space) amongst the very top finishers, but the increasingly steep slope toward the right end of the graph suggests there’s less time between worse-finishing places. Which makes sense.

See that one pink dot all the way to the left – who crushed this workout that hard?

wk1 |>
  slice_min(time_score, n = 1) |> 
  pull(athlete)

[1] "Colten Mertens"

24.2

We’ll do the same thing for 24.2. You can see the workout description here

wk2 <- all_workouts |>
  filter(workout_num == 2) |>
  mutate(n_reps = parse_number(score))

wk2 |>
  ggplot(aes(x = n_reps, y = workout_place, color = div)) +
  geom_point(alpha = .5) +
  scale_y_reverse() +
  scale_color_discrete(name = "Division") +
  labs(
    x = "Reps",
    y = "Workout Place",
    title = "Reps Completed in 24.2 by Workout Place",
    subtitle = "Top 100 Overall Men and Women"
  )

We see basically the inverse pattern here – the curve flattens toward the right (since more reps is better in this case). What’s interesting is that we see this flattening occur at around the top ~100 finishers of the workout for women, but at maybe the top ~30 for men. This might have something to do with the scoring (1 double under obviously isn’t equivalent to 1 deadlift), or it might be an indication that the top 100 women were considerably better than the next others in this workout. Again, it’s kinda hard to tell.

24.3

And we’ll wrap up by looking at the same type of plot for 24.3. You can see the workout description here

wk3 <- all_workouts |>
  filter(workout_num == 3) |>
  mutate(time_score = period_to_seconds(ms(score)))

wk3 |>
  ggplot(aes(x = time_score, y = workout_place, color = div)) +
  geom_point(alpha = .5) +
  scale_y_reverse() +
  scale_color_discrete(name = "Division") +
  labs(
    x = "Time (Seconds)",
    y = "Workout Place",
    title = "Time to Complete 24.3 by Workout Place",
    subtitle = "Top 100 Overall Men and Women"
  )

Again we see basically the same pattern we saw in 24.1

I’ll probably do something like this again for the Quarterfinals and Semis, so if there’s anything else people would like to see, let me know.

Overall Points

This isn’t the most exciting graph, but it makes sense to start by looking at the overall points. If you followed the Games coverage over the weekend, though, you probably know all of this already.

lb_df |>
    filter(rank <= 20, rank > 0) |>
    ggplot(aes(x = score, y = fct_reorder(athlete, score), fill = division)) +
    geom_col() +
    geom_text(aes(label = score, x = score - 10), hjust = 1, color = "white") +
    facet_wrap(vars(division), scales = "free_y") +
    labs(
        x = "Total Points",
        y = NULL,
        title = "Total Points by Athlete, 2023 CFG",
        subtitle = "Only top 20 included"
    ) +
    theme(
        legend.position = "none"
    )

One thing that sticks out to me when looking at this is how close places 4-6 were to one another on both the men and the women’s sides. Only 17 points separated Gabi Migala from Alexis Raptis, and only 10 points separated Brent Fikowski from Jonne Koski.

Number of Top 3 Finishes

Next, let’s take a look at the number of top 3 finishes by all of our athletes. To preserve some space, I’m only going to include those athletes with multiple top 3 finishes.

workout_df |>
    filter(workout_place <= 3) |>
    count(division, athlete) |>
    filter(n > 1) |>
    ggplot(aes(x = n, y = fct_reorder(athlete, n), fill = division)) +
    geom_col() +
    geom_text(aes(label = n, x = n - .1), hjust = 1, color = "white") +
    labs(
        y = NULL,
        x = "Number of Top 3 Finishes",
        title = "Number of Top 3 Finishes by Athlete",
        subtitle = "Only athletes with multiple top 3 finishes shown"
    ) +
    theme(
        legend.position = "none"
    )

So there are a few things that stand out to me here:

• Laura absolutely crushed it. She had 6 total top 3 finishes (5 of which were wins), which was 2 more than the next-closest person.
• Emma Lawson, even though she ended up in 2nd and led for a decent amount of the competition, only had 2 top 3 finishes.
• Justin Medeiros still had 3 top 3 finishes, despite placing 13th overall, which just goes to show how damaging a few very bad finishes can be.

Event Placement Variability

Medeiros’s performance provides a nice segue into the next thing we’ll look at – variability. That is, to what extent were athletes consistent in their finishes. The plot below shows athletes average event placement as a point, and it shows the standard error of this estimate (the variability) as bars extending around the point. The wider the bars, the more variable (less consistent) the athlete was in their finishes.

top_20_athletes <- lb_df |>
    filter(rank <= 20, rank > 0) |>
    pull(athlete)

workout_df |>
    filter(athlete %in% top_20_athletes) |>
    group_by(division, athlete) |>
    summarize(
        std_err = sd(workout_place) / sqrt(12),
        avg = mean(workout_place)
    ) |>
    ungroup() |>
    left_join(select(lb_df, athlete, rank)) |>
    ggplot(aes(x = avg, y = fct_reorder(athlete, -rank), color = division)) +
    geom_point() +
    geom_errorbarh(aes(xmin = avg - std_err, xmax = avg + std_err), height = 0) +
    facet_wrap(vars(division), scales = "free_y") +
    labs(
        x = "Avg Event Placement",
        y = NULL,
        title = "Average Event Placement and Variability",
        subtitle = "Top 20 Athletes Only"
    ) +
    scale_color_hp_d("HermioneGranger") +
    theme(
        panel.grid.major.y = element_blank(),
        legend.position = "none"
    )

One thing to note here is that the y-axes are sorted by final leaderboard position, whereas the position of the point on the x-axis for each athlete is the average event finish. If all events are weighted equally, these would points cascade downward and outward – the average event placement would increase as you go down the leaderboard. But since the point gaps between places increase as athletes are cut, it’s possible for athletes to have higher average event finishes and yet still finish better on the leaderboard. This is the case for athletes who do better on Saturday and Sunday than they did on Thursday and Friday. We can see this with Gabi Migala and Pat Vellner. Inversely, athletes who do worse on Saturday and Sunday will have lower average event finishes relative to their overall place. We can see this with Chandler Smith and Roman Khrennikov (who didn’t do well on Sunday for obvious reasons).

Beyond that, though, it’s interesting to look at the width of some of these error bars. On the women’s side, we can see how narrow Emma Lawson’s bars were, showing that she consistently finished around 7th place in events. Likewise for Chandler Smith on the men’s side – he seems much more consistent than many of the other top 20, and I’m not sure anyone would say consistency was Chandler’s vibe before this year. It’s also probably worth mentioning that Roman’s performance would (probably) have been much more consistent had he not broken his foot.

Inversely, we can see that some athletes were very inconsistent. For instance, Justin Medeiros, Pat Vellner, and Sam Kwant on the men’s side, and Katrin, Emma Cary, and Olivia Kerstetter on the women’s side. This all makes sense – Justin, Pat, and Sam all had a few terribly events, but as we saw earlier they were also top 3 in multiple events. Likewise for Katrin, Olivia, and Emma.

Top 10 Athlete Finishes by Event

The error bars in the above plot tell us something about variability, but we might want to look at the actual event finishes to unpack this variability a bit more. The plot below is a jitter plot, which is basically just a scatter plot with the points jittered a little so they don’t overlap. Since this might be too busy otherwise, I’m going to drop down to just the top 10 athletes in each division here.

top_10_athletes <- lb_df |>
    filter(rank <= 10, rank > 0) |>
    pull(athlete)

workout_df |>
    filter(athlete %in% top_10_athletes) |>
    left_join(select(lb_df, athlete, rank)) |>
    ggplot(aes(x = workout_place, y = fct_reorder(athlete, -rank), color = rank %% 2 == 0)) +
    geom_jitter(width = 0, height = .15, alpha = .6) +
    facet_wrap(vars(division), scales = "free_y") +
    labs(
        x = "Workout Place",
        y = NULL,
        title = "Variability in Workout Placement",
        subtitle = "Top 10 athletes per division"
    ) +
    scale_color_hp_d("HermioneGranger") +
    theme(
        panel.grid.major.y = element_blank(),
        legend.position = "none"
    )

Right, so here we can get a better sense of athletes by performances. We can see, for example, that both Katrin and Emma Cary mostly did well, but they had a few events where they bombed. Same thing with Vellner (and probably Medeiros too, if he were displayed here). Jelle Hoste’s finishes appear much more smoothly spread – it’s not like he vacillated between dominating events and bombing them. He won 1 (the 5k), finished a few others in the top 10, finished a few others in the top 20, and then had a handful of worse finishes. We see a similar pattern for Fikowski, Paige Powers, Gabi Migala, and Danielle Brandon.

Placement for Top 5 Athletes Across the Competition

As a penultimate glance at the data, let’s track the overall placement of the eventual top 5 finishers across the competition. I’m going to color the eventual winners in gold and the others in gray, which will make the winners’ trajectories easier to follow and make the graph less busy (although it does make it slightly harder to follow the non-winners’ trajectories).

top_5_athletes <- lb_df |>
    filter(rank <= 5, rank > 0) |>
    pull(athlete)

athlete_cumul <- workout_df |>
  filter(athlete != "Jason Smith")  |> 
  group_by(athlete) |> 
  mutate(
    cum_pts = cumsum(points)
  ) |> 
  ungroup() |> 
  group_by(workout_num, division) |> 
  arrange(desc(cum_pts), .by_group = TRUE) |> 
  mutate(cum_rank = row_number()) 

top_5_cumul <- athlete_cumul |> 
  ungroup() |> 
  filter(athlete %in% top_5_athletes) |> 
  left_join(select(lb_df, athlete, final_rank = rank))

top_5_cumul |> 
    ggplot(aes(x = workout_num, y = cum_rank, color = final_rank == 1, group = athlete)) +
    geom_line() +
    geom_point(aes(size = final_rank == 1)) +
    geom_text(
        aes(
            label = str_replace_all(athlete, "^(.*) (.*)$", "\\2"),
            y = final_rank,
            x = 12.5
        ),
        hjust = 0
    ) +
    facet_wrap(vars(division)) +
    scale_x_continuous(limits = c(0, 16), breaks = seq(2, 12, by = 2)) +
    labs(
        x = "Workout Number",
        y = "Place after Workout",
        title = "Placement of the Top 5 Athletes over the Competition"
    ) +
    scale_color_manual(values = c("grey50", "#e59950ff")) +
    scale_size_manual(values = c(1, 3)) +
    scale_y_reverse() +
    theme(
        legend.position = "none",
        panel.grid.minor.x = element_blank()
    )

The first thing that stands out to me is what we all know – Roman dominated most of the men’s competition, and it was a real bummer that he broke his foot. Another thing that stands out to me is that Dallin Pepper made a huge late charge to go from ~14th after event 7 up to 5th at the end of Sunday, which is a lot of ground to make up in 5 events. We can also see Vellner doing Vellner things – pulling himself out of an early hole to eventually take 2nd.

On the women’s side, we can see that Emma Lawson was basically always at or near the top. Laura had a bit of a roller-coaster ride to get back to the top spot, but she ended up there when it mattered. The other thing on the women’s side that jumps out is that Gabi Migala had sort of a similar trajectory as Dallin Pepper – she dug herself into a bit of a hole over the first half of the competition that she climbed out of by the end.

Exploring Laura’s Event Wins

And let’s end with a little bit about Laura Horvath. I’ve been a huge Laura fan since 2018, and I’m so happy for her that she finally got a W this year. I hope this is just the first of many for her, and I truly think she’s a great ambassador for the sport.

All of that said, one of the things you couldn’t help but notice when watching her was how dominant her event wins were. The table below shows her score for each of her event wins as well as the score of the woman who finished in 2nd.

lh_wins <- c(2, 5, 9:11)

lh_win_workouts <- workout_df |> 
  filter(
    workout_num %in% lh_wins,
    workout_place <= 2,
    division == "Women"
    ) 

comparison_tbl <- lh_win_workouts |> 
  select(-c("workout_place", "points", "division"))

lh_tbl <- comparison_tbl |> 
  filter(athlete == "Laura Horvath") |> 
  rename(lh_score = score)

other_tbl <- comparison_tbl |> 
  filter(athlete != "Laura Horvath") |> 
  rename(other_athlete = athlete, other_score = score)

comp_tbl <- lh_tbl |> 
  left_join(other_tbl, by = "workout_num") |> 
  select(-athlete)

comp_tbl |> 
  gt() |> 
  cols_label(
    workout_num = "Workout #",
    lh_score = "Laura Score",
    other_athlete = "2nd Place Finisher",
    other_score = "2nd Place Score"
  ) |> 
  tab_style(
    style = list(
        cell_text(weight = "bold")
    ),
    locations = cells_column_labels()
  ) |> 
  tab_header(
    title = "Margin of Victory for Laura's Workout Wins"
  )

The first 2 wins are absolutely nutzo. Winning by nearly a minute in a ~14 minute event is crazy enough, but then winning by over a minute in a 5 minute event is bonkers. Her next 3 wins don’t quite reach those same levels of insanity, but none of them are particularly close. In a lifting even where 1-5 lbs separated many athletes, Laura won by 23 lbs. And in events 10 and 11, she still won by 18 and 12 seconds, which is a lot (go ahead and count to 12 slowly and see how long it feels).

All in all, I’m pumped for Laura, pumped for Adler (who I didn’t write much about here, but he does seem like a good dude), and pumped for another great Games weekend.

I may dig into some other aspects of this data more in the future – who knows – but for now this is it.

Load Packages and Generate Data

For this, we just need the Random package to set a seed and sample our strings as well as the BenchmarkTools package to benchmark the function performance.

using Random
using BenchmarkTools

Random.seed!(0408)

#function to generate some strings
function make_strings(n::Int)
    v = Vector{String}(undef, n)

    letters = "abcde"
    numbers = "12345"

    for i ∈ eachindex(v)
        x = randstring(letters, 4)
        y = randstring(numbers, 3)
        v[i] = x * y
    end
    return v
end

make_strings (generic function with 1 method)

This will make a vector of length n where each element is a 7-character string. In each of these strings, the first 4 characters will be sampled (with replacement) from "abcde", and the last 3 characters will be sampled (with replacement) from "12345".

Next we’ll set n to 100,000 and generate our strings. I’ll also make an arbitrary reference string to compare the candidate strings against. Note that we’re not benchmarking any of this stuff – just the comparisions that will come later.

n = 100_000

#returns a vector of 100k strings
x = make_strings(n);

ref = "aade124" #making a reference string to compare against

"aade124"

Write Comparison Functions

So now we want to compare each element of x to ref. The goal is count how many characters match until we hit the first characters that don’t match. For example, if we’re comparing "abcd123" to "abde123", the result would be 2, since the first two characters (ab vs ab) match in each, but the third characters (c vs d) don’t.

My first step here is to write a function that compares 1 string to 1 string – that is’, I’m not worrying about the fact that I want to do this for all the of the elements in x yet – I just want to do it for 1 element.

function compare_strings(x::String, y::String)
    s = 0
    for i ∈ eachindex(x)
        x[i] != y[i] ? break : s += 1
    end
    return s
end

compare_strings (generic function with 1 method)

This will: 1. Create a counter, s (for sum) and set it equal to 0; 2. For each index i (position) in x – recall that x and y will have the same length – compare x[i] and y[i]; 3. If they’re not equal, break the loop and return s; 4. If they are equal, increment s by one and keep going

We can check that this works by using the previous example strings:

compare_strings("abcd123", "abde123")

2

Now we want to write a version of this function that accepts a vector of strings and compares each element of that vector to the reference string. The cool thing about Julia is that its multiple dispatch feature allows us to define another compare_strings() function that accepts different types of arguments.

So we can write the following and it’s perfectly acceptable and, honestly, way better IMO than how you might have to handle this in R or python

function compare_strings(x::Vector{String}, y::String)
    return [compare_strings(i, y) for i in x]
end

compare_strings (generic function with 2 methods)

Notice that the new function has the same name (compare_strings()) but its x argument is a vector of strings rather than a single string. Then, inside the function, we just call our other method that requires x to be a single string. We do these calls inside of a list comprehension to iterate over all of the elements in x.

Benchmark

Now we just run the benchmark to see how our code does

@benchmark compare_strings(x, ref)

BenchmarkTools.Trial: 5038 samples with 1 evaluation.
 Range (min … max):  880.500 μs …   2.713 ms  ┊ GC (min … max): 0.00% … 26.16%
 Time  (median):     951.200 μs               ┊ GC (median):    0.00%
 Time  (mean ± σ):   984.414 μs ± 115.531 μs  ┊ GC (mean ± σ):  0.87% ±  4.08%
    ▁▆██▄▂                                                       
  ▂▅██████▇▇▆▅▅▄▃▃▃▃▃▃▃▃▃▃▂▂▂▂▂▂▂▂▂▂▂▂▂▁▂▁▁▂▂▂▁▁▂▂▂▂▁▂▂▂▂▂▂▂▂▂▂ ▃
  880 μs           Histogram: frequency by time         1.58 ms <
 Memory estimate: 781.30 KiB, allocs estimate: 2.

Obviously this isn’t an apples-to-apples comparison with the code Josiah wrote – we have different machines, different input vectors, he was calling both Rust and C++ from R, etc. But the point remains that Julia is also fast…just in case people hadn’t heard :)

Setup and Examine Data

First, let’s load the packages we’ll use and read the data in:

using CSV #for reading CSVs
using DataFrames #dataframe utilities
using Chain #chain macro, similar to R's pipe
using Languages #for stopwords
using CairoMakie #plotting
using Statistics #for median

st_things_dialogue = CSV.read(download("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2022/2022-10-18/stranger_things_all_dialogue.csv"), DataFrame);

And then we can look at the size of the dataframe:

size(st_things_dialogue)

(32519, 8)

As well as see the first few rows:

first(st_things_dialogue, 3)

So we can see that dialogue might be missing if the line is just stage directions. For our purposes here, let’s just use the lines with dialogue. To do this, we can use the dropmissing() function and then pass in the Dataframe and the column we want to only keep complete cases of, which is :dialogue in this case. Note that Julia uses : to denote symbols.

dialogue_complete = dropmissing(st_things_dialogue, :dialogue)

Reshape Data

Cool, so this will get us just rows that actually have dialogue. But what we can see is that each row is a line of dialogue, whereas we actually want to tokenize this so that each row is a word.

To do this, we can use the split function, which lets us split a string at whatever delimiter we provide. In this case, that’s a space. For example:

split("a man a plan a canal panama", " ")

7-element Vector{SubString{String}}:
 "a"
 "man"
 "a"
 "plan"
 "a"
 "canal"
 "panama"

Or, using our actual data:

split(dialogue_complete.dialogue[1], " ")

7-element Vector{SubString{String}}:
 "Something"
 "is"
 "coming."
 "Something"
 "hungry"
 "for"
 "blood."

It’s worth noting that, by default, split() will split on spaces, so we can just call the default function without the final argument as well:

split(dialogue_complete.dialogue[1])

7-element Vector{SubString{String}}:
 "Something"
 "is"
 "coming."
 "Something"
 "hungry"
 "for"
 "blood."

So this gives us the first step of what we want to do in tokenizing the dialogue.

Let’s start putting this into a chain, which is similar to R’s pipe concept. And apparently there are several different chains/pipes in Julia, but the Chain.jl package seems reasonable to me so let’s just use that one.

We can begin a chain operation with the @chain macro, then pass the dataframe name and a begin keyword. We then do all of our operations, then pass the end keyword. Like tidyverse functions in R, most of Julia’s DataFrame functions expect a dataframe as the first argument, which makes them work well with chains.

df_split = @chain dialogue_complete begin
    select(
        :season,
        :episode,
        :line,
        :dialogue => ByRow(split) => :dialogue_split
    )
    end

Technically we don’t need to chain anything above since we’re just doing one operation (select()) right now, but we’ll add more soon.

One thing you might notice in the final line within select() is Julia’s notation for “doing things” is input_col => function => output_col. In the case above, we’re supplying an anonymous function (which is that x -> fun(x, …)) syntax, and wrapping that in a special ByRow() function that facilitates broadcasting in dataframe operations.

All that said, the above doesn’t quite give us what we want if we look at the first two rows of output:

first(df_split, 2)

Our dialogue_split column is a vector of vectors. To get around this, we want to flatten the column so that each row contains a single word. The nice thing about our chain operation above is that we can just plunk the flatten() function right on the end to do this:

df_split = @chain dialogue_complete begin
    select(
        :season,
        :episode,
        :line,
        :dialogue => ByRow(split) => :dialogue_split
    )
    flatten(:dialogue_split)
end

Better! Now let’s check out the first 10 elements of our dialogue split column:

show(first(df_split.:dialogue_split, 10))

SubString{String}["Something", "is", "coming.", "Something", "hungry", "for", "blood.", "A", "shadow", "grows"]

Clean Text

So, it’s not ideal that we have punctuation in here. We don’t want, for instance “blood” to be considered a different word than “blood.” when we count words later. Same deal for uppercase and lowercase letters – we want “something” to be the same as “Something”. So we need to strip punctuation and lowercase everything.

First, we can write a small little function to strip punctuation.

function strip_punc(x)
    strip(x, [',', ';', '.', '?', '!'])
end

strip_punc (generic function with 1 method)

And Julia already has a lowercase() function built in. Now, let’s jam these on the end of the chain we already have:

df_split = @chain dialogue_complete begin
    select(
        :season,
        :episode,
        :line,
        :dialogue => ByRow(split) => :dialogue_split
    )
    flatten(:dialogue_split)
    transform(:dialogue_split => ByRow(lowercase) => :dialogue_split)
    transform(:dialogue_split => ByRow(strip_punc) => :dialogue_stripped)
end

Confirming that this worked:

show(df_split.:dialogue_stripped[1:10])

SubString{String}["something", "is", "coming", "something", "hungry", "for", "blood", "a", "shadow", "grows"]

Splendid.

Remove Stop Words

The next step is to get rid of stop words, because we don’t really care about counting those. There’s a list of stopwords in the Languages.jl package that we’ll use

stops = stopwords(Languages.English())

488-element Vector{String}:
 "a"
 "about"
 "above"
 "across"
 "after"
 "again"
 "against"
 "all"
 "almost"
 "alone"
 "along"
 "already"
 "also"
 ⋮
 "you'd"
 "you'll"
 "young"
 "younger"
 "youngest"
 "your"
 "you're"
 "yours"
 "yourself"
 "yourselves"
 "you've"
 "z"

Swell. Now that we have this, we can subset (filter in R terms) our dataset to include only rows with words not in the list of stop words.

dialogue_no_stops = subset(
    df_split,
    :dialogue_stripped => x -> .!in.(x, Ref(stops))
    )

If you’re not familiar with Julia, the . is a way to broadcast/vectorize operations, which mostly aren’t vectorized by default. And to be completely honest, I’m not sure why I need to wrap our stopwords in Ref(), but the internet says I do and I assume this is some Julia equivalent of, like, tidyeval that I haven’t gotten around to understanding yet. But regardless, this does what we want!

Getting the Top 20 Words

We’re almost there, fam. We’ve got a dataset in the format we want it in, and we’ve done some light cleaning. Now, let’s count how often each word is used and select the top 20 most common. Again, we’re going to chain some operations together.

top_20 = @chain dialogue_no_stops begin
    groupby(:dialogue_stripped)
    combine(nrow => :count)
    sort(:count, rev = true)
    first(20)
end

I’m actually not going to explain the above because I think it’s pretty intuitive if you’ve been following along so far and are familiar with either R or Python functions (the function names here are pretty descriptive, I think).

Plotting

Ok, so, as much as I like Julia so far, plotting does feel difficult. I’ve mostly used Makie and its counterparts, and I think I’m almost starting to get a handle on them, but they definitely don’t feel as intuitive to me as, say, ggplot2.

Full transparency – making this little plot took me more time than I wanted it to, and it’s entirely due to labeling the y-axis ticks. So, uh, here’s the code to make the plot, and just know that I don’t fully understand why some options accept vectors while others want tuples.

lbls = "Rank " .* reverse(string.(1:20))

barplot(
    1:nrow(top_20),
    reverse(top_20.count),
    direction = :x,
    bar_labels = reverse(top_20.:dialogue_stripped),
    flip_labels_at = median(top_20.count),
    axis = (
        yticks = (1:20, lbls),
        title = "Most Common Words in Stranger Things",
        xlabel = "Times Said"
    ),
)

Et voila – we’ve taken a dataframe with dialogue, tokenized it, cleaned it a little bit, and found the top 20 most common words. We could modify our list of stop words a little if we wanted to get rid of things like “oh”, “okay”, “uh”, and whatnot, but I’m not going to bother with that here. I hope you learned as much from reading this as I did from writing it!

Stating the Problem

So, what I want to do here is get point estimates for the coefficients in a logistic regression model “by hand” (or mostly by hand). I’m going to be doing this in Julia, because I’m also interested in getting better at Julia stuff, but obviously the concepts are the same across any programming language.

Setup

First, we’ll load the libraries we’re using here and set a seed:

using GLM #to check my work against
using Distributions #for the Bernoulli distribution
using Random #to set a seed
using Optim #to do the acutal optimizing
using Statistics #mean and std
using RDatasets #to get data

Random.seed!(0408)

TaskLocalRNG()

Load and Preprocess Data

Next, we’ll load in some data and do some light preprocessing. We’ll use the Default data from the RDatasets package, which presents features describing a given person as well as a binary indicator of whether they defaulted on a credit card payment.

After loading the data, we’ll pull out the default variable, dummy code it, and then assign it to a vector called y. We’ll also select just the “balance” and “income” columns of the data and assign those to X. There are other columns we could use as predictors, but that’s not really the point here.

data = RDatasets.dataset("ISLR", "Default")

y = [r.Default == "Yes" ? 1 : 0 for r in eachrow(data)]

X = data[:, [:Balance, :Income]]

Next, we’ll z_score the predictor variables, convert them to a matrix, and append a column vector of ones to the matrix (so we can estimate the intercept). The mapcols() function from DataFrames.jl will apply the z_score function to all of the columns in X, which is actually only 2 in this case.

First we’ll define a z-score function

function z_score(x)
    u = mean(x)
    s = std(x)

    res = Float64[]
    for i in 1:lastindex(x)
        tmp = (x[i] - u) / s
        push!(res, tmp)
    end

    return res
end

z_score (generic function with 1 method)

And then we’ll actually apply it.

Xz = hcat(ones(length(y)), Matrix(mapcols(z_score, X)))

10000×3 Matrix{Float64}:
 1.0  -0.218824    0.813147
 1.0  -0.037614   -1.60542
 1.0   0.492386   -0.131206
 1.0  -0.632861    0.164023
 1.0  -0.102786    0.370897
 1.0   0.174098   -1.95142
 1.0  -0.0203871  -0.645722
 1.0  -0.0552131  -1.19344
 1.0   0.673295    0.296293
 1.0  -1.727      -0.31805
 1.0  -1.727      -0.873227
 1.0   0.796355   -1.51825
 1.0  -1.23695    -0.394799
 ⋮                
 1.0  -1.727       0.616625
 1.0   0.338849   -1.01252
 1.0  -0.957166   -0.610505
 1.0  -0.36504     1.59599
 1.0   0.571147    0.897805
 1.0   0.213889    1.73331
 1.0  -1.37056    -1.39173
 1.0  -0.255977    1.46029
 1.0  -0.160036   -1.03896
 1.0   0.02075     1.88347
 1.0   1.51667     0.236351
 1.0  -1.31163    -1.24874

Define a Logistic Function

Next, we’ll write a logistic function that will implement the logistic transformation. This is built into the StatsFuns.jl package, but I want to write it out by hand to reinforce what it is. We’ll use this to predict y values with a given input (which will actually be X*)

my_logistic(x) = exp(x) / (1 + exp(x))

my_logistic (generic function with 1 method)

Define a Maximum Likelihood Estimator

Now that we have some data, we can write a function that uses maximum likelihood estimation to give us the best parameters for our given X and y. If you want to brush up on maximum likelihood, you can read my previous “learning out loud” post, or you can probably find materials written by someone who knows way more than I do. Either way, I’m not going to recap what MLE is here.

Let’s define our function that we’ll use to estimate . The important thing to keep in mind is that the return value of this function isn’t the values, but rather the negative log likelihood, since this is what we we want to optimize.

function ml_logreg(x, y, b)

    ŷ = my_logistic.(x*b)
    res = Float64[]

    for i in 1:lastindex(y)
        push!(res, logpdf(Bernoulli(ŷ[i]), y[i]))
    end

    ret = -sum(res)

    return ret
end

ml_logreg (generic function with 1 method)

So what’s going on in this code?

1. We’re getting estimates for a given x and b by running them through the my_logistic() function. This will give us a 10000x1 vector
2. We’re instantiating an empty vector that will (eventually) contain Float64 values.
3. For each index in (i.e. 1 through 10000), we’re getting the log-likelihood of the true outcome (y[i]) given a Bernoulli distribution parameterized by success rate [i].

I think this is the trickiest part of the whole problem, so I want to put it into words to make sure I understand it. In our problem, our y values are either 0 or 1. And the output of the my_logistic() function is going to be, for each y, a predicted probability that , i.e. a predicted success rate. Since a Bernoulli distribution is parameterized by a given success rate and models the outcome of a single yes/no (1/0) trial, it makes sense to use this to generate the likelihoods we want to maximize.

More concretely, the likelihoods we get will be dependent on:

1. the provided success rate p, and
2. the actual outcome

Where values of p that are closer to the actual outcome will be larger:

logpdf(Bernoulli(.5), 1)

-0.6931471805599453

#will be larger than the previous
logpdf(Bernoulli(.8), 1)

-0.2231435513142097

#will be even larger
logpdf(Bernoulli(.99), 1)

-0.01005033585350145

And inversely, you can imagine that if the outcome were 0, we’d want our predicted success rate to be very low.

Returning to our ml_logreg() function, what we’re doing then is applying this logic to all of our and corresponding y values (i.e. we’re getting the likelihood of y for a given ), and then we’re creating a vector with all of these likelihoods – that’s what the push!(...) notation is doing – pushing these likelihoods to the empty float vector we created.

Finally, we’re summing all of our likelihoods and then multiplying the result by negative one, since the optimizer we’re using actually wants to minimize a loss function rather than maximize a loss function.

We can run this function by providing any X, y, and , and it’ll give us back a negative loglikelihood – the negative sum of all of the individual likelihoods.

#just some arbitrary numbers to test the function with
start_vals = [.1, .1, .1]

ml_logreg(Xz, y, start_vals)

7372.506385031871

Optimize

So the above gives us the likelihood for a starting value of , but we want to find the best values of . To do that, we can optimize the function. Like I said in my previous post, the optimizers are written by people much smarter than I am, so I’m just going to use that package rather than futz around with doing any, like, calculus by hand – although maybe that’s a topic for a later learning out loud post.

res = optimize(b -> ml_logreg(Xz, y, b), start_vals)

 * Status: success

 * Candidate solution
    Final objective value:     7.894831e+02

 * Found with
    Algorithm:     Nelder-Mead

 * Convergence measures
    √(Σ(yᵢ-ȳ)²)/n ≤ 1.0e-08

 * Work counters
    Seconds run:   0  (vs limit Inf)
    Iterations:    103
    f(x) calls:    190

And then we can get the coefficients that minimize the loss function (i.e. that maximize the likelihood)

Optim.minimizer(res)

3-element Vector{Float64}:
 -6.125561839584853
  2.731586594783831
  0.2775242967112382

And just to confirm that we did this correctly, we can check our point estimates against what we’d get if we fit the model using the GLM package.

logreg_res = glm(Xz, y, Binomial())

GeneralizedLinearModel{GLM.GlmResp{Vector{Float64}, Binomial{Float64}, LogitLink}, GLM.DensePredChol{Float64, LinearAlgebra.Cholesky{Float64, Matrix{Float64}}}}:

Coefficients:
─────────────────────────────────────────────────────────────────
        Coef.  Std. Error       z  Pr(>|z|)  Lower 95%  Upper 95%
─────────────────────────────────────────────────────────────────
x1  -6.12557    0.187562   -32.66    <1e-99  -6.49318   -5.75795
x2   2.73159    0.109984    24.84    <1e-99   2.51602    2.94715
x3   0.277522   0.0664854    4.17    <1e-04   0.147213   0.407831
─────────────────────────────────────────────────────────────────

Cool beans!

Maury Povich as a metaphor for maximum likelihood estimation

So this obviously isn’t 100% mathematically rigorous, but based on my understanding of maximum likelihood estimation (MLE), I think it’s kind of like the Maury Povich show…

Back when I was in high school, some of my friends and I used to eat lunch in our track coach’s classroom and watch the Maury Povich show. For those of you that haven’t every watched Maury, it’s an…interesting study of human behavior…and worth checking out. But basically it’s like Jerry Springer or any of these other daytime drama-fests, covering everything from infidelity to obesity to insane behavior and everything in between. But Maury’s specialty was paternity tests.

Although the details of the paternity test episodes differed slightly, a common pattern was that a pregnant woman along with multiple men would come on the show, and each of the men would take a paternity test. Maury would ask the men and the women to describe how confident they were in the results of the test, and the men would usually offer up something like:

“I am a thousand percent sure I am not the father.”

Which would then elicit the next man to say:

“Well I am one million percent sure I’m not the father!”

Which would in turn elicit animated reactions from the audience, the mother, and the other potential father(s) on the stage.

So how’s this like maximum likelihood estimation?

So my understanding of the logic of maximum likelihood estimation (MLE) is that, given a set of data, we can estimate the likelihood of a distribution parameterized by a given set of parameters. Imagine we have a bunch of measures of adult heights, and we assume that height is normally distributed. We know that a normal distribution is defined by its mean and its standard deviation. And so using our set of data, we can estimate the likelihood of any combination of mean and standard deviation (i.e. any set of parameters) given this data. And the parameters with the maximum likelihood are the “best” given our set of data. We’ll walk through this with examples later.

What matters here though is that the actual number describing the likelihood (or the log-likelihood, more likely) doesn’t really matter. It’s not arbitrary, but it’ll differ depending upon how many observations are in your dataset, the distribution you’re using, etc. The values of the (log)likelihood relative to one another are what matters. And in this respect I’m reminded of Maury’s paternity tests.

It doesn’t matter if a guest on the show says he’s 100% sure the baby isn’t his. If the guy next to him says he’s 110% sure the baby’s not his, then he’s more certain than the first guy. Likewise, if the first guy says he’s one million percent sure the baby isn’t his, he still “loses” if the guy next to him says he’s 2 million percent sure. The actual number doesn’t matter – what matters is the estimate relative to the other estimates.

Some Examples

I’m not 100% sure the Maury analogy actually holds up, but whatever, let’s work through some examples

First we’ll load some necessary packages.

using Distributions
using CairoMakie
using Random
using Optim
using GLM
using DataFrames

Case 1: Fitting a Normal Distribution

This is the simplest case. First, we’re going to generate some sample data, s, from a normal distribution with and

Random.seed!(0408)
s = rand(Normal(), 10000)

10000-element Vector{Float64}:
 -1.4055556573814212
  0.8813161144909877
  0.4695240597638853
  1.0596565592604608
 -1.1909245261358548
 -1.4819187811057175
 -0.40408041211016915
 -0.37805385034816524
 -1.5132047920081557
  2.2528479354589197
 -1.6595728371412546
  1.321172026499611
 -1.5741912720732054
  ⋮
 -0.6706076665047674
  1.313413766916552
 -0.5776340358208154
  2.2968511578121857
  0.6020915294889897
  0.19216658269979192
  0.8936776607551574
 -0.5898756308872724
  0.2424739897566387
  0.7926169568329148
 -0.46603730352631795
 -0.6572491362891565

Then we’ll generate a bunch of normal distributions with various means and standard deviations

μs = collect(-2.0:2.0)
σs = [0.5:0.5:2;]

ds = []

for i = μs, j = σs
    d = Normal(i, j)
    push!(ds, d)
end

So our task now is going to be to determine the likelihood of each distribution (defined with a given set a parameters) given our data, s, that we’ve drawn from a normal distribution with and

To do this, we use the probability density function (pdf) of our normal distribution to determine the likelihood of the parameters for any given observation. Fortunately, Julia (and other languages) have tools that can help us do this without having to write out the entire equation by hand. That said, here’s the equation – even though I’m not going to call it directly, it’s probably useful to see it.

Let’s take a look at the first observation and the first distribution we defined:

The first value in our sample is:

s[1]

-1.4055556573814212

And the first distribution we’ll look at is

ds[1]

Normal{Float64}(μ=-2.0, σ=0.5)

And if we look at the pdf of this, we get:

pdf(ds[1], s[1])

0.39356088133821826

I’m not a statistician (hence these learning posts), but my understanding of this is that it generally represents the “fit” of the distribution (and its parameters) to the given sample/data point. These values will be bound between 0 and 1, since they’re likelihoods, with higher values indicating better fit/higher likelihood.

The next step is to convert this to a log scale, since logging allows us to sum things rather than multiply them (which we’re gonna do soon).

logpdf(ds[1], s[1])
#same as log(pdf(ds[1], s[]1))

-0.9325195055871961

So this gives us the log likelihood of a given data point. But now we need to do this for all of the data points in our sample to determine the “fit”/likelihood of the distribution to our whole sample.

sum(logpdf.(ds[1], s))

-103363.07786213113

Apparently Distributions.jl gives us a helper for this via loglikelihood, so the above is the same as:

loglikelihood(ds[1], s)

-103363.07786213112

So this gives us the (log)likelihood of a distribution (normal, in this case, defined by parameters and ) given our sample. That is, the relatively plausibility of the parameters given our data. The goal then is to pick the best distribution/parameters, which we can do by maximizing the likelihood. In Maury terms, we want to find guy who’s most sure that the baby isn’t his.

Or, apparently, it’s more common to minimize the negative loglikelihood, which is the same thing (and called logloss, I guess).

So let’s do this for all of the distributions we specified earlier

lls = []

for i in ds
    res = -loglikelihood(i, s)
    push!(lls, res)
end

lls = Float64.(lls)

20-element Vector{Float64}:
 103363.07786213112
  34465.6764159677
  24477.94356153769
  22439.92990862643
  42816.83247490566
  19329.115069161333
  17750.58296295708
  18655.789571924823
  22270.587087680186
  14192.553722354956
  15467.666808820915
  17371.649235223234
  41724.3417004547
  19055.992375548587
  17629.195099129196
  18587.50889852165
 101178.09631322921
  33919.43102874222
  24235.16783388192
  22303.36856182006

And then we can plot the loglikelihoods we get:

ind = collect(1.0:length(ds))

lines(ind, lls)

Notice that our negative log likelihood is minimized in the 10th distribution, so let’s take a look at what that is

ds[10]

Normal{Float64}(μ=0.0, σ=1.0)

This makes sense! This was the distribution that we drew our samples from!

If we want to do this without looking at a plot, we can apparently do this:

#get the index of the minimum value in lls
min_ll = findall(lls .== minimum(lls))

#get the distribution at this index
ds[min_ll]

1-element Vector{Any}:
 Normal{Float64}(μ=0.0, σ=1.0)

So this tells us that – of the distributions we tested! – the most likely distribution given our data is a normal distribution with mean of 0 and standard deviation of 1. This doesn’t necessarily mean that this and are the optimal parameters. There could be better parameters that we didn’t test, and so in the future we’d want to probably use some sort of optimizing functions that can do all of the math for us.

Case 2: Simple Linear Regression

So now let’s move on a bit and try a simple linear regression. First we’ll just generate some fake data and a “ground truth” function

#generate some x values
x = collect(0:.1:10)

#generate error
ϵ = rand(Normal(0, 1), length(x))

#define a function relating x to y
f(x) = 0.5 + 2*x

#generate y as f(x) plus error
y = f.(x) .+ ϵ

101-element Vector{Float64}:
  2.4461255238293758
  1.2496723713219855
  1.5014319678963934
  1.8228982131749496
 -0.4320716243406362
  0.9628100854937409
  2.475384749019799
  2.047025196204242
  1.7487030877341891
  1.4865883008076408
  0.405749179591091
  2.5585877608457355
  2.956751811280712
  ⋮
 19.232878652117428
 17.53450559237765
 19.290332010598092
 18.144129060042054
 18.413568163778812
 17.89449730367819
 19.175282300038607
 20.826640516579364
 19.21519350783753
 19.070233221768582
 21.072296712369102
 19.469128284822276

And then we can plot the x and y values we just created:

CairoMakie.scatter(x, y)

Another way to think about the above is that we expect a linear relationship between x and y in the form of

We need to estimate alpha and beta in a way that optimally fits this line, and we can do this with maximum likelihood. We can take advantage of the fact that linear regression assumes that residuals are normally distributed with an expected value (mean) of 0, since this will provide as with a distribution we can try to parameterize optimally. Since the residuals are dependent upon the predicted values of y, and since the predicted values of y are dependent on the intercept () and the coefficient (), this will give us a way to estimate the terms in the regression line.

is not super important to us, but we still need to estimate it. We can estimate the loglikelihood of a given set of parameters using the function below.

function max_ll_reg(x, y, params)

    α = params[1]
    β = params[2]
    σ = params[3]

    ŷ = α .+ x.*β

    resids = y .- ŷ

    d = Normal(0, σ)

    ll = -loglikelihood(d, resids)
    
    return ll

end

max_ll_reg (generic function with 1 method)

And let’s see how this works by passing in some generic values – .5 as the intercept, 2 as the beta coefficient, and 1 as the error variance.

yy = max_ll_reg(x, y, [.5, 2, 1])

137.00423917573127

The next step then is to optimize this. We pass some starting values and our max_ll_reg function into an optimizer, tell it to find the optimal values for the parameters (, , and ), and then the magical optimizing algorithm written by people much smarter than me will give us our coefficients.

res = optimize(params -> max_ll_reg(x, y, params), [0.0, 1.0, 1.0])

 * Status: success

 * Candidate solution
    Final objective value:     1.361561e+02

 * Found with
    Algorithm:     Nelder-Mead

 * Convergence measures
    √(Σ(yᵢ-ȳ)²)/n ≤ 1.0e-08

 * Work counters
    Seconds run:   0  (vs limit Inf)
    Iterations:    130
    f(x) calls:    234

And then this will give us the maximum likelihood solution for our regression equation.

Optim.minimizer(res)

3-element Vector{Float64}:
 0.6262632240571052
 1.9908770881500015
 0.9315933450872507

We can check this by fitting the model with the GLM package

data = DataFrame(X = x, Y = y)

ols_res = lm(@formula(Y ~ X), data)

StatsModels.TableRegressionModel{LinearModel{GLM.LmResp{Vector{Float64}}, GLM.DensePredChol{Float64, LinearAlgebra.CholeskyPivoted{Float64, Matrix{Float64}}}}, Matrix{Float64}}

Y ~ 1 + X

Coefficients:
────────────────────────────────────────────────────────────────────────
                Coef.  Std. Error      t  Pr(>|t|)  Lower 95%  Upper 95%
────────────────────────────────────────────────────────────────────────
(Intercept)  0.626272   0.185875    3.37    0.0011   0.257455   0.995089
X            1.99088    0.0321144  61.99    <1e-80   1.92715    2.0546
────────────────────────────────────────────────────────────────────────

et voila, we get the same and ! The coefficients aren’t exactly the same as the ones we specified when generating the data, but that’s because of the error we introduced.

It’s maybe also worth nothing that Julia lets us solve the equation via the \ operator, which apparently provides a shorthand for solving systems of linear equations:

#we have to include a column of 1s in the matrix to get the intercept
xmat = hcat(ones(length(x)), x)

xmat \ y

2-element Vector{Float64}:
 0.6262717121103298
 1.9908750493937837

Case 3: Multiple Regression

And I think we can extend the same logic above to multiple regression. The first step is to generate some data:

#make a 100x3 matrix of random numbers
tmp = randn(100, 3)

#append a leading column of 1s (so we can get the intercept)
𝐗 = hcat(ones(100), tmp)

#provide 'ground truth' coefficients
𝚩 = [.5, 1, 2, 3]

#define a function to multiply X by B
f₂(X) = X*𝚩

#create some error
ϵ = rand(Normal(0, .5), size(𝐗)[1])

#make outcome values that comprise our generating function plus error
𝐘 = f₂(𝐗) + ϵ

100-element Vector{Float64}:
  1.9539840955199055
  2.2807060973619135
  2.406665555383834
 -0.014731760693462048
  0.6002032048684441
 -3.531148702629271
  3.194699866301238
 -1.17858666703318
 -0.31117832513371646
  1.5595030004201824
  7.314823243199307
 -2.1182414214687673
 -3.502694667516171
  ⋮
  9.205296659574488
  4.233455153011074
  5.620823053237128
 -2.4088759447640156
  5.127431971734125
  1.0043279157869205
  3.6343775497324184
  2.611885689812401
  0.11077494956658729
  3.06142672043232
  1.961141975667116
 -0.013605916161866072

Then we can define another function to return the maximum likelihood. This is the same as the simple regression function above, except it’s generalized to allow for more than 1 slope coefficient. Julia provides some neat functionality via the begin and end keywords that let us access the first and last elements of a vector, and we can even do things like end-1 to get the second-to-last element, which is pretty nifty.

function max_ll_mreg(x, y, params)
    𝚩 = params[begin:end-1]
    σ = params[end]

    ŷ = x*𝚩

    resids = y .- ŷ

    d = Normal(0, σ)

    ll = -loglikelihood(d, resids)

    return ll
end

max_ll_mreg (generic function with 1 method)

Then we can do the same thing as before – provide some starting parameters (coefficients), and tell our super-smart optimizer function to give us the parameters that maximize the likelihood.

start_params = [.4, .5, 1.5, 4.0, 1.0]

mreg_res = optimize(params -> max_ll_mreg(𝐗, 𝐘, params), start_params)

 * Status: success

 * Candidate solution
    Final objective value:     6.860916e+01

 * Found with
    Algorithm:     Nelder-Mead

 * Convergence measures
    √(Σ(yᵢ-ȳ)²)/n ≤ 1.0e-08

 * Work counters
    Seconds run:   0  (vs limit Inf)
    Iterations:    221
    f(x) calls:    392

And then we can show the results:

Optim.minimizer(mreg_res)

5-element Vector{Float64}:
 0.42976727494283473
 1.0367345683471323
 1.8923643524058003
 3.0304421915621127
 0.4805357922701782

And we can check that these are returning the correct values

𝐗 \ 𝐘

4-element Vector{Float64}:
 0.42976708591782187
 1.0367343909692166
 1.8923640529063954
 3.0304412982361364

Alternatively, we could have written out the joint pdf for the normal distribution by hand, like below.

First we can define this function:

function alt_mle_mlr(x, y, params)
    𝚩 = params[begin:end-1]
    σ = params[end]

    ŷ = x*𝚩

    n = length(ŷ)

    ll = -n/2*log(2π) - n/2* log(σ^2) - (sum((y .- ŷ).^2) / (2σ^2))
    
    ll = -ll

    return ll
end

alt_mle_mlr (generic function with 1 method)

Then see what the loglikelihood is given our starting parameters:

alt_mle_mlr(𝐗, 𝐘, start_params)

174.11351826768353

Then optimize the function:

mreg_res2 = optimize(params -> alt_mle_mlr(𝐗, 𝐘, params), start_params)

 * Status: success

 * Candidate solution
    Final objective value:     6.860916e+01

 * Found with
    Algorithm:     Nelder-Mead

 * Convergence measures
    √(Σ(yᵢ-ȳ)²)/n ≤ 1.0e-08

 * Work counters
    Seconds run:   0  (vs limit Inf)
    Iterations:    221
    f(x) calls:    392

And check the results:

Optim.minimizer(mreg_res2)

5-element Vector{Float64}:
 0.42976727494283473
 1.0367345683471323
 1.8923643524058003
 3.0304421915621127
 0.4805357922701782

And there we go. Hopefully that was helpful for some others. I’ll probably do some more of these “learning out loud” posts as I dig into some more math, Julia, or other topics.

Setup

First we’ll do a little bit of set up, and we’ll also pull down the data.

library(tidyverse)
library(cfg)
library(eemisc)
library(harrypotter)
library(glue)
library(ggtext)

theme_set(theme_minimal())

options(
    ggplot2.discrete.fill = list(
        hp(n = 2, option = "HermioneGranger")
    ),
    ggplot2.discrete.color = list(
        hp(n = 2, option = "HermioneGranger")
    )
)

#get data
women_df <- fetch_leaderboard(division = "women") |>
    mutate(division = "Women")

men_df <- fetch_leaderboard(division = "men") |>
    mutate(division = "Men")

combined <- bind_rows(women_df, men_df)

long_by_event <- combined |>
    select(athlete, division, starts_with("event")) |>
    pivot_longer(
        cols = starts_with("event"),
        names_to = "event",
        values_to = "event_place"
    )

Points

Let’s first take a look at all of the athletes’ total points. Hopefully this is pretty self-explanatory.

ggplot(combined, aes(x = points, y = fct_reorder(athlete, points), fill = division)) +
    geom_col() +
    geom_text(aes(label = points, x = points - 10), hjust = 1, color = "white") +
    facet_wrap(vars(division), scales = "free_y") +
    labs(
        x = "Total Points",
        y = NULL,
        title = "Total Points by Athlete at the 2022 CFG"
    ) +
    theme(
        legend.position = "none"
    )

Number of Top 3 Finishes

Another thing that might be interesting to check out is the number of top 3 finishes from each athlete:

long_by_event |>
    filter(event_place <= 3) |>
    count(division, athlete) |>
    filter(n > 1) |>
    ggplot(aes(x = n, y = fct_reorder(athlete, n), fill = division)) +
    geom_col() +
    geom_text(aes(label = n, x = n - .1), hjust = 1, color = "white") +
    labs(
        y = NULL,
        x = "# of Top 3 Finishes",
        title = "Number of Top 3 Finishes by Athlete",
        subtitle = "Only athletes with multiple top 3 finishes shown"
    ) +
    theme(
        legend.position = "none"
    )

It’s probably not surprising that Tia dominated here, finishing in the top 3 in 8 of the 14 total scored events. One thing that’s interesting to me, though, is that every athlete who podiumed had 5 (or more) top 3 finishes, while nobody else had more than 3.

Event Placement Variability

We hear a lot about the importance of consistency in Crossfit. After all, the whole point of Crossfit is to be able to do everything well. We always hear that you need to be well rounded and need to avoid bombing events. And whenever Pat Vellner or Laura Horvath or whoever has a bad event, we hear about how that’s not the way to win the Games.

So given all of that, let’s spend some time looking at event-to-event variability for each athlete. To make it a bit easier, I’ll limit this to the top 20 athletes for the men and women.

In the graph below, I’ll show athletes’ average event placement with a dot, and a measure of their variability with a bar. It doesn’t really matter how variability is calculated (it’s just the standard error of the mean in this case), but suffice to say that the wider the bar is, the more variable (less consistent) each athlete’s performance was.

top_20 <- combined$athlete[combined$place <= 20]

long_by_event |>
    filter(athlete %in% top_20) |>
    group_by(division, athlete) |>
    summarize(sem = sd(event_place)/sqrt(14), avg = mean(event_place)) |>
    ungroup() |>
    ggplot(aes(x = avg, y = fct_reorder(athlete, -avg), color = division)) +
    geom_point() +
    geom_errorbarh(aes(xmin = avg - sem, xmax = avg + sem), height = 0) +
    facet_wrap(vars(division), scales = "free_y") +
    labs(
        y = NULL,
        x = "Event Placement",
        title = "Event Avg Placement and Variability"
    ) +
    scale_color_hp_d("HermioneGranger") +
    theme(
        panel.grid.major.y = element_blank(),
        legend.position = "none"
    )

So we can see a lot of differences between athletes here. Justin Medeiros and Roman Khrennikov were the two most consistent athletes (followed by Tia Toomey). We can also see that Noah Ohlsen and BKG were very consistent, albeit consistently toward the high-middle. On the flip side, we can see people like Laura Horvath, Gui Malheiros, and Dani Speegle had a lot of variability between events – meaning they finished very well in some and very poorly in others.

Finish Range

The analysis above takes all of the athletes’ events into account to calculate variability, but we might just care about each athlete’s best and worst performance, and the spread between those.

finish_range <- long_by_event |>
    filter(athlete %in% top_20) |>
    group_by(division, athlete) |>
    summarize(
        worst = max(event_place),
        best = min(event_place)
    ) |>
    ungroup() |>
    left_join(select(combined, place, athlete), by = "athlete")

ggplot(finish_range, aes(color = division, y = fct_reorder(athlete, -place))) +
    geom_segment(aes(x = best, yend = fct_reorder(athlete, -place), xend = worst)) +
    geom_point(aes(x = worst), size = 7, shape = 21, fill = "white") +
    geom_point(aes(x = best), size = 7, shape = 21, fill = "white") +
    geom_text(aes(x = worst, label = worst)) +
    geom_text(aes(x = best, label = best)) +
    scale_color_hp_d("HermioneGranger") + 
    facet_wrap(vars(division), scales = "free_y") +
    labs(
        x = "Event Finish",
        y = NULL,
        title = "Best and Worst Finishes for Top 20 Athletes"
    ) +
    theme(
        legend.position = "none"
    )

Although this shows something slightly different that the previous graph, it basically reaffirms what we saw there. One interesting takeaway is that Justin Medeiros won the Games without actually winning any events. Another interesting point is that Roman Khrennikov had the best “worst event finish” out of everyone, never finishing lower than 15th, which is pretty incredible. On the women’s side, we see that quite a few athletes spanned the whole range between first and last (recall that Emily Rolfe withdrew, so last was 39th for much of the competition). Laura Horvath, Dani Speegle, and Lucy Campbell all went from worst to first, and a few others (Kara Saunders, Amanda Barnhart) managed nearly the same. To be fair, there were a few instances of this on the men’s side, too (Adler, Malheiros, Pepper).

Score Variability vs Overall Finish

This doesn’t really tell us the story about how much consistency matters, though. On the one hand, Medeiros and Khrennikov were the most consistent and also finished top 2. On the other hand, Noah Ohlsen was also incredibly consistent, but he finished 12th, whereas Laura Horvath had a lot of variability in her performances and finished 3rd. So let’s plot athletes’ overall finish (on the X axis) against their score variability (on the Y axis). If these are strongly related, we’d expect to see them form a line. If they’re not strongly related, they’ll look like a blob.

sem_by_place <- long_by_event |>
    group_by(division, athlete) |>
    summarize(sem = sd(event_place)/sqrt(14)) |>
    ungroup() |>
    left_join(select(combined, athlete, place), by = "athlete") 
    
sem_by_place |>
    ggplot(aes(x = place, y = sem, color = division)) +
    geom_point() +
    scale_color_hp_d("HermioneGranger") +
    facet_wrap(vars(division)) +
    labs(
        x = "Place",
        y = "Variability"
    ) +
    theme(
        legend.position = "none"
    )

It doesn’t really seem like there’s much here. But we can calculate the actual correlation coefficient to get a number to summarize the relationship.

cor(sem_by_place$sem, sem_by_place$place)

[1] -0.1818332

So there’s a small negative correlation here – people who varied more between events tended to place slightly worse overall. But it’s a pretty small relationship.

Point Trajectories for Top 5

The thing that always makes the Games interesting are the races for the podium, and this year had some great races. On the men’s side, there was a lot of jostling between the top 3 for position. On the women’s side, Tia didn’t pull away until about event 10, and even Tia and Mal had locked up the gold and silver, there was an incredibly exciting race for 3rd thanks to a big comeback from Laura Horvath. So let’s plot the point trajectories for the athletes that ended up finishing in the top 5:

top_5 <- combined$athlete[combined$place <= 5]

scores_men <- running_scores(men_df) |>
    mutate(division = "Men")

scores_women <- running_scores(women_df) |>
    mutate(division = "Women")

scores_combined <- bind_rows(scores_men, scores_women) |>
    filter(athlete %in% top_5)
    
max_athlete <- scores_combined |>
    group_by(athlete) |>
    summarize(score = max(cum_points))

scores_combined <- scores_combined |>
    left_join(max_athlete, by = "athlete")

ggplot(scores_combined, aes(x = event, y = cum_points, color = athlete)) +
    geom_line() +
    geom_point() +
    geom_text(aes(label = str_replace_all(athlete, "^(.*) (.*)", "\\2"), y = score), x = 14.5, hjust = 0) +
    facet_wrap(vars(division)) +
    scale_x_continuous(limits = c(0, 19), breaks = seq(2, 14, by = 2)) +
    labs(
        title = "Point Trajectories for Top 5 Athletes",
        x = "Event #",
        y = "Total Points"
    ) +
    theme(
        panel.grid.minor.x = element_blank(),
        legend.position = "none"
    )

Laura Horvath’s Comeback

And the last thing I’ll include here is a visualization of Laura Horvath’s huge comeback. I’m a major LH fan, and even though I had a moment of doubt after the HSPU event, I was stoked to see her come back and take 3rd after absolutely crushing it during Sunday’s events.

scores <- running_scores(women_df)

lh_scores <- scores[scores$athlete == "Laura Horvath", ] |>
    select(event, cum_points, athlete)

# function to get 3rd place for a given event
third_place <- function(x, event) {
    tmp <- event_leaderboard(x, event)

    res <- tmp[tmp$place == 3, c("event", "cum_points")]

    res$athlete <- "third"

    res
}

events <- unique(scores$event)

thirds <- map_dfr(events, ~third_place(women_df, .x))

x <- bind_rows(lh_scores, thirds)

hungary_green <- "#436F4D"
bronze <- "#CD7F32"

ggplot(x, aes(x = event, y = cum_points, color = athlete)) +
    geom_line() +
    geom_point(shape = 21, fill = "white", size = 10) +
    geom_text(aes(label = cum_points)) +
    scale_color_manual(
        values = c(hungary_green, bronze)
    ) +
    labs(
        title = glue("<span style='color:{hungary_green}'>Laura Horvath's</span> Charge to the <span style='color:{bronze}'>Podium</span>"),
        y = "Total Points",
        x = "Event #",
        subtitle = glue("The <span style='color:{bronze}'>bronze line</span> represents 3rd place after any given event")
    ) +
    theme_ee(size = 12) +
    theme(
        legend.position = "none",
        panel.grid.minor = element_blank(),
        panel.grid.minor.x = element_blank(),
        panel.grid.minor.y = element_blank(),
        plot.title = element_markdown(size = 16)
    )

That’s all for now – maybe I’ll do another once the Rogue Invitational rolls around in October. And who knows, maybe Tia will hang up her shoes and we’ll have a new top dog in the women’s division.

Step 0: Install Quarto

Maybe this is obvious, but you’ll need Quarto installed if you want to use it. You can download it here

Step 1: Make a site

I prefer to do this from the command line, but I think you can do it from RStudio as well (I use VSCode, so I’m not 100% up-to-date on all of the RStudio IDE features).

You can do this in the command line by changing your working directory to wherever you want your site’s folder to live, then create a default site via:

quarto create-project PROJECT_NAME --type website:blog

This will create a generic sample site with the following file structure:

(n.b. that you may not have the README file in your directory)

Step 2: Render the site

This is sort of optional, but if you want to get a sense of what the default site looks like, you can render all of the files in it. From the command line, set your current directory to the site folder (that you just created), then run

quarto render

and you should get some notifications that your posts are rendering. Once they’re done, you will see a _site folder. This has all of your files rendered inside of it, and if you open index.html, you can navigate to your site’s home page, which (by default) is the blog listing. This is something we’re going to change. You’ll also notice the about.html page, which is what we actually want to make our index.

Step 3: Change some file names

In your root directory (i.e. whatever you set PROJECT_NAME to earlier; not _site), we want to do the following:

• change the file name of index.qmd to blog.qmd
• change the file name of about.qmd to index.qmd

You’ll also want to open up the blog.qmd file and change the title (inside the YAML header) to “Blog”. The header should now look like this:

Likewise, you’ll want to change the title of index.qmd (which was about.qmd) from “About” to something else – maybe your name of the name of the site. So it’ll look something like this:

You’ll also obviously want to change the image, include your own social media links, etc., but we won’t cover that here.

Step 4: Make a new about page

I like having the home page (index) be like a brief summary of me, and then I like having a more detailed “About” page just in case people are interested in reading more. We just set the index to be that brief intro or whatever you want to call it, so now we need to create a new about page.

In your root folder (PROJECT_NAME), create a new file called about.qmd

And then within that you can add in whatever content you want – a brief bio, some pictures, whatever. The only thing I include at the outset (beside the content) is a YAML header that looks like this:

---
title: "About Me"
---

Step 5: Modify your _quarto.yml file

Now we need to modify the _quarto.yml file, which is in the root directory (PROJECT_NAME). This file provides Quarto with some “big picture” instructions on the overall layout and styling of you site.

Basically we need to do 2 things in this file:

1. add blog.qmd to the navbar menu; and
2. add your site url.

You also might want to change your website title. Either way, after you’re done, your _quarto.yml file should look something like this:

Step 6: Render your site (again)

Now we’re ready to render again! Before you render, make sure you save all of your files. As before, we can render the site from the command line via:

quarto render

And your files should update in the _site directory. And that’s pretty much it. You can explore the files in your _site directory and see that our “postcard” is now the index/home page, and your blog and about me pages are accessible via the navbar.

Step 7: Customize and deploy

I’m not going to cover these things, but now that we have our website set up the way we want it, the next steps are to customize the style/theming, add content, include your own social media links, etc. And then finally deploy your site! The main Quarto site has some great resources on how to do all of this.

Wrapping Up

You can see this demo site (I didn’t customize anything beyond what we just walked through) here, and you can see the site’s Github repo here

Hope this helps some folks! Happy Quarto-ing!

Base Function

Right, so, the point of this function is to take a percent (as a decimal) and turn it into a string. The base version of that function is the same as we presented above:

pct_to_string <- function(x) {
    paste0(round(100 * x, digits = 1), "%")
}

And there’s nothing necessarily wrong with this. It works like we’d expect it to:

pct_to_string(.1)

[1] "10%"

pct_to_string(.111)

[1] "11.1%"

Digits Argument

The vast majority of the time, I’ll want to present these string percentages with a single decimal place (e.g. “11.1%”). It’s pretty rare – at least in the contexts I work in – for the hundredths place in a percentage to matter much, and including it detracts more than it helps. If two “groups” score 11.12% and 11.14%, these are functionally identical in my mind.

That said, there may be some cases where I do want to include a hundredths decimal point. More likely, there may be cases where I don’t want to include any decimal points. In the base version of pct_to_string(), I hardcoded the function to provide 1 decimal place (digits = 1). But to allow for some flexibility, I want to make digits an argument. Since I’ll be setting it to 1 99.9% (see what I did there) of the time, I’ll just set 1 as the default. So now our function looks like this:

pct_to_string <- function(x, digits = 1) {
    paste0(round(100 * x, digits = digits), "%")
}

And we can see this in action like so:

#not specifying a digits argument will use the default of 1
pct_to_string(.1111)

[1] "11.1%"

#but we can specify a different number of digits if we want
pct_to_string(.1111, digits = 2)

[1] "11.11%"

Checking Bounds

Most often, the percent data I’m working with is bounded between 0 and 1 (0% - 100%). For instance, if I’m looking at the pass rates for standardized tests, I’m doing something wrong if I have a number greater than 1 or less than 0.

Another note is that, although I’m pretty consistent (insistent? both?) about formatting my percents as decimals, I sometimes pull data from sources where this isn’t the case, and it comes in as, e.g., 80.5 (rather than .805). The Virginia Department of Education tends to format their data this way.

Given both of these tidbits, I want to add an argument to pct_to_string() that checks if values of x are between 0 and 1. In my case, this is mostly to help catch mistakes before I make them. For instance, I want it to stop me if I try to multiply 80.5 * 100 because I didn’t realize the input was 80.5 and not .805. Additionally, because it’s so common that my percents at between 0 and 1, I want it to stop me if I’m working outside of this range.

To accomplish this, I’ll add a check_bounds argument to pct_to_string(). I want this to be a logical argument that, if set to TRUE, will stop the function from running if any values of x are less than 0 or greater than 1.

pct_to_string <- function(x, digits = 1, check_bounds = TRUE) {

    if (check_bounds == TRUE & !(min(x) >= 0 & max(x) <= 1)) {
        stop("all elements of `x` must be between 0 and 1. If you are intentionally using a percentage outside of these bounds, set `check_bounds = FALSE`")
    }

    paste0(round(100 * x, digits = digits), "%")
}

So let’s see how this works, now:

a <- seq(0, 1, .1)

#this should work
pct_to_string(a)

 [1] "0%"   "10%"  "20%"  "30%"  "40%"  "50%"  "60%"  "70%"  "80%"  "90%" 
[11] "100%"

Note that the below will throw an error, so I’m going to capture it using safely() from the {purrr} package and then return the error

b <- seq(0, 1.1, .1)

safe_pts <- safely(pct_to_string)

safe_pts(b)$error

<simpleError in .f(...): all elements of `x` must be between 0 and 1. If you are intentionally using a percentage outside of these bounds, set `check_bounds = FALSE`>

One note is that you could write this function to throw a warning or a message rather than an error depending on your needs. For my personal use cases, I think it makes more sense to throw an error rather than a warning, but your mileage my vary.

Input Checks

A final thing I want to do is add a few statements to check that the input values I’m providing are valid. If this is a function that really is just for me, I might not do this (mostly out of laziness), but I’m also going to add it to a package that other people at my work use, so I think it makes sense to include these.

Basically, these will just throw an error if you try to pass an invalid value to one of the function arguments. Like with the check_bounds piece earlier, this entials using an if statement to evaluate some parameter values, and then, if these are TRUE, to stop the function and instead return an error message. I also want to make sure that the error messages are actually helpful. We can add these like so:

pct_to_string <- function(x, digits = 1, check_bounds = TRUE) {
    if (!is.numeric(x)) {
        stop("`x` must be numeric")
    }

    if (!is.integer(digits) | digits < 0) {
        stop("`digits` must be a non-negative integer")
    }

    if (!is.logical(check_bounds)) {
        stop("`check_bounds` must be TRUE or FALSE")
    }

    if (check_bounds == TRUE & !(min(x) >= 0 & max(x) <= 1)) {
        stop("all elements of `x` must be between 0 and 1. If you are intentionally using a percentage outside of these bounds, set `check_bounds = FALSE`")
    }

    paste0(round(100 * x, digits = digits), "%")
}

# and wrapping this with safely() again to show errors
safe_pts <- safely(pct_to_string)

And we can see what happens if we pass in invalid values:

safe_pts(.1, digits = "a")$eror

NULL

safe_pts(x = "a", digits = 0)$error

<simpleError in .f(...): `x` must be numeric>

etc. etc.

Technically, you don’t need some of these checks. If you try to pass a non-numeric value (x) to round(), you’ll get an error. Likewise if you give it an invalid value for its digits argument:

# first creating a safe function to catch error
safe_round <- safely(round)

safe_round(1.1, digits = "a")$error

<simpleError in .Primitive("round")(x, digits): non-numeric argument to mathematical function>

safe_round("a", digits = 1)$error

<simpleError in .Primitive("round")(x, digits): non-numeric argument to mathematical function>

But these error messages aren’t quite as helpful as the ones we’ve written.

Wrapping Up

That’s pretty much it – my thought process for creating a pretty simple function to convert percents to strings, as well as how I would build out this function. Hopefully this metacognitive activity was useful for people who are just starting out writing their own R functions!

Setup

To start, let’s load the packages we’ll need.

knitr::opts_chunk$set(echo = TRUE, warning = FALSE, message = FALSE)

library(tidyverse)
library(palmerpenguins)

Let’s also take a quick peeksie at the penguins data, although the content of the data isn’t terrible important here.

glimpse(penguins)

Rows: 344
Columns: 8
$ species           <fct> Adelie, Adelie, Adelie, Adelie, Adelie, Adelie, Adel…
$ island            <fct> Torgersen, Torgersen, Torgersen, Torgersen, Torgerse…
$ bill_length_mm    <dbl> 39.1, 39.5, 40.3, NA, 36.7, 39.3, 38.9, 39.2, 34.1, …
$ bill_depth_mm     <dbl> 18.7, 17.4, 18.0, NA, 19.3, 20.6, 17.8, 19.6, 18.1, …
$ flipper_length_mm <int> 181, 186, 195, NA, 193, 190, 181, 195, 193, 190, 186…
$ body_mass_g       <int> 3750, 3800, 3250, NA, 3450, 3650, 3625, 4675, 3475, …
$ sex               <fct> male, female, female, NA, female, male, female, male…
$ year              <int> 2007, 2007, 2007, 2007, 2007, 2007, 2007, 2007, 2007…

Cool cool. Now, let’s assume we want to analyze this penguins data. Let’s say we want to estimate a mean, a correlation coefficient, and fit a linear regression, and that this is our workflow (n.b. again that this probably shouldn’t be your actual workflow when you analyze data).

Let’s say we want to get the mean body mass – this is easy for us.

mean(penguins$body_mass_g, na.rm = TRUE)

[1] 4201.754

Another way we can do the exact same thing is with do.call(). do.call() has a “what” argument, to which you provide the function you want to call (or the character string name of the function), and an “args” argument, where you list the arguments to pass to “what”. It has some other arguments, too, but I’m going to ignore those here. So, the call below does the exact same thing we did previously:

do.call(what = "mean", args = list(penguins$body_mass_g, na.rm = TRUE))

[1] 4201.754

The nice thing about do.call is that it’s very flexible. Say we wanted to run a correlation between body mass and bill depth. We can do this by directly calling the cor() function:

# option 1:
cor(
    x = penguins$body_mass_g,
    y = penguins$bill_depth_mm, 
    use = "pairwise.complete.obs"
)

[1] -0.4719156

Or we can do the exact same thing via do.call():

# option 2
do.call("cor",
    args = list(
        x = penguins$body_mass_g,
        y = penguins$bill_depth_mm, 
        use = "pairwise.complete.obs"
    )
)

[1] -0.4719156

Or say we wanted to run a linear regression with body mass regressed on bill depth and sex. Again, we can call lm() directly:

# option 1:
res1 <- lm(body_mass_g ~ bill_depth_mm + sex, data = penguins, na.action = "na.omit")

broom::glance(res1)

# A tibble: 1 × 12
  r.squared adj.r.squared sigma statistic  p.value    df logLik   AIC   BIC
      <dbl>         <dbl> <dbl>     <dbl>    <dbl> <dbl>  <dbl> <dbl> <dbl>
1     0.642         0.640  483.      296. 2.34e-74     2 -2529. 5066. 5081.
# … with 3 more variables: deviance <dbl>, df.residual <int>, nobs <int>

Or via do.call():

#option 2
res2 <- do.call("lm", args = list(
    formula = body_mass_g ~ bill_depth_mm + sex,
    data = penguins,
    na.action = "na.omit"
))

broom::glance(res2)

# A tibble: 1 × 12
  r.squared adj.r.squared sigma statistic  p.value    df logLik   AIC   BIC
      <dbl>         <dbl> <dbl>     <dbl>    <dbl> <dbl>  <dbl> <dbl> <dbl>
1     0.642         0.640  483.      296. 2.34e-74     2 -2529. 5066. 5081.
# … with 3 more variables: deviance <dbl>, df.residual <int>, nobs <int>

#generate data
a <- rnorm(100)
b <- rnorm(100)
d <- rnorm(100)

#put data into a list
sample_args <- list(
    x = list(a, b, d),
    y = list(b, d, a)
)

pmap(sample_args, ~cor(..1, ..2, use = "pairwise.complete.obs"))

[[1]]
[1] 0.0467708

[[2]]
[1] 0.1479934

[[3]]
[1] -0.07458596

#create a vector of function names
funs <- c("mean", "cor", "lm")

#create a list of function arguments, where each element of the list is a list of args
fun_args <- list(
    list(penguins$body_mass_g, na.rm = TRUE),
    list(
        penguins$body_mass_g, 
        penguins$bill_depth_mm, 
        use = "pairwise.complete.obs"
        ),
    list(
        formula = body_mass_g ~ bill_depth_mm + sex,
        data = penguins,
        na.action = "na.omit"
    )
)

#combine the function names and args into a tibble
fun_iterator <- tibble(
    f = funs,
    fa = fun_args
)

#take a look at the tibble
glimpse(fun_iterator)

Rows: 3
Columns: 2
$ f  <chr> "mean", "cor", "lm"
$ fa <list> [<3750, 3800, 3250, NA, 3450, 3650, 3625, 4675, 3475, 4250, 3300, 3…

res <- pmap(fun_iterator, ~ do.call(..1, ..2))

#mean
res[[1]]

[1] 4201.754

#cor
res[[2]]

[1] -0.4719156

#lm
broom::glance(res[[3]])

# A tibble: 1 × 12
  r.squared adj.r.squared sigma statistic  p.value    df logLik   AIC   BIC
      <dbl>         <dbl> <dbl>     <dbl>    <dbl> <dbl>  <dbl> <dbl> <dbl>
1     0.642         0.640  483.      296. 2.34e-74     2 -2529. 5066. 5081.
# … with 3 more variables: deviance <dbl>, df.residual <int>, nobs <int>

analyze_penguins <- function(include = c("mean", "cor", "lm")) {
  #some code here
}

analyze_penguins <- function(include = c("mean", "cor", "lm")) {
    #we already ran all of this
    funs <- c("mean", "cor", "lm")

    fun_args <- list(
        list(penguins$body_mass_g, na.rm = TRUE),
        list(
            penguins$body_mass_g,
            penguins$bill_depth_mm,
            use = "pairwise.complete.obs"
        ),
        list(
            formula = body_mass_g ~ bill_depth_mm + sex,
            data = penguins,
            na.action = "na.omit"
        )
    )

    fun_iterator <- tibble(
        f = funs,
        fa = fun_args
    )
}

analyze_penguins <- function(include = c("mean", "cor", "lm")) {
    #this is all the same as previously
    funs <- c("mean", "cor", "lm")

    fun_args <- list(
        list(penguins$body_mass_g, na.rm = TRUE),
        list(
            penguins$body_mass_g,
            penguins$bill_depth_mm,
            use = "pairwise.complete.obs"
        ),
        list(
            formula = body_mass_g ~ bill_depth_mm + sex,
            data = penguins,
            na.action = "na.omit"
        )
    )

    fun_iterator <- tibble(
        f = funs,
        fa = fun_args
    )

    # filter to only a subset of these functions that we've asked for in the wrapper args
    fun_iterator <- fun_iterator[fun_iterator$f %in% include, ]
    
    #execute these functions
    pmap(fun_iterator, ~do.call(..1, ..2))
}

analyze_penguins("mean")

[[1]]
[1] 4201.754

analyze_penguins(c("mean", "cor"))

[[1]]
[1] 4201.754

[[2]]
[1] -0.4719156

broom::glance(analyze_penguins("lm")[[1]])

# A tibble: 1 × 12
  r.squared adj.r.squared sigma statistic  p.value    df logLik   AIC   BIC
      <dbl>         <dbl> <dbl>     <dbl>    <dbl> <dbl>  <dbl> <dbl> <dbl>
1     0.642         0.640  483.      296. 2.34e-74     2 -2529. 5066. 5081.
# … with 3 more variables: deviance <dbl>, df.residual <int>, nobs <int>

Loading Data

For this project, I’m going to use some ultramarathon data from #TidyTuesday a few weeks ago. So the first step is loading that in and setting some plot options and whatnot.

library(tidyverse)
library(eemisc) #for ggplot theme
library(harrypotter) #for colors
library(janitor)
library(torch)


herm <- harrypotter::hp(n = 1, option = "HermioneGranger")

opts <- options(
  ggplot2.discrete.fill = list(
    harrypotter::hp(n = 2, option = "HermioneGranger"),
    harrypotter::hp(n = 3, option = "HermioneGranger"),
    harrypotter::hp(n = 7, option = "Always")
  )
)

theme_set(theme_ee())

ultra_rankings <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-10-26/ultra_rankings.csv')
race <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2021/2021-10-26/race.csv')

Then, let’s take a little peeksie at the data. The first dataframe, ultra_rankings, provides data for each runner in each race.

glimpse(ultra_rankings)

Rows: 137,803
Columns: 8
$ race_year_id    <dbl> 68140, 68140, 68140, 68140, 68140, 68140, 68140, 68140…
$ rank            <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, NA, NA, NA,…
$ runner          <chr> "VERHEUL Jasper", "MOULDING JON", "RICHARDSON Phill", …
$ time            <chr> "26H 35M 25S", "27H 0M 29S", "28H 49M 7S", "30H 53M 37…
$ age             <dbl> 30, 43, 38, 55, 48, 31, 55, 40, 47, 29, 48, 47, 52, 49…
$ gender          <chr> "M", "M", "M", "W", "W", "M", "W", "W", "M", "M", "M",…
$ nationality     <chr> "GBR", "GBR", "GBR", "GBR", "GBR", "GBR", "GBR", "GBR"…
$ time_in_seconds <dbl> 95725, 97229, 103747, 111217, 117981, 118000, 120601, …

Let’s also peek at the race data, which provides data about races:

glimpse(race)

Rows: 1,207
Columns: 13
$ race_year_id   <dbl> 68140, 72496, 69855, 67856, 70469, 66887, 67851, 68241,…
$ event          <chr> "Peak District Ultras", "UTMB®", "Grand Raid des Pyréné…
$ race           <chr> "Millstone 100", "UTMB®", "Ultra Tour 160", "PERSENK UL…
$ city           <chr> "Castleton", "Chamonix", "vielle-Aure", "Asenovgrad", "…
$ country        <chr> "United Kingdom", "France", "France", "Bulgaria", "Turk…
$ date           <date> 2021-09-03, 2021-08-27, 2021-08-20, 2021-08-20, 2021-0…
$ start_time     <time> 19:00:00, 17:00:00, 05:00:00, 18:00:00, 18:00:00, 17:0…
$ participation  <chr> "solo", "Solo", "solo", "solo", "solo", "solo", "solo",…
$ distance       <dbl> 166.9, 170.7, 167.0, 164.0, 159.9, 159.9, 163.8, 163.9,…
$ elevation_gain <dbl> 4520, 9930, 9980, 7490, 100, 9850, 5460, 4630, 6410, 31…
$ elevation_loss <dbl> -4520, -9930, -9980, -7500, -100, -9850, -5460, -4660, …
$ aid_stations   <dbl> 10, 11, 13, 13, 12, 15, 5, 8, 13, 23, 13, 5, 12, 15, 0,…
$ participants   <dbl> 150, 2300, 600, 150, 0, 300, 0, 200, 120, 100, 300, 50,…

Exploring Data

Again, I’m skipping this, but you should definitely do some exploration before building a model. :)

Modeling with Torch

So, the idea here is to use {torch} to “manually” (sort of) estimate a multiple linear regression model. The first thing I’m going to do is refine a dataframe to use in the model. There are lots of possibilities here, but I’m going to choose to estimate model that predicts the winning time of a race from the race distance, the total elevation gain, and the total elevation loss. So let’s and filter our data down to what we’ll actually use in our model.

ultra_mod_df <- ultra_rankings %>%
  left_join(race, by = "race_year_id") %>%
  filter(rank == 1) %>%
  select(time_in_seconds, distance, elevation_gain, elevation_loss)

Next, I’m going to drop any observations with missing values on any of these variables. I’m also going to normalize the variables, because my understanding is that this matters quite a bit for optimizing via gradient descent (and it’s also good practice for linear models in general).

ultra_normed <- ultra_mod_df %>%
  drop_na() %>%
  mutate(across(1:4, function(x) {(mean(x) - x)/sd(x)}))

#initializing dataset

ultra_dataset <- dataset(
  
  name = "ultra_dataset",
  
  initialize = function(df) {
    self$x <- df %>%
      select(-time_in_seconds) %>%
      as.matrix() %>%
      torch_tensor()
    
    self$y <- torch_tensor(df$time_in_seconds)
    
  },
    
    .getitem = function(i) {
      x <- self$x[i, ]
      y <- self$y[i]
      
      list(x, y)
    },
    
    .length = function() {
      self$y$size()[[1]]
    }
)

ultra_tensor_df <- ultra_dataset(ultra_normed)


ultra_len <- ultra_tensor_df$.length()
#note that this is the same as: length(ultra_tensor_df)

ultra_len

[1] 1237

ultra_tensor_df$.getitem(1)

[[1]]
torch_tensor
-0.3624
 0.2811
-0.2866
[ CPUFloatType{3} ]

[[2]]
torch_tensor
-0.809365
[ CPUFloatType{} ]

#note that 1 here refers to the index of the item

set.seed(0408)
train_ids <- sample(1:ultra_len, floor(.8*ultra_len))
valid_ids <- setdiff(1:ultra_len, train_ids)

trn <- ultra_dataset(ultra_normed[train_ids, ])
vld <- ultra_dataset(ultra_normed[valid_ids, ])

lin_mod <- function(x, w, b) {
  torch_mm(w, x) + b
}

#defining parameters
num_feats <- 3

w <- torch_ones(c(1, num_feats))
b <- torch_zeros(1)

aa <- trn$.getitem(1:10)

aa_x <- torch_transpose(aa[[1]], 1, 2)

t_out <- lin_mod(aa_x, w, b)

t_out

torch_tensor
-0.2315 -0.4256 -0.7237 -0.2182 -0.2279 -0.2015 -0.2869 -0.2124 -0.5832 -0.2300
[ CPUFloatType{1,10} ]

#recreate our parameters with the requires_grad attribute
w <- torch_zeros(c(1, num_feats), requires_grad = TRUE)
b <- torch_zeros(1, requires_grad = TRUE)

#put the parameters in a list
params <- list(w, b)

#define our optimizer
optimizer <- optim_adam(params, lr = .1)

#create lists to track values during the training
loss_tracking <- list()
params_tracking <- list()
vld_loss_tracking <- list()

#training loop
for (i in 1:1000) {
  
  optimizer$zero_grad()
  
  x <- torch_transpose(trn$x, 1, 2)
  vld_x <- torch_transpose(vld$x, 1, 2)
  
  preds <- lin_mod(x, w, b)
  vld_preds <- lin_mod(vld_x, w, b)
  
  preds <- torch_squeeze(preds)
  vld_preds <- torch_squeeze(vld_preds)
  
  current_loss <- nnf_mse_loss(preds, trn$y)
  vld_loss <- nnf_mse_loss(vld_preds, vld$y)
  
  loss_tracking[i] <- current_loss$item()
  vld_loss_tracking[i] <- vld_loss$item()
  params_tracking[i] <- list(c(as.numeric(params[[1]]), as.numeric(params[[2]])))
  
  current_loss$backward()
  
  optimizer$step()
  
}