The One With All The Quantifiable Friendships Continued

Intro

When I first started blogging I decided to collect some data about the TV Show Friends. I ended up writing about “the frequency of characters’ shared plotlines, or character groupings, throughout the span of the entire show.” However, I collected this data by manually going through the episodes and recording the relevant groupings. Now, I return to this topic with new data obtained by web scraping the television show scripts. Giora Simchoni just recently put out a post on this and I am seeking to use his structure for scraping and go from there. In short, I am using Giora’s data and making new visuals from his work.

Data Scraping

First, I scrape the data using Giora’s code verbatim in order to yield personLines_df. Once I have followed Giora’s code, I can manipulate the resulting dataframe in order to make my own visuals! Quick note here: Episodes 199 (Season 9, ep 15) and 203 (Season 9, ep 19) are missing from this dataset. (So, this gives data on 226 episodes. Two part episodes are included as one since they have a single script.)

Lines spoken over the course of the show

First, I make my own version of the bar chart that Giora has in his blog post, illustrating the total number of lines for each of the 6 main characters.

#in eps 32-33 abbreviations are used for some of the characters
#let's standardize
personLines_df$person[personLines_df$person == "chan" | personLines_df$person == "chandler "] <- "chandler"
personLines_df$person[personLines_df$person == "phoe" | personLines_df$person == "phoebe "] <- "phoebe"
personLines_df$person[personLines_df$person == "mnca" | personLines_df$person == "monica "] <- "monica"
personLines_df$person[personLines_df$person == "rach" | personLines_df$person == "rachel "] <- "rachel"
#make all other characters "other"
personLines_df$person[!(personLines_df$person == "monica" | personLines_df$person == "rachel" | personLines_df$person == "joey" |personLines_df$person == "phoebe" |personLines_df$person == "ross" |personLines_df$person == "chandler" )] <- "other"
#get dataframe with totals
total_lines <- personLines_df %>%
  count(person) %>%
  arrange(-n)

Now, I can plot my barchart. So, first, I define my custom theme, as per usual.

#Load more libraries
library(ggplot2);library(ggrepel); library(extrafont); library(ggthemes);library(reshape);library(grid);
library(scales);library(RColorBrewer);library(gridExtra)
#Define theme for my visuals
my_theme <- function() {
  # Define colors for the chart
  palette <- brewer.pal("Greys", n=9)
  color.background = palette[2]
  color.grid.major = palette[4]
  color.panel = palette[3]
  color.axis.text = palette[9]
  color.axis.title = palette[9]
  color.title = palette[9]
  # Create basic construction of chart
  theme_bw(base_size=9, base_family="Friends") + 
  #Seems like a good time to use the Friends-TV-show-specific font  
  # Set the entire chart region to a light gray color
  theme(panel.background=element_rect(fill=color.panel, color=color.background)) +
  theme(plot.background=element_rect(fill=color.background, color=color.background)) +
  theme(panel.border=element_rect(color=color.background)) +
  # Format grid
  theme(panel.grid.major=element_line(color=color.grid.major,size=.25)) +
  theme(panel.grid.minor=element_blank()) +
  theme(axis.ticks=element_blank()) +
  # Format legend
  theme(legend.position="right") +
  theme(legend.background = element_rect(fill=color.background)) +
  theme(legend.text = element_text(size=7,color=color.axis.title)) + 
  theme(legend.title = element_text(size=0,face="bold", color=color.axis.title)) + 
  
  #Format facet labels
  theme(strip.text.x = element_text(size = 8, face="bold"))+
  # Format title and axes labels these and tick marks
  theme(plot.title=element_text(color=color.title, size=18, face="bold", hjust=0)) +
  theme(axis.text.x=element_text(size=6,color=color.axis.text)) +
  theme(axis.text.y=element_text(size=6,color=color.axis.text)) +
  theme(axis.title.x=element_text(size=8,color=color.axis.title, vjust=-1, face="bold")) +
  theme(axis.title.y=element_text(size=8,color=color.axis.title, vjust=1.8, face="bold")) +
  #Format title and facet_wrap title
  theme(strip.text = element_text(size=8), plot.title = element_text(size = 10, face = "bold", colour = "black", vjust = 1, hjust=0.5))+
    
  # Plot margins
  theme(plot.margin = unit(c(.2, .2, .2, .2), "cm"))
}

Then I plot the barchart.

ggplot(data=total_lines, aes(x=person, y=n, group=person, color=person, fill=person, label=n)) + scale_fill_brewer(palette = "Set3") + 
  scale_color_brewer(palette = "Set3") +
  geom_bar(stat="identity")+
  my_theme()+ theme(legend.position="none")+ theme(plot.title = element_text( hjust = 0))+theme(axis.text.x=element_text(size=9))+
  geom_text(size = 2, color="black", family="Friends", position = position_stack(vjust = 0.5))+
  labs(x="", y="")+
  ggtitle("The One With All The Quantifiable Friendships", subtitle="Total Lines Spoken by Each Character and Others")

ggsave("total.png", width=7, height=4.5, dpi=900)

Episode by episode

I want to visualize the lines spoken by the 6 main characters and others over the course of the show. Giora does this in a few aggregated ways but I am now going to show this epsiode by episode. So, I first make some manipulations to get a count of lines for each character and episode pairing.

episodes_df$ID <- as.numeric(rownames(episodes_df))
  
ep_person_lines <- personLines_df %>%
  count(person, episodeTitle, episodeNum, season) 
epi<-episodes_df[c("ID", "episodeTitle")]
ep_lines<-merge(epi, ep_person_lines, by="episodeTitle")
ep_lines

Now I have the data in a form I can graph, so I call ggplot to make some graphs. I went through a number of attempts to get my final product. First, I simply showed the time series of lines spoken for each character all on the same graph.

ggplot(data=ep_lines, aes(x=ID, y=n, group=person, color=person)) + scale_fill_brewer(palette = "Set3") + 
  scale_color_brewer(palette = "Set3") +
  geom_line(size=0.5, alpha=1)+
  my_theme() +theme(plot.title = element_text( hjust = 0))+
  labs(x="Episode Number", y="")+
  
  ggtitle("The One With All The Quantifiable Friendships", subtitle = "Lines Spoken Over All The Episodes")

NA

The above is very hard to get anything out of visually, so I had an idea based on previous work I did on demographics in the science PhD’s. So, I try making a stacked area graph.

p<-ggplot(data=ep_lines, aes(x=ID, y=n, group=person, fill=person, color=person))+ 
  scale_fill_brewer(palette = "Set3") + 
  scale_color_brewer(palette = "Set3") +
  my_theme()+theme(plot.title = element_text( hjust = 0))+
  labs(x="Episode Number", y="")+
  ggtitle("The One With All The Quantifiable Friendships", subtitle = "Lines Spoken Over All The Episodes")
#Stacked area graph
p+geom_area(aes(fill=person), position='stack')

I make a nightingale graph also (for fun).

#Nightingale Graph
p+geom_area(aes(fill=person), position='stack')+coord_polar()+ theme(plot.title = element_text(size = 8))

However, the differences in lines for each character aren’t super visible still due to the major differences in total episode lines–mainly due to the fact that there are single scripts for two part episodes, which messes with the scale. For this season, it’s worth looking into percentages of lines for characters by episode instead.

# Make percentage figures
# First calculate total lines for each ep
lines_total<-ep_lines %>%
  group_by(ID) %>%
  summarise(n=sum(n))
lines_new<-merge(ep_lines, lines_total, by=c("ID"))
lines_new$perc<-lines_new$n.x/lines_new$n.y

Time for plotting…

p<-ggplot(data=lines_new, aes(x=ID, y=perc, group=person, fill=person, color=person)) + 
  scale_fill_brewer(palette = "Set3") + 
  scale_color_brewer(palette = "Set3") +
  my_theme()+theme(plot.title = element_text( hjust = 0))+
  labs(x="Episode Number", y="")+
  scale_y_continuous(labels = percent_format())+
  ggtitle("The One With All The Quantifiable Friendships", subtitle = "Percentage of Lines Spoken Across The Episodes")
#Stacked area graph
p+geom_area(aes(fill=person), position='stack')

ggsave("lines1.png", width=7, height=4.5, dpi=900)

Tell me the above doesn’t look just like Rachel’s English Trifle! Layer on layer on layer…

#Nightingale graphs
p+geom_bar(stat="identity", aes(fill=person), position='stack')+ 
  coord_polar()+
  theme(plot.title = element_text(size=8.8))

ggsave("lines2.png", width=7, height=4.5, dpi=900)

The two visible gaps in that graph are due to missing observations for two episodes.

#Line
p+geom_line(size=0.5)

ggsave("lines3.png", width=7, height=4.5, dpi=900)

This last graph is useful for seeing outlier episodes in terms of who was abnormally overserved or underserved by the writing of a particular episode. While no one ever spoke the majority of the lines in the group for an episode, there are a few times people come close. Similarly, there are a few times characters come close to not speaking at all.

lines_new <- lines_new %>%
  arrange(-perc) 
lines_new

The highest percentage of lines in an episode is Chandler for The One with Christmas in Tulsa. Makes sense. Second place is Joey in The One With Joey’s Interview.

lines_new <- lines_new %>%
  arrange(perc) 
head(lines_new, 5)

The most gang-driven episode is The One The Last Night, as only 1 line in that episode is spoken by someone outside the 6 main characters. The above table shows the 5 episodes that have the highest percentage of lines spoken by the gang.

Maybe we want to forget about the others in this post and just focus on the main 6 characters. If we do that then we get a picture of how central or tangential characters were to specific episodes. Ie, Monica only speaks ~1.5% of lines in The One With The Ring and same for Ross in The One With The Cuffs.

#take out other options
lines_new_no_other<-lines_new[!(lines_new$person=="other"),]
lines_new_no_other <- lines_new_no_other %>%
  arrange(perc) 
lines_new_no_other

We can also look at the episodes certain characters are most dominant in. See below.

lines_new_no_other <- lines_new_no_other %>%
  arrange(-perc) 
lines_new_no_other

Gender and lines

What if I group the women and men together and then look at the visuals…would certain periods of time be more male/female dominated?

lines_new_no_other$gender[lines_new_no_other$person == "rachel" |lines_new_no_other$person == "phoebe" |lines_new_no_other$person == "monica" ] <- "Women"
lines_new_no_other$gender[ lines_new_no_other$person == "joey" |lines_new_no_other$person == "chandler" |lines_new_no_other$person == "ross" ] <- "Men"
lines_gender<-lines_new_no_other[c("episodeTitle", "episodeNum", "season", "gender", "n.x", "ID")]
lines_gender_final<-lines_gender %>%
  group_by(gender, ID) %>%
  summarise(n=sum(n.x))
l2<-lines_gender %>%
  group_by(ID) %>%
  summarise(tot=sum(n.x))
gender<-merge(l2, lines_gender_final, by="ID")
gender<-merge(gender, epi, by="ID")
gender$perc<-gender$n/gender$tot

Now, I plot the balance over time.

p<-ggplot(data=gender, aes(x=ID, y=perc, group=gender, fill=gender, color=gender)) + 
  scale_fill_brewer(palette = "Set2") + 
  scale_color_brewer(palette = "Set2") +
  my_theme()+theme(plot.title = element_text( hjust = 0))+
  labs(x="Episode Number", y="")+
  scale_y_continuous(labels = percent_format())+
  ggtitle("The One With All The Quantifiable Friendships", subtitle = "Percentage of Lines Spoken Across the Gang By Gender")
#Stacked area graph
p+geom_area(aes(fill=gender), position='stack')

ggsave("gender1.png", width=7, height=4.5, dpi=900)

p+geom_line(size=0.5)

ggsave("gender2.png", width=7, height=4.5, dpi=900)

The above shows there are three episodes that stand-out in terms of giving one gender of the gang more lines than the other percentage-wise

gender <- gender %>%
  arrange(-perc) 
gender

They are: The One Where Chandler Crosses A Line (Chandler kisses Joey’s girlfriend and confrontation ensues), The One With Joey’s Interview, and The One With Mac and C.H.E.E.S.E..

Two episodes are actually exactly 50-50: The One Where Rachel Finds Out and The One With The Thanksgiving Flashbacks!

How many are >50% men speaking?

gender_new<-gender[gender$gender=="Men",]
gender_new<-gender_new[gender_new$perc > 0.50,]
nrow(gender_new)

[1] 118

So 118/226 (52.2%) of the available episodes with >50% lines given to men in the group.

Who mentions whom?

Here I am adapting Giora’s code. The change I’m making is to include nicknames like Mon, Rach, Pheebs, and Joe.

library(dplyr); library(stringr); library(purrr)
m <- personLines_df %>%
  filter(person %in% c("chandler", "ross", "joey", "monica", "rachel", "phoebe")) %>%
  mutate(chandler = map_int(line, str_count, "chandler"),
         ross = map_int(line, str_count, "ross"),
         joey = map_int(line, str_count, "joey"),
         joe = map_int(line, str_count, "joe "),
         monica = map_int(line, str_count, "monica"),
         mon = map_int(line, str_count, "mon "),
         rachel = map_int(line, str_count, "rachel"),
         rach = map_int(line, str_count, "rach "),
         phoebe = map_int(line, str_count, "phoebe"),
         pheebs = map_int(line, str_count, "pheebs")) %>%
  select(person, chandler, joey, joe, monica, mon, phoebe, pheebs, rachel, rach, ross) %>%
  group_by(person) %>%
  summarise_each(funs(sum))
m

Look how much the characters say Pheebs! That’s by far the most important nickname to add in.

m$monica<-m$monica+m$mon
m$phoebe<-m$pheebs+m$phoebe
m$rachel<-m$rachel+m$rach
m$joey<-m$joe+m$joey
m<-m[,c("person", "chandler", "joey", "monica", "phoebe", "rachel", "ross")]
m

So the above is our updated dataframe with nicknames included. Now, to graph, I want to mutate this a bit…

library(reshape)
m<-as.data.frame(m)
mnew <- reshape(m, varying = c("chandler", "monica","ross", "rachel","phoebe", "joey"), 
                     v.names = "count",
                     timevar = "friend_mention", 
                     times = c("chandler", "monica","ross", "rachel","phoebe", "joey"), 
                     direction = "long")
mnew<-mnew[c("person", "friend_mention", "count")]

Now, I use faceting to graph my updated version of Giora’s collected data.

library(ggplot2)
ggplot(data=mnew, aes(x=friend_mention, y=count, group=friend_mention,
                      fill=friend_mention, label=count)) + 
  scale_fill_brewer(palette = "Set3", guide = guide_legend(title = "Friend Mentioned")) + 
  geom_bar(stat="identity")+
  facet_wrap(~person, ncol=3)+
  my_theme()+ theme(plot.title = element_text( hjust = 0))+theme(axis.text.x=element_text(size=0))+
  geom_text(size = 1, color="black", family="Friends", position = position_stack(vjust = 0.5))+
  labs(x="", y="")+
  ggtitle("The One With All The Quantifiable Friendships", subtitle="Mentions by Friends... of Friends")+ 
  theme(legend.title = element_text(size=6,face="bold"))

ggsave("mentions.png", width=7, height=4.5, dpi=900)

Wow, Rachel likes saying Ross.

Alright, that’s a wrap!

Screen goes dark and…

Executive Producer: Alex Albright