What's the most successful Broadway show of all time?

Identify missing values

Don’t blindly trust data you didn’t collect yourself. A lot of the time, a quick look will shine a light on quirks that could mess up your analysis down the line and this data isn’t any different. I took that quick look and identified a few circumstances to change values to NA (missing values):

• Measures like weekly_gross and seats_sold sometimes have values of zero for weeks where there were no performances
• These measures also sometimes have zeros for weeks when there were performances – I checked this out and it seems to be data missing from the source
• top_ticket_price sometimes has values in weeks with no performances

grosses_fixed_missing <- grosses_raw %>%
  # Turn metrics into missing values if there were no shows
  # OR if metrics have a value of zero
  mutate_at(vars(weekly_gross:pct_capacity),
            ~ ifelse(performances + previews == 0 | . == 0, NA, .))

Changing these to missing values will keep us from accidentally incorporating zeros into, say, calculating an average. If we did include the zeros, they could erroneously skew our numbers downward. (There is the possibility that the data showing weeks without any performances is wrong itself, but based on some spot-checking and research, I’m comfortable making the assumption the we’re just dealing with missing or wonky data from the source.)
 

Add week of show’s run

Remember when I said this one’s tricky? There are two reasons why. To illustrate the first, let’s look at Les Misérables. Here’s a quick graph of seats sold by week (with a bonus illustration of using scale_x_date() to adjust date axis labels).
 

grosses_fixed_missing %>%
  filter(show == "Les Miserables") %>%
  ggplot(aes(week_ending, seats_sold)) +
  geom_col() +
  scale_x_date(date_breaks = "5 years", date_labels = "%Y") +
  labs(title = "Two-four-six-oh-what??",
       subtitle = "Seats sold by week for Les Misérables")

Why are there two big gaps? Well, Les Misérables, like many Broadway shows, has had multiple runs – an original run and two revivals in this case:

1. 1987-2003 (Original)
2. 2006-2008 (Revival #1)
3. 2014-2016 (Revival #2)

But they all have the same show name in our data. So when figuring out which week of a run a show is in, we can’t just count the number of weeks since it first showed up in our data. We also need to figure out whether a show has started a fresh new run. I don’t want to look that up manually for – *checks notes* – 1,122 shows, so we need a heuristic to do that.

I’m going to assume that the first time a show appears is its first run. (This isn’t technically true for shows that opened and closed before our dataset starts in 1985, like The King and I, but it’s close enough for our purposes.) I’m also going to assume that a show has started a new run if it has been more than 90 days – about 12 weeks – since the previous time it appeared in the data. I chose 90 days because it’s long enough to account for shows that shut down briefly, which they sometimes do for things like moving to a new theatre. It’s also short enough that it won’t accidentally consider seasonal productions, which might appear in consecutive years, the same run.

Fortunately, we can do that in a few lines of code:

1. Grouping by show, for each observation, check whether it is the first time it appears OR whether it is more than 90 days since the previous week in the data. This will return a logical value TRUE or FALSE, which indicate the first week of a new run.
2. Use the cumulative sum function cumsum() to determine the run number. R coerces TRUE to one and FALSE to zero, so cumsum() acts as a counter that only increases when it hits a new run’s first week (which we calculated in step 1).
3. Group by show and run number and use row_number() which counts the rows as they appear in the data. Since each show and run is its own group, you get the week of the run!

grosses_clean_temp <- grosses_fixed_missing %>%
  group_by(show) %>%
  arrange(week_ending) %>%
  mutate(run_number = cumsum(row_number() == 1 |
                               week_ending - lag(week_ending) > 90)) %>%
  group_by(show, run_number) %>%
  mutate(week_of_run = row_number()) %>%
  ungroup()

But remember when I said there were two reasons this one’s tricky? Here’s the second reason. The shows that appear in the very first week of our dataset, June 1985, had already been running for some period of time. I don’t want to say that the first week of Cats was in 1985 when it was actually in 1982. Fortunately, there are only 19 shows where this is the case, so this time we can look it up manually. I searched the Internet Broadway Database for starting dates for each of these shows and added them as a separate file in the data’s GitHub repository.

To calculate the actual week of a show’s run – which we only need to do for shows that appear in the very first week of our dataset – we can write a function to calculate the number of weeks between the start date I looked up and the beginning of the dataset.

pre_1985_starts <- readr::read_csv("https://raw.githubusercontent.com/tacookson/data/master/broadway-grosses/pre-1985-starts.csv")

calculate_weeks_since_start <- function(x) {
  as.integer(pmax(1, difftime("1985-06-09", x, units = "weeks")))
}

pre_1985_starts_calculated <- grosses_clean_temp %>%
  group_by(show, run_number) %>%
  filter(min(week_ending) == "1985-06-09") %>%
  ungroup() %>%
  select(week_ending, show) %>%
  left_join(pre_1985_starts, by = "show") %>%
  group_by(show) %>%
  mutate(week_of_run_originals = calculate_weeks_since_start(start_date) + row_number()) %>%
  ungroup() %>%
  select(week_ending, show, week_of_run_originals)

grosses_clean <- grosses_clean_temp %>%
  left_join(pre_1985_starts_calculated, by = c("show", "week_ending")) %>%
  mutate(week_of_run = coalesce(week_of_run_originals, week_of_run)) %>%
  select(-week_of_run_originals)

Convert nominal to real dollars

Our final cleaning step is more straightforward. We need to match our (monthly) CPI values to our (weekly) grosses data and convert all the dollars to the same period of time – I’m going to use January 2020. To do that, let’s first convert the CPI value to multiplier that will give us Jan 2020 dollars. We do that by taking the Jan 2020 value and dividing it by the CPI value for every other month.

cpi <- cpi_raw %>%
  mutate(jan_2020_dollars = cpi[year_month == "2020-01-01"] / cpi)

So, if we want, say, Nov 1988 dollars in their Jan 2020 equivalent, we just use our newly-calculated multiplier. ($100 in Nov 1988 is equivalent to about $212 in Jan 2020).

Now we need to get our weekly grosses data to be monthly. We can use the {lubridate} package’s floor_date() function, which can round dates down to the first of the month. Then, we join the cpi data based on month and multiply all the dollar figures by our Jan 2020 mulitiplier.

real_grosses <- grosses_clean %>%
  mutate(year_month = floor_date(week_ending, unit = "month")) %>%
  left_join(cpi, by = "year_month") %>%
  mutate_at(
    vars(
      weekly_gross_overall,
      weekly_gross,
      potential_gross,
      avg_ticket_price,
      top_ticket_price
    ),
    ~ . * jan_2020_dollars
  ) %>%
  select(-year_month:-jan_2020_dollars)

Ahhhh, feels good to have nice, clean data. We can finally start answering our questions!
 

Top ticket prices

Let’s switch to the consumer side of things. I’ve been to a few Broadway shows with decent, but by no means top-tier, seats. The tickets worth the price, but they were definitely expensive. What if I were rich, though, and I was in the market for the best tickets money could buy? How much would that cost me?
 

top_tickets <- real_grosses %>%
  mutate(year = year(week_ending)) %>%
  filter(year >= 1996,
         !is.na(top_ticket_price)) %>%
  group_by(year, show) %>%
  summarise(avg_ticket_price = mean(avg_ticket_price, na.rm = TRUE),
            avg_top_ticket_price = mean(top_ticket_price, na.rm = TRUE)) %>%
  mutate(annotated = (show == "The Producers" & between(year, 2002, 2003)) | show == "Manilow on Broadway") %>%
  ungroup() %>%
  mutate(is_hamilton = show == "Hamilton")

## `summarise()` regrouping output by 'year' (override with `.groups` argument)

avg_top_tickets_by_year <- top_tickets %>%
  group_by(year) %>%
  summarise(avg_top_ticket_price = mean(avg_top_ticket_price))

## `summarise()` ungrouping output (override with `.groups` argument)

top_tickets %>%
  ggplot(aes(year, avg_top_ticket_price)) +
  geom_jitter(data = top_tickets %>% filter(!annotated, !is_hamilton),
              position = position_jitter(width = 0.2),
              shape = 19,
              size = 2,
              col = "grey80",
              alpha = 0.5) +
  geom_point(data = top_tickets %>% filter(annotated),
             size = 2,
             col = "black") +
  geom_point(data = top_tickets %>% filter(is_hamilton),
             col = "#d1495b",
             size = 4) +
  geom_line(data = avg_top_tickets_by_year,
            size = 1.5,
            col = "darkblue") +
  scale_x_continuous(breaks = seq(1996, 2020, 2)) +
  scale_y_continuous(breaks = seq(0, 1000, 100),
                     labels = dollar_format()) +
  annotate("text", x = 2018.5, y = 920, family = "Bahnschrift", label = "Hamilton", col = "#d1495b") +
  annotate("curve", x = 2011, y = 775, xend = 2012.95, yend = 795, curvature = 0.3, arrow = arrow(length = unit(2, "mm"))) +
  annotate("text", x = 2010.9, y = 780, family = "Bahnschrift", label = "Manilow on Broadway", hjust = "right") +
  annotate("curve", x = 2003.5, y = 590, xend = 2002.05, yend = 655, curvature = -0.3, arrow = arrow(length = unit(2, "mm"))) +
  annotate("curve", x = 2003.5, y = 590, xend = 2003, yend = 655, curvature = -0.3, arrow = arrow(length = unit(2, "mm"))) +
  annotate("text", x = 2003.5, y = 590, family = "Bahnschrift", label = "The Producers", hjust = "left") +
  labs(title = "Premium Broadway experiences have become much pricier",
       caption = paste("Source: Playbill",
                       "Points are average top ticket price per show",
                       "Blue line is average top ticket price for all shows",
                       sep = "\n"),
       subtitle = "(Especially if you want to see Hamilton)",
       x = "",
       y = "") +
  theme(text = element_text(family = "Bahnschrift"),
        panel.grid.minor = element_blank())

I have so many observations. First, Hamilton’s prices are unprecedented. For four straight years, the average top ticket price has been over $800! The only other shows that have even come close tend to be short-run musicians or comedians, like Manilow on Broadway in 2013 or Dave Chapelle on Broadway in 2019. It does look like the Hamilton hype might be easing – top ticket prices were down slightly in 2019 and down a slight bit more for the first part of 2020.

Second, was The Producers the Hamilton of its time? I have no trouble believing it. For part of its run, The Producers starred Matthew Broderick and Nathan Lane! Be still, my heart!

Third, top ticket prices jumped in 2006, from an average of $150 to $250 (in Jan 2020 dollars). What happened here? Did theatres start offering more bells and whistles with premium tickets and start charging more accordingly? Maybe there was simply a surge in demand that drove the prices up? Maybe there’s a separate explanation or a combination of both these things.
 

Average ticket prices

I’m not rich, so I’m more likely to be paying average ticket prices than top ticket prices. How have those changed?
 

avg_tickets <- real_grosses %>%
  mutate(year = year(week_ending)) %>%
  filter(!is.na(avg_ticket_price)) %>%
  group_by(year, show) %>%
  summarise(avg_ticket_price = mean(avg_ticket_price, na.rm = TRUE),
            performances = sum(performances)) %>%
  ungroup()

## `summarise()` regrouping output by 'year' (override with `.groups` argument)

avg_tickets_by_year <- avg_tickets %>%
  group_by(year) %>%
  summarise(avg_ticket_price = weighted.mean(avg_ticket_price, w = performances))

## `summarise()` ungrouping output (override with `.groups` argument)

avg_tickets %>%
  ggplot(aes(year, avg_ticket_price)) +
  geom_jitter(position = position_jitter(width = 0.2),
              shape = 19,
              size = 2,
              col = "grey80",
              alpha = 0.5) +
  geom_line(data = avg_tickets_by_year,
            size = 1.5,
            col = "darkblue") +
  scale_x_continuous(breaks = seq(1984, 2020, 2)) +
  scale_y_continuous(labels = dollar_format()) +
  labs(title = "The cost of a Broadway experience has doubled in the past 35 years",
       subtitle = "Inflation-adjusted average ticket prices (Jan. 2020 dollars)",
       caption = paste("Source: Playbill",
                       "Points are average ticket price per show",
                       "Blue line is average ticket price for all shows",
                       sep = "\n"),
       x = "",
       y = "") +
  theme(text = element_text(family = "Bahnschrift"),
        panel.grid.minor = element_blank())

This graph is less dramatic than the one for top ticket prices, but it’s still interesting. First, inflation-adjusted ticket prices have doubled in the past 35 years. The average ticket in 1985 would cost $65, but in 2020 it would be $119. Keep in mind, these are inflation-adjusted dollars, so it really has gotten quite a bit more expensive to see a Broadway show.

Second, we start seeing more high-priced outliers starting around 2010. (Though there is a notable outlier in 1986, The Life Adventures of Nicholas Nickleby.) Does this mark the start of the era of supershows – must-see shows that command much higher prices?

Third, we have to talk about those outliers in 2017 and 2018. Any guesses on what show it is? I would understand if your guess was Hamilton, but even though Alexander Hamilton was young, scrappy, and hungry, he wasn’t Born to Run. That’s right, the highest average ticket prices were to see The Boss himself, Bruce Springsteen!