In this document we will briefly practice working with different
vector types. Follow the instructions in the comments of each code
chunk.
Exercise 1 - Creating and examining vectors
# In a recent coding competition, Liz came first, Alex came second
# and Jiena came third.
# here is a vector with their names
name <- c("Alex", "Jiena", "Liz")
# Check that this vector is a character vector of length 3
str(name)
## chr [1:3] "Alex" "Jiena" "Liz"
# Create a corresponding numeric vector with each person's position.
position <- c(2, 3, 1)
# Check that your vector is a numeric vector of length three.
str(position)
## num [1:3] 2 3 1
Exercise 2 - Converting vectors to factors and ordered factors
# Convert the 'name' character vector to a factor vector called 'name_factor'.
# Check that the conversion succeeded.
name_factor <- as.factor(name)
str(name_factor)
## Factor w/ 3 levels "Alex","Jiena",..: 1 2 3
# Convert your 'name' character vector to an ordered factor vector
# in increasing position order. Check that the conversion succeeded.
name_ordered <- ordered(name, levels = c("Jiena", "Alex", "Liz"))
str(name_ordered)
## Ord.factor w/ 3 levels "Jiena"<"Alex"<..: 2 1 3
# EXTENSION: Use a function to display the vector in order of position (highest to lowest)?
sort(name_ordered, decreasing = TRUE)
## [1] Liz Alex Jiena
## Levels: Jiena < Alex < Liz
Exercise 3 - Loading and inspecting dataframes
# Here is a URL for on online csv of data about charity donations
url <- "https://peopleanalytics-regression-book.org/data/charity_donation.csv"
# Download this into a dataframe with a name of your choice
charity_data <- read.csv(url)
# Inspect the dataframe to find out how many rows of data there are
# and what the columns names and data types are
str(charity_data)
## 'data.frame': 354 obs. of 8 variables:
## $ n_donations : int 2 3 3 2 6 8 3 10 5 3 ...
## $ total_donations: int 310 1200 1200 760 2540 3440 1200 4330 2100 1200 ...
## $ time_donating : int 27 22 37 19 37 35 36 42 27 34 ...
## $ recent_donation: int 0 0 1 1 0 1 0 0 1 0 ...
## $ last_donation : int 4 6 11 1 11 1 4 1 6 4 ...
## $ gender : chr "M" "M" "M" "F" ...
## $ reside : chr "Urban Domestic" "Rural Domestic" "Urban Domestic" "Overseas" ...
## $ age : int 29 41 77 66 26 65 60 50 82 41 ...
Exercise 4 - Using functions, packages and the pipe operator
# Load the dplyr package
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
# Seek help on the functions filter() and pull() from dplyr
# What do these functions do and what are their arguments?
?dplyr::filter
?dplyr::pull
# Using the pipe operator, write code to calculate the average amount
# donated by Rural Domestic individuals, rounded to the nearest dollar.
# Remember that == (double equals) is used for precise equality
charity_data |>
dplyr::filter(reside == "Rural Domestic") |>
dplyr::pull(total_donations) |>
mean() |>
round()
## [1] 2565
## EXTENSION: Write similar code to calculate the average amount donated
## by males the age range of 30-39 inclusive, rounded to the nearest dollar
charity_data |>
dplyr::filter(gender == "M", age %in% 30:39) |>
dplyr::pull(total_donations) |>
mean() |>
round()
## [1] 2187
Exercise 5 - Plotting and graphing
# Using your charity dataset from the previous exercises, plot
# total_donations (y-axis) against age (x-axis)
plot(charity_data$age, charity_data$total_donations)
# Using an appropriate function, plot a histogram of total donations.
# Use Help if you need to.
hist(charity_data$total_donations)
# EXTENSION: If you know ggplot2, use it to create a boxplot of
# total donations grouped by gender.
library(ggplot2)
ggplot(data = charity_data, aes(x = gender, y = total_donations)) +
geom_boxplot() +
labs(x = "Gender", y = "Total donations") +
theme_minimal()
# EXTENSION: Run a pairplot to see if you can identify interesting patterns
# in the charity_data dataset. Remember to consider the data types.
library(GGally)
## Registered S3 method overwritten by 'GGally':
## method from
## +.gg ggplot2
charity_data <- charity_data |>
dplyr::mutate(
across(c("recent_donation", "gender", "reside"), as.factor)
)
GGally::ggpairs(charity_data)
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Exercise 6 - Documenting in R Markdown
# Knit this document into a HTML file using the 'Knit' button
# View your output
================================================
FILE: docs/materials/module-exercises/01-R_fundamentals.Rmd
================================================
---
title: "1 - R Fundamentals"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will briefly practice working with different vector types. Follow the instructions in the comments of each code chunk.
## Exercise 1 - Creating and examining vectors
```{r}
# In a recent coding competition, Liz came first, Alex came second
# and Jiena came third.
# here is a vector with their names
name <- c("Alex", "Jiena", "Liz")
# Check that this vector is a character vector of length 3
```
```{r}
# Create a corresponding numeric vector with each person's position.
```
```{r}
# Check that your vector is a numeric vector of length three.
```
## Exercise 2 - Converting vectors to factors and ordered factors
```{r}
# Convert the 'name' character vector to a factor vector called 'name_factor'.
# Check that the conversion succeeded.
```
```{r}
# Convert your 'name' character vector to an ordered factor vector
# in increasing position order. Check that the conversion succeeded.
```
```{r}
# EXTENSION: Use a function to display the vector in order of position (highest to lowest)?
```
## Exercise 3 - Loading and inspecting dataframes
```{r}
# Here is a URL for on online csv of data about charity donations
url <- "https://peopleanalytics-regression-book.org/data/charity_donation.csv"
# Download this into a dataframe with a name of your choice
```
```{r}
# Inspect the dataframe to find out how many rows of data there are
# and what the columns names and data types are
```
## Exercise 4 - Using functions, packages and the pipe operator
```{r}
# Load the dplyr package
# Seek help on the functions filter() and pull() from dplyr
# What do these functions do and what are their arguments?
```
```{r}
# Using the pipe operator, write code to calculate the average amount
# donated by Rural Domestic individuals, rounded to the nearest dollar.
# Remember that == (double equals) is used for precise equality
```
```{r}
## EXTENSION: Write similar code to calculate the average amount donated
## by males the age range of 30-39 inclusive, rounded to the nearest dollar.
```
## Exercise 5 - Plotting and graphing
```{r}
# Using your charity dataset from the previous exercises, plot
# total_donations (y-axis) against age (x-axis)
```
```{r}
# Using an appropriate function, plot a histogram of total donations.
```
```{r}
# EXTENSION: If you know ggplot2, use it to create a boxplot of
# total donations grouped by gender.
```
```{r}
# EXTENSION: Run a pairplot to see if you can identify interesting patterns
# in the charity_data dataset. Remember to consider the data types.
```
## Exercise 6 - Documenting in R Markdown
```{r}
# Knit this document into a HTML file using the 'Knit' button
# View your output
```
================================================
FILE: docs/materials/module-exercises/02A-Statistical_Inference - SOLUTIONS.Rmd
================================================
---
title: "2A - Statistical Inference - SOLUTIONS"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will briefly practice some foundational concepts of statistical inference and hypothesis testing. Follow the instructions in the comments of each code chunk.
## Exercise 1 - Running a $t$-test
```{r}
# Download the charity donation dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/charity_donation.csv"
charity_data <- read.csv(url)
```
```{r}
# Create two vectors capturing the total donations for those who have
# recently donated and those who have not
donations_recent <- charity_data$total_donations[charity_data$recent_donation == 1]
donations_notrecent <- charity_data$total_donations[charity_data$recent_donation == 0]
```
```{r}
# Calculate the difference in the means of these two vectors
# Round this to 2 decimal places
diff <- mean(donations_recent) - mean(donations_notrecent)
(diff <- round(diff, 2))
```
```{r}
# Test the hypothesis that recent donors have a different mean donation amount.
# Ensure that your test is saved as an object with a name of your choice.
(diff_test <- t.test(donations_recent, donations_notrecent))
```
```{r}
# EXTENSION: Test the hypothesis that recent donors donate MORE
# (Hint: seek help on the t.test function to work out how to do this)
t.test(donations_recent, donations_notrecent, alternative = "greater")
```
## Exercise 2 - Interpreting a $t$-test
```{r}
# The results of a t-test are actually a named list.
# You can access specific elements of the list using $ (eg test$p.value)
# Return the standard error value for the difference in mean total donations.
# Round this to 2 decimal places
(se <- diff_test$stderr |>
round(2))
```
```{r}
# Return the p-value and the 95% confidence interval for the population diff.
# round these to 2 decimal places
(pval <- diff_test$p.value |>
round(2))
(confint <- diff_test$conf.int |>
round(2))
```
Use these values to write an interpretation of your $t$-test, explaining what you have observed in the sample and what this means you can infer about the population.
* The null hypothesis is that there is no difference in the mean donations.
* The observed difference in means for the sample provided was `r diff`.
* The standard error of this difference in means is `r se`.
* The 95% confidence interval for the population difference is approimately 1.96
standard errors either side of the observed value, which calculates to `r confint`.
* A difference of zero is not inside the 95% confidence interval.
* Therefore the likelihood of this difference occurring if the null hypothesis
were true is less than 5%
* We can infer a rejection of the null hypothesis and an acceptance of the
alternative hypothesis that there is a difference in the mean donations.
* The $p$-value of the test indicates that the likelihood of this difference
or a greater difference occurring if the null hypothesis were true is
approximately `r pval*100`%.
================================================
FILE: docs/materials/module-exercises/02A-Statistical_Inference---SOLUTIONS.html
================================================
In this document we will briefly practice some foundational concepts
of statistical inference and hypothesis testing. Follow the instructions
in the comments of each code chunk.
Exercise 1 - Running a \(t\)-test
# Download the charity donation dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/charity_donation.csv"
charity_data <- read.csv(url)
# Create two vectors capturing the total donations for those who have
# recently donated and those who have not
donations_recent <- charity_data$total_donations[charity_data$recent_donation == 1]
donations_notrecent <- charity_data$total_donations[charity_data$recent_donation == 0]
# Calculate the difference in the means of these two vectors
# Round this to 2 decimal places
diff <- mean(donations_recent) - mean(donations_notrecent)
(diff <- round(diff, 2))
## [1] 781.38
# Test the hypothesis that recent donors have a different mean donation amount.
# Ensure that your test is saved as an object with a name of your choice.
(diff_test <- t.test(donations_recent, donations_notrecent))
##
## Welch Two Sample t-test
##
## data: donations_recent and donations_notrecent
## t = 2.443, df = 130.34, p-value = 0.01591
## alternative hypothesis: true difference in means is not equal to 0
## 95 percent confidence interval:
## 148.6116 1414.1404
## sample estimates:
## mean of x mean of y
## 2948.313 2166.937
# EXTENSION: Test the hypothesis that recent donors donate MORE
# (Hint: seek help on the t.test function to work out how to do this)
t.test(donations_recent, donations_notrecent, alternative = "greater")
##
## Welch Two Sample t-test
##
## data: donations_recent and donations_notrecent
## t = 2.443, df = 130.34, p-value = 0.007953
## alternative hypothesis: true difference in means is greater than 0
## 95 percent confidence interval:
## 251.5076 Inf
## sample estimates:
## mean of x mean of y
## 2948.313 2166.937
Exercise 2 - Interpreting a \(t\)-test
# The results of a t-test are actually a named list.
# You can access specific elements of the list using $ (eg test$p.value)
# Return the standard error value for the difference in mean total donations.
# Round this to 2 decimal places
(se <- diff_test$stderr |>
round(2))
## [1] 319.85
# Return the p-value and the 95% confidence interval for the population diff.
# round these to 2 decimal places
(pval <- diff_test$p.value |>
round(2))
## [1] 0.02
(confint <- diff_test$conf.int |>
round(2))
## [1] 148.61 1414.14
## attr(,"conf.level")
## [1] 0.95
Use these values to write an interpretation of your \(t\)-test, explaining what you have observed
in the sample and what this means you can infer about the
population.
- The null hypothesis is that there is no difference in the mean
donations.
- The observed difference in means for the sample provided was
781.38.
- The standard error of this difference in means is 319.85.
- The 95% confidence interval for the population difference is
approimately 1.96 standard errors either side of the observed value,
which calculates to 148.61, 1414.14.
- A difference of zero is not inside the 95% confidence interval.
- Therefore the likelihood of this difference occurring if the null
hypothesis were true is less than 5%
- We can infer a rejection of the null hypothesis and an acceptance of
the alternative hypothesis that there is a difference in the mean
donations.
- The \(p\)-value of the test
indicates that the likelihood of this difference or a greater difference
occurring if the null hypothesis were true is approximately 2%.
================================================
FILE: docs/materials/module-exercises/02A-Statistical_Inference.Rmd
================================================
---
title: "2A - Statistical Inference"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will briefly practice some foundational concepts of
statistical inference and hypothesis testing. Follow the instructions
in the comments of each code chunk.
## Exercise 1 - Running a $t$-test
```{r}
# Download the charity donation dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/charity_donation.csv"
```
```{r}
# Create two vectors capturing the total donations for those who have
# recently donated and those who have not
```
```{r}
# Calculate the difference in the means of these two vectors
# Round this to 2 decimal places.
```
```{r}
# Test the hypothesis that recent donors have a different mean donation amount.
# Ensure that your test is saved as an object with a name of your choice.
```
```{r}
# EXTENSION: Test the hypothesis that recent donors donate MORE
# (Hint: seek help on the t.test function to work out how to do this)
```
## Exercise 2 - Interpreting a $t$-test
```{r}
# The results of a t-test are actually a named list.
# You can access specific elements of the list using $ (eg my_test$p.value)
# Return the standard error value for the difference in mean total donations.
# Round this to 2 decimal places
```
```{r}
# Return the p-value and the 95% confidence interval for the population diff.
# round these to 2 decimal places
```
Use these values to write an interpretation of your $t$-test, explaining what you have observed in the sample and what this means you can infer about the population.
================================================
FILE: docs/materials/module-exercises/02B-Linear_regression - SOLUTIONS.Rmd
================================================
---
title: "2B - Linear Regression Solutions"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will conduct linear regression modeling on a data set relating to graduate salaries in the United States, to try to understand economic factors which influence graduate salaries.
## Exercise 1 - Running a simple linear regression model
```{r}
# Download the graduates dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/graduates.csv"
graduates <- read.csv(url)
```
```{r}
# view the first few rows in the data set to acquaint yourself with the data
head(graduates)
```
```{r}
# Determine how many observations we have in this data set
nrow(graduates)
```
```{r}
# use the colnames() function to get the names of the columns in the data set
colnames(graduates)
```
```{r}
# Use the cor() function to determine the correlation between unemployment rate and median salary
cor(graduates$Unemployment_rate, graduates$Median_salary)
```
```{r}
# Consider the scale of the Unemployment_rate column.
# Transform it into a more useful scale
# (Hint: we will want to understand the impact of a percentage point change)
graduates$Unemployment_rate <- 100*graduates$Unemployment_rate
```
```{r}
# Run a simple linear regression model to estimate the influence of unemployment rate
# on graduate salaries, saving your model using a name of your choice
model <- lm(data = graduates, formula = Median_salary ~ Unemployment_rate)
```
## Exercise 2 - Interpreting the coefficients
```{r}
# Examine the coefficients of your saved model
model$coefficients
```
```{r}
# Determine the 95% confidence interval for the coefficients
confint(model)
```
Write below an interpretation of these coefficients using the estimates and the confidence intervals which you just calculated.
* Unemployment rate has a statistically significant influence on median graduate salary
* Full employment is associated with a median salary of between \$63425 and \$76769 on average
* An additional percentage point in unemployment rate is associated with a reduction in median salary of between \$1212 and \$3419 on average
```{r}
# EXTENSION: If you are familiar with using ggplot2, create a plot of unemployment rate and
# median salary and show the estimated linear model using geom_smooth()
library(ggplot2)
ggplot(data = graduates, aes(x = Unemployment_rate, y = Median_salary)) +
geom_point() +
geom_smooth(method = "lm") +
labs(x = "Unemployment rate (%)",
y = "Median salary ($)") +
theme_minimal()
```
## Exercise 3 - Running a multiple linear regression model
```{r}
# Run a multiple linear regression to determine the influence of both unemployment rate
# and total graduate employees on median salary
model2 <- lm(Median_salary ~ Unemployment_rate + Total, graduates)
```
```{r}
# View the coefficients and confidence intervals
model2$coefficients
confint(model2)
```
Write below an interpretation of the coefficients of this model.
## Exercise 4 - Including categorical input variables
```{r}
# Add discipline as an input variable to the previous model you created in
# Exercise 3.
model3 <- lm(Median_salary ~ Unemployment_rate + Total + Discipline,
graduates)
```
```{r}
# Inspect the results and determine which value was used as a reference for
# discipline in the model
confint(model3)
# view all unique values for discipline
unique(graduates$Discipline)
# it appears that the first discipline in alphabetical order has been used
# as reference (Agriculture & Natural Resources)
```
Write below your thoughts on whether any specific disciplines have a significant influence on median salary.
Compared to a reference discipline of Agriculture & Natural Resources, the following disciplines have a significant positive influence on median salary (assuming similar unemployment rates and total graduate numbers):
* Computers & Mathematics (Yay for R programmers!)
* Engineering
* Physical Sciences
and the following have a significant negative influence:
* Education
```{r}
# EXTENSION: Change your reference discipline to a discipline of your choice,
# rerun the model and inspect the results. How have they changed?
graduates$Discipline <- as.factor(graduates$Discipline) |>
relevel(ref = "Computers & Mathematics")
model3 <- lm(Median_salary ~ Unemployment_rate + Total + Discipline,
graduates)
confint(model3)
```
Because we have referenced on one of the higher salary disciplines, we now see a lot more disciplines which have a significantly negative influence on median salary.
## Exercise 5 - Determining model fit
```{r}
# Determine the fit of your model from Exercise 4
summary(model3)$r.squared
```
```{r}
# Determine if any of the input variables can be removed to form a
# more parsimonious model
# we know from Exercise 4 that we can remove Total
model4 <- lm(Median_salary ~ Unemployment_rate + Discipline, graduates)
```
```{r}
# Verify that these is no substantial difference in the fit of your
# more parsimonious model
summary(model4)$r.squared
```
```{r}
# Run a summary of your parsimonious model
summary(model4)
```
The $p$-value of the F-statistic is very small, indicating high confidence that the model is better than a null model.
## EXTENSION Exercise 6 - Model diagnostics
```{r}
# Determine if the two numerical input variables have a significant correlation
cor.test(graduates$Unemployment_rate, graduates$Total)
```
```{r}
# Using the package mctest, use the imcdiag() function to test if collinearity
# exists in your full model from Exercise 3. Use the VIF method for this.
library(mctest)
mctest::imcdiag(model3, method = "VIF")
```
```{r}
# View a density plot of the Median salaries in the data set - what do you observe?
density(graduates$Median_salary) |>
plot(main = "Median Salary Density")
```
The distribution appears to be somewhat left-skewed due to a tail of high median salaries.
```{r}
# use the qqnorm() function to determine how the residuals of your model
# compare to a normal distribution
# comment on your observations
# consider re-running your model to address any concerns you have
qqnorm(model4$residuals)
```
Observations:
* Linear regression assumes a normal distribution of residuals
* Therefore we want this to be as close to a straight line as possible
* Two high median salary outliers appear to be affecting this
* We could consider removing these outliers to help build a more reliable model
```{r}
# remove highest two median salaries
library(dplyr)
adjusted_graduates <- graduates |>
dplyr::arrange(Median_salary) |>
head(nrow(graduates) - 2)
# rerun model
model5 <- lm(Median_salary ~ Unemployment_rate + Discipline,
adjusted_graduates)
# test residuals now
qqnorm(model5$residuals)
```
Healthier looking residual distribution.
```{r}
# view results
summary(model5)
```
Overall fit has improved, with similar significant variables, but some changes to coefficients.
================================================
FILE: docs/materials/module-exercises/02B-Linear_regression---SOLUTIONS.html
================================================
In this document we will conduct linear regression modeling on a data
set relating to graduate salaries in the United States, to try to
understand economic factors which influence graduate salaries.
Exercise 1 - Running a simple linear regression model
# Download the graduates dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/graduates.csv"
graduates <- read.csv(url)
# view the first few rows in the data set to acquaint yourself with the data
head(graduates)
## Major Discipline Total
## 1 GENERAL AGRICULTURE Agriculture & Natural Resources 128148
## 2 AGRICULTURE PRODUCTION AND MANAGEMENT Agriculture & Natural Resources 95326
## 3 AGRICULTURAL ECONOMICS Agriculture & Natural Resources 33955
## 4 ANIMAL SCIENCES Agriculture & Natural Resources 103549
## 5 FOOD SCIENCE Agriculture & Natural Resources 24280
## 6 PLANT SCIENCE AND AGRONOMY Agriculture & Natural Resources 79409
## Unemployment_rate Median_salary
## 1 0.02614711 50000
## 2 0.02863606 54000
## 3 0.03024832 63000
## 4 0.04267890 46000
## 5 0.04918845 62000
## 6 0.03179089 50000
# Determine how many observations we have in this data set
nrow(graduates)
## [1] 173
# use the colnames() function to get the names of the columns in the data set
colnames(graduates)
## [1] "Major" "Discipline" "Total"
## [4] "Unemployment_rate" "Median_salary"
# Use the cor() function to determine the correlation between unemployment rate and median salary
cor(graduates$Unemployment_rate, graduates$Median_salary)
## [1] -0.3019457
# Consider the scale of the Unemployment_rate column.
# Transform it into a more useful scale
# (Hint: we will want to understand the impact of a percentage point change)
graduates$Unemployment_rate <- 100*graduates$Unemployment_rate
# Run a simple linear regression model to estimate the influence of unemployment rate
# on graduate salaries, saving your model using a name of your choice
model <- lm(data = graduates, formula = Median_salary ~ Unemployment_rate)
Exercise 2 - Interpreting the coefficients
# Examine the coefficients of your saved model
model$coefficients
## (Intercept) Unemployment_rate
## 70096.911 -2315.512
# Determine the 95% confidence interval for the coefficients
confint(model)
## 2.5 % 97.5 %
## (Intercept) 63424.936 76768.887
## Unemployment_rate -3419.067 -1211.958
Write below an interpretation of these coefficients using the
estimates and the confidence intervals which you just calculated.
- Unemployment rate has a statistically significant influence on
median graduate salary
- Full employment is associated with a median salary of between $63425
and $76769 on average
- An additional percentage point in unemployment rate is associated
with a reduction in median salary of between $1212 and $3419 on
average
# EXTENSION: If you are familiar with using ggplot2, create a plot of unemployment rate and
# median salary and show the estimated linear model using geom_smooth()
library(ggplot2)
ggplot(data = graduates, aes(x = Unemployment_rate, y = Median_salary)) +
geom_point() +
geom_smooth(method = "lm") +
labs(x = "Unemployment rate (%)",
y = "Median salary ($)") +
theme_minimal()
## `geom_smooth()` using formula 'y ~ x'
Exercise 3 - Running a multiple linear regression model
# Run a multiple linear regression to determine the influence of both unemployment rate
# and total graduate employees on median salary
model2 <- lm(Median_salary ~ Unemployment_rate + Total, graduates)
# View the coefficients and confidence intervals
model2$coefficients
## (Intercept) Unemployment_rate Total
## 7.069198e+04 -2.343223e+03 -1.894123e-03
confint(model2)
## 2.5 % 97.5 %
## (Intercept) 6.382648e+04 7.755749e+04
## Unemployment_rate -3.450722e+03 -1.235725e+03
## Total -6.926153e-03 3.137908e-03
Write below an interpretation of the coefficients of this model.
Exercise 4 - Including categorical input variables
# Add discipline as an input variable to the previous model you created in
# Exercise 3.
model3 <- lm(Median_salary ~ Unemployment_rate + Total + Discipline,
graduates)
# Inspect the results and determine which value was used as a reference for
# discipline in the model
confint(model3)
## 2.5 % 97.5 %
## (Intercept) 5.309890e+04 6.715682e+04
## Unemployment_rate -2.248705e+03 -3.458837e+02
## Total -3.647491e-03 3.819117e-03
## DisciplineArts -1.528832e+04 4.772593e+03
## DisciplineBiology & Life Science -1.064108e+04 4.968144e+03
## DisciplineBusiness -9.672146e+02 1.595158e+04
## DisciplineCommunications & Journalism -1.324829e+04 9.850149e+03
## DisciplineComputers & Mathematics 5.439571e+03 2.224382e+04
## DisciplineEducation -1.788046e+04 -2.630368e+03
## DisciplineEngineering 1.724532e+04 3.113145e+04
## DisciplineHealth -5.639558e+03 1.050717e+04
## DisciplineHumanities & Liberal Arts -1.326690e+04 3.142300e+03
## DisciplineIndustrial Arts & Consumer Services -9.302614e+03 9.497455e+03
## DisciplineInterdisciplinary -2.703539e+04 1.282003e+04
## DisciplineLaw & Public Policy -9.150384e+03 1.206888e+04
## DisciplinePhysical Sciences 8.546786e+02 1.782305e+04
## DisciplinePsychology & Social Work -1.486827e+04 3.889056e+03
## DisciplineSocial Science -7.424027e+03 1.060487e+04
# view all unique values for discipline
unique(graduates$Discipline)
## [1] "Agriculture & Natural Resources" "Biology & Life Science"
## [3] "Engineering" "Humanities & Liberal Arts"
## [5] "Communications & Journalism" "Computers & Mathematics"
## [7] "Industrial Arts & Consumer Services" "Education"
## [9] "Law & Public Policy" "Interdisciplinary"
## [11] "Health" "Social Science"
## [13] "Physical Sciences" "Psychology & Social Work"
## [15] "Arts" "Business"
# it appears that the first discipline in alphabetical order has been used
# as reference (Agriculture & Natural Resources)
Write below your thoughts on whether any specific disciplines have a
significant influence on median salary.
Compared to a reference discipline of Agriculture & Natural
Resources, the following disciplines have a significant positive
influence on median salary (assuming similar unemployment rates and
total graduate numbers):
- Computers & Mathematics (Yay for R programmers!)
- Engineering
- Physical Sciences
and the following have a significant negative influence:
# EXTENSION: Change your reference discipline to a discipline of your choice,
# rerun the model and inspect the results. How have they changed?
graduates$Discipline <- as.factor(graduates$Discipline) |>
relevel(ref = "Computers & Mathematics")
model3 <- lm(Median_salary ~ Unemployment_rate + Total + Discipline,
graduates)
confint(model3)
## 2.5 % 97.5 %
## (Intercept) 6.590542e+04 8.203370e+04
## Unemployment_rate -2.248705e+03 -3.458837e+02
## Total -3.647491e-03 3.819117e-03
## DisciplineAgriculture & Natural Resources -2.224382e+04 -5.439571e+03
## DisciplineArts -2.820131e+04 -9.997809e+03
## DisciplineBiology & Life Science -2.427128e+04 -9.085053e+03
## DisciplineBusiness -1.432016e+04 1.621136e+03
## DisciplineCommunications & Journalism -2.655835e+04 -4.523188e+03
## DisciplineEducation -3.152224e+04 -1.667198e+04
## DisciplineEngineering 3.671058e+03 1.702232e+04
## DisciplineHealth -1.929639e+04 -3.519399e+03
## DisciplineHumanities & Liberal Arts -2.639708e+04 -1.141091e+04
## DisciplineIndustrial Arts & Consumer Services -2.278212e+04 -4.706431e+03
## DisciplineInterdisciplinary -4.054532e+04 -1.353428e+03
## DisciplineLaw & Public Policy -2.249663e+04 -2.268268e+03
## DisciplinePhysical Sciences -1.268773e+04 3.682062e+03
## DisciplinePsychology & Social Work -2.792243e+04 -1.074018e+04
## DisciplineSocial Science -2.069284e+04 -3.809716e+03
Because we have referenced on one of the higher salary disciplines,
we now see a lot more disciplines which have a significantly negative
influence on median salary.
Exercise 5 - Determining model fit
# Determine the fit of your model from Exercise 4
summary(model3)$r.squared
## [1] 0.626935
# Determine if any of the input variables can be removed to form a
# more parsimonious model
# we know from Exercise 4 that we can remove Total
model4 <- lm(Median_salary ~ Unemployment_rate + Discipline, graduates)
# Verify that these is no substantial difference in the fit of your
# more parsimonious model
summary(model4)$r.squared
## [1] 0.6269301
# Run a summary of your parsimonious model
summary(model4)
##
## Call:
## lm(formula = Median_salary ~ Unemployment_rate + Discipline,
## data = graduates)
##
## Residuals:
## Min 1Q Median 3Q Max
## -18681 -5185 -665 3455 47871
##
## Coefficients:
## Estimate Std. Error t value
## (Intercept) 74001.1 4010.1 18.454
## Unemployment_rate -1300.3 475.7 -2.734
## DisciplineAgriculture & Natural Resources -13856.0 4228.1 -3.277
## DisciplineArts -19085.7 4582.8 -4.165
## DisciplineBiology & Life Science -16686.7 3827.0 -4.360
## DisciplineBusiness -6299.8 3871.1 -1.627
## DisciplineCommunications & Journalism -15513.1 5526.3 -2.807
## DisciplineEducation -24089.6 3743.1 -6.436
## DisciplineEngineering 10340.8 3366.1 3.072
## DisciplineHealth -11404.3 3979.8 -2.866
## DisciplineHumanities & Liberal Arts -18893.5 3774.1 -5.006
## DisciplineIndustrial Arts & Consumer Services -13745.8 4560.5 -3.014
## DisciplineInterdisciplinary -20954.1 9887.7 -2.119
## DisciplineLaw & Public Policy -12378.4 5102.9 -2.426
## DisciplinePhysical Sciences -4509.4 4127.7 -1.092
## DisciplinePsychology & Social Work -19320.8 4329.0 -4.463
## DisciplineSocial Science -12238.0 4249.7 -2.880
## Pr(>|t|)
## (Intercept) < 2e-16 ***
## Unemployment_rate 0.00699 **
## DisciplineAgriculture & Natural Resources 0.00129 **
## DisciplineArts 5.14e-05 ***
## DisciplineBiology & Life Science 2.35e-05 ***
## DisciplineBusiness 0.10567
## DisciplineCommunications & Journalism 0.00564 **
## DisciplineEducation 1.44e-09 ***
## DisciplineEngineering 0.00251 **
## DisciplineHealth 0.00474 **
## DisciplineHumanities & Liberal Arts 1.49e-06 ***
## DisciplineIndustrial Arts & Consumer Services 0.00301 **
## DisciplineInterdisciplinary 0.03566 *
## DisciplineLaw & Public Policy 0.01642 *
## DisciplinePhysical Sciences 0.27631
## DisciplinePsychology & Social Work 1.54e-05 ***
## DisciplineSocial Science 0.00454 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 9432 on 156 degrees of freedom
## Multiple R-squared: 0.6269, Adjusted R-squared: 0.5887
## F-statistic: 16.38 on 16 and 156 DF, p-value: < 2.2e-16
The \(p\)-value of the F-statistic
is very small, indicating high confidence that the model is better than
a null model.
EXTENSION Exercise 6 - Model diagnostics
# Determine if the two numerical input variables have a significant correlation
cor.test(graduates$Unemployment_rate, graduates$Total)
##
## Pearson's product-moment correlation
##
## data: graduates$Unemployment_rate and graduates$Total
## t = -0.87117, df = 171, p-value = 0.3849
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
## -0.21355488 0.08355632
## sample estimates:
## cor
## -0.06647261
# Using the package mctest, use the imcdiag() function to test if collinearity
# exists in your full model from Exercise 3. Use the VIF method for this.
library(mctest)
mctest::imcdiag(model3, method = "VIF")
##
## Call:
## mctest::imcdiag(mod = model3, method = "VIF")
##
##
## VIF Multicollinearity Diagnostics
##
## VIF detection
## Unemployment_rate 1.6389 0
## Total 1.2223 0
## DisciplineAgriculture & Natural Resources 1.9038 0
## DisciplineArts 1.8092 0
## DisciplineBiology & Life Science 2.1234 0
## DisciplineBusiness 2.1863 0
## DisciplineCommunications & Journalism 1.3576 0
## DisciplineEducation 2.2914 0
## DisciplineEngineering 3.0790 0
## DisciplineHealth 1.9891 0
## DisciplineHumanities & Liberal Arts 2.2016 0
## DisciplineIndustrial Arts & Consumer Services 1.5704 0
## DisciplineInterdisciplinary 1.0928 0
## DisciplineLaw & Public Policy 1.4217 0
## DisciplinePhysical Sciences 1.8067 0
## DisciplinePsychology & Social Work 1.8024 0
## DisciplineSocial Science 1.7402 0
##
## NOTE: VIF Method Failed to detect multicollinearity
##
##
## 0 --> COLLINEARITY is not detected by the test
##
## ===================================
# View a density plot of the Median salaries in the data set - what do you observe?
density(graduates$Median_salary) |>
plot(main = "Median Salary Density")
The distribution appears to be somewhat left-skewed due to a tail of
high median salaries.
# use the qqnorm() function to determine how the residuals of your model
# compare to a normal distribution
# comment on your observations
# consider re-running your model to address any concerns you have
qqnorm(model4$residuals)
Observations: * Linear regression assumes a normal distribution of
residuals * Therefore we want this to be as close to a straight line as
possible * Two high median salary outliers appear to be affecting this *
We could consider removing these outliers to help build a more reliable
model
# remove highest two median salaries
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
adjusted_graduates <- graduates |>
dplyr::arrange(Median_salary) |>
head(nrow(graduates) - 2)
# rerun model
model5 <- lm(Median_salary ~ Unemployment_rate + Discipline,
adjusted_graduates)
# test residuals now
qqnorm(model5$residuals)
Healthier looking residual distribution.
# view results
summary(model5)
##
## Call:
## lm(formula = Median_salary ~ Unemployment_rate + Discipline,
## data = adjusted_graduates)
##
## Residuals:
## Min 1Q Median 3Q Max
## -16830.0 -4713.6 -577.4 3618.5 22186.0
##
## Coefficients:
## Estimate Std. Error t value
## (Intercept) 72367.3 3281.2 22.055
## Unemployment_rate -1025.4 389.8 -2.630
## DisciplineAgriculture & Natural Resources -13309.9 3454.6 -3.853
## DisciplineArts -19859.9 3744.8 -5.303
## DisciplineBiology & Life Science -16425.5 3126.5 -5.254
## DisciplineBusiness -6164.0 3162.5 -1.949
## DisciplineCommunications & Journalism -15779.4 4514.7 -3.495
## DisciplineEducation -23741.1 3058.1 -7.763
## DisciplineEngineering 8926.5 2761.8 3.232
## DisciplineHealth -15452.2 3313.7 -4.663
## DisciplineHumanities & Liberal Arts -19168.2 3083.3 -6.217
## DisciplineIndustrial Arts & Consumer Services -13721.3 3725.6 -3.683
## DisciplineInterdisciplinary -21444.3 8077.7 -2.655
## DisciplineLaw & Public Policy -12609.7 4168.8 -3.025
## DisciplinePhysical Sciences -4374.8 3372.0 -1.297
## DisciplinePsychology & Social Work -19827.4 3537.0 -5.606
## DisciplineSocial Science -12409.8 3471.8 -3.574
## Pr(>|t|)
## (Intercept) < 2e-16 ***
## Unemployment_rate 0.009400 **
## DisciplineAgriculture & Natural Resources 0.000171 ***
## DisciplineArts 3.89e-07 ***
## DisciplineBiology & Life Science 4.89e-07 ***
## DisciplineBusiness 0.053100 .
## DisciplineCommunications & Journalism 0.000619 ***
## DisciplineEducation 1.07e-12 ***
## DisciplineEngineering 0.001503 **
## DisciplineHealth 6.71e-06 ***
## DisciplineHumanities & Liberal Arts 4.55e-09 ***
## DisciplineIndustrial Arts & Consumer Services 0.000319 ***
## DisciplineInterdisciplinary 0.008771 **
## DisciplineLaw & Public Policy 0.002916 **
## DisciplinePhysical Sciences 0.196442
## DisciplinePsychology & Social Work 9.34e-08 ***
## DisciplineSocial Science 0.000469 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 7705 on 154 degrees of freedom
## Multiple R-squared: 0.6957, Adjusted R-squared: 0.6641
## F-statistic: 22.01 on 16 and 154 DF, p-value: < 2.2e-16
Overall fit has improved, with similar significant variables, but
some changes to coefficients.
================================================
FILE: docs/materials/module-exercises/02B-Linear_regression.Rmd
================================================
---
title: "2B - Linear Regression"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will conduct linear regression modeling on a data set relating to graduate salaries in the United States, to try to understand economic factors which influence gradiate salaries,
## Exercise 1 - Running a simple linear regression model
```{r}
# Download the graduates dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/graduates.csv"
```
```{r}
# view the first few rows in the data set to acquaint yourself with the data
```
```{r}
# Determine how many observations we have in this data set
```
```{r}
# use the colnames() function to get the names of the columns in the data set
```
```{r}
# Use the cor() function to determine the correlation between unemployment rate and median salary
```
```{r}
# Consider the scale of the Unemployment_rate column.
# Transform it into a more useful scale
# (Hint: we will want to understand the impact of a percentage point change)
```
```{r}
# Run a simple linear regression model to estimate the influence of unemployment rate
# on graduate salaries, saving your model using a name of your choice
```
## Exercise 2 - Interpreting the coefficients
```{r}
# Examine the coefficients of your saved model
```
```{r}
# Determine the 95% confidence interval for the coefficients
```
Write below an interpretation of these coefficients using the estimates and the confidence intervals which you just calculated.
```{r}
# EXTENSION: If you are familiar with using ggplot2, create a plot of unemployment rate and
# median salary and show the estimated linear model using geom_smooth()
```
## Exercise 3 - Running a multiple linear regression model
```{r}
# Run a multiple linear regression to determine the influence of both unemployment rate
# and total graduate employees on median salary
```
```{r}
# View the coefficients and confidence intervals
```
Write below an interpretation of the coefficients of this model.
## Exercise 4 - Including categorical input variables
```{r}
# Add discipline as an input variable to the previous model you created in
# Exercise 3.
```
```{r}
# Inspect the results and determine which value was used as a reference for
# discipline in the model
```
Write below your thoughts on whether any specific disciplines have a significant influence on median salary.
```{r}
# EXTENSION: Change your reference discipline to a discipline of your choice,
# rerun the model and inspect the results. How have they changed?
```
## Exercise 5 - Determining model fit
```{r}
# Determine the fit of your model from Exercise 4
```
```{r}
# Determine if any of the input variables can be removed to form a
# more parsimonious model
```
```{r}
# Verify that these is no substantial difference in the fit of your
# more parsimonious model
```
```{r}
# Run a summary of your parsimonious model and comment on
# whether you are confident that it is better than a null model
```
## EXTENSION Exercise 6 - Model diagnostics
```{r}
# Determine if the two numerical input variables have a significant correlation
```
```{r}
# Using the package mctest, use the imcdiag() function to test if collinearity
# exists in your full model from Exercise 3. Use the VIF method for this.
```
```{r}
# View a density plot of the Median salaries in the data set - what do you observe?
```
```{r}
# use the qqnorm() function to determine how the residuals of your model
# compare to a normal distribution
# comment on your observations
# consider re-running your model to address any concerns you have
```
================================================
FILE: docs/materials/module-exercises/03A-Binomial_regression - SOLUTIONS.Rmd
================================================
---
title: "03A - Binomial Logistic Regression Solutions"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will conduct binomial logistic regression modeling on a data set relating to recruiting data and whether a person is hired or not hired based on test scores, interviews, and gender. Data fields:
- gender: gender
- sat: SAT test score of applicant
- gpa: GPA of applicant
- apttest: Score on an aptitude test given to applicant
- int1: applicant rating given by one of two line manager interviewers (1-5 where high is positive)
- int2: applicant rating given by second of two line manager interviewers (1-5 where high is positive)
- int3: applicant rating given by HR interviewer (1-5 where high is positive)
- hired: hired (1) or not hired (0)
## Exercise 1 - Running a simple binomial logistic regression model
```{r}
# Download the recruiting dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/recruiting.csv"
recruiting <- read.csv(url)
```
```{r}
# view the first few rows in the data set to acquaint yourself with the data
head(recruiting)
```
```{r}
# What do you think the datatypes are?
# gender: binary factor
# sat: numeric
# gpa: numeric
# apttest: numeric
# int1: ordered factor
# int2: ordered factor
# int3: ordered factor
# hired: binary factor
```
```{r}
# Perform any necessary datatype adjustments
recruiting$gender <- as.factor(recruiting$gender)
recruiting$hired <- as.factor(recruiting$hired)
recruiting$int1 <- ordered(recruiting$int1,
levels = 1:5)
recruiting$int2 <- ordered(recruiting$int2,
levels = 1:5)
recruiting$int3 <- ordered(recruiting$int3,
levels = 1:5)
```
```{r}
# get to the know the data a bit. what is the split of hired/not hired,
# do you notice differences between the interviewers, etc
# Hint: summary(), GGally::ggpairs() are good first steps
summary(recruiting)
GGally::ggpairs(recruiting)
```
```{r}
# Run a simple binomial logistic regression model to estimate the influence of SAT scores
# on hire success, saving your model using a name of your choice
model <- glm(data = recruiting, formula = hired ~ sat, family = "binomial")
```
## Exercise 2 - Interpreting the coefficients
```{r}
# Examine the coefficients of your saved model
summary(model)$coefficients
```
```{r}
# Take a look at the odds ratio for our independent variable. How do you interpret this?
exp(model$coefficients)
```
```{r}
# Do you think this is a good model?
DescTools::PseudoR2(model)
```
## Exercise 3 - Running a multiple binomial logistic regression model
```{r}
# What variables look like they might be interesting to include?
GGally::ggpairs(recruiting)
```
```{r}
# make a new model with gender and apttest
model2 <- glm(hired ~ apttest + gender, data = recruiting, family = "binomial")
```
```{r}
# View the coefficients and log odds.
summary(model2)$coefficients
exp(model2$coefficients)
```
```{r}
# Assess model fit - is this better than the simple model?
DescTools::PseudoR2(model2)
AIC(model)
AIC(model2)
```
Write a few sentences on the data and the results of your model. Odds can be difficult to explain - can you try to
explain to a stakeholder what this means for a candidate with a 60 on their aptitude test vs a candidate with a 70?
Each additional point in the aptitude tests results in a ~6.5% increase in the odds of being hired.
The low Pseudo R^2 value means that we are only explaining a small amount of what leads to a person being hired.
A candidate with a 70 has 10 more points than a candidate with 60. Each point relates to a 6.5% increase in odds, so all
else being equal, the person with a 70 has 1.065^10 = ~88% increased odds of being hired vs the candidate with a 60.
================================================
FILE: docs/materials/module-exercises/03A-Binomial_regression---SOLUTIONS.html
================================================
In this document we will conduct binomial logistic regression
modeling on a data set relating to recruiting data and whether a person
is hired or not hired based on test scores, interviews, and gender. Data
fields:
- gender: gender
- sat: SAT test score of applicant
- gpa: GPA of applicant
- apttest: Score on an aptitude test given to applicant
- int1: applicant rating given by one of two line manager interviewers
(1-5 where high is positive)
- int2: applicant rating given by second of two line manager
interviewers (1-5 where high is positive)
- int3: applicant rating given by HR interviewer (1-5 where high is
positive)
- hired: hired (1) or not hired (0)
Exercise 1 - Running a simple binomial logistic regression
model
# Download the recruiting dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/recruiting.csv"
recruiting <- read.csv(url)
# view the first few rows in the data set to acquaint yourself with the data
head(recruiting)
## gender sat gpa apttest int1 int2 int3 hired
## 1 F 1230 3.57 70 4 3 4 0
## 2 F 1250 3.58 20 3 4 3 0
## 3 F 930 2.89 77 2 3 3 0
## 4 F 1110 3.49 85 5 3 4 0
## 5 M 1260 3.39 93 3 4 4 1
## 6 M 1370 3.41 81 2 4 4 0
# What do you think the datatypes are?
# gender: binary factor
# sat: numeric
# gpa: numeric
# apttest: numeric
# int1: ordered factor
# int2: ordered factor
# int3: ordered factor
# hired: binary factor
# Perform any necessary datatype adjustments
recruiting$gender <- as.factor(recruiting$gender)
recruiting$hired <- as.factor(recruiting$hired)
recruiting$int1 <- ordered(recruiting$int1,
levels = 1:5)
recruiting$int2 <- ordered(recruiting$int2,
levels = 1:5)
recruiting$int3 <- ordered(recruiting$int3,
levels = 1:5)
# get to the know the data a bit. what is the split of hired/not hired,
# do you notice differences between the interviewers, etc
# Hint: summary(), GGally::ggpairs() are good first steps
summary(recruiting)
## gender sat gpa apttest int1 int2 int3
## F:494 Min. : 420 Min. :2.46 Min. : 8.00 1: 6 1: 0 1: 0
## M:472 1st Qu.: 970 1st Qu.:3.26 1st Qu.:51.00 2:157 2: 31 2: 10
## Median :1110 Median :3.45 Median :62.00 3:409 3:429 3:554
## Mean :1106 Mean :3.38 Mean :62.25 4:370 4:491 4:396
## 3rd Qu.:1258 3rd Qu.:3.55 3rd Qu.:76.00 5: 24 5: 15 5: 6
## Max. :1600 Max. :3.87 Max. :99.00
## hired
## 0:780
## 1:186
##
##
##
##
GGally::ggpairs(recruiting)
## Registered S3 method overwritten by 'GGally':
## method from
## +.gg ggplot2
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
# Run a simple binomial logistic regression model to estimate the influence of SAT scores
# on hire success, saving your model using a name of your choice
model <- glm(data = recruiting, formula = hired ~ sat, family = "binomial")
Exercise 2 - Interpreting the coefficients
# Examine the coefficients of your saved model
summary(model)$coefficients
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.140822718 0.4942049503 -6.355304 2.080148e-10
## sat 0.001518944 0.0004267464 3.559360 3.717589e-04
# Take a look at the odds ratio for our independent variable. How do you interpret this?
exp(model$coefficients)
## (Intercept) sat
## 0.0432472 1.0015201
# Do you think this is a good model?
DescTools::PseudoR2(model)
## McFadden
## 0.01390745
Exercise 3 - Running a multiple binomial logistic regression
model
# What variables look like they might be interesting to include?
GGally::ggpairs(recruiting)
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
# make a new model with gender and apttest
model2 <- glm(hired ~ apttest + gender, data = recruiting, family = "binomial")
# View the coefficients and log odds.
summary(model2)$coefficients
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -5.88658877 0.468463826 -12.565727 3.258639e-36
## apttest 0.06362264 0.006391116 9.954857 2.401685e-23
## genderM 0.31346702 0.177697958 1.764044 7.772457e-02
exp(model2$coefficients)
## (Intercept) apttest genderM
## 0.002776432 1.065690176 1.368160340
# Assess model fit - is this better than the simple model?
DescTools::PseudoR2(model2)
## McFadden
## 0.1441964
AIC(model)
## [1] 937.3132
AIC(model2)
## [1] 815.9978
Write a few sentences on the data and the results of your model. Odds
can be difficult to explain - can you try to explain to a stakeholder
what this means for a candidate with a 60 on their aptitude test vs a
candidate with a 70?
Each additional point in the aptitude tests results in a ~6.5%
increase in the odds of being hired. The low Pseudo R^2 value means that
we are only explaining a small amount of what leads to a person being
hired.
A candidate with a 70 has 10 more points than a candidate with 60.
Each point relates to a 6.5% increase in odds, so all else being equal,
the person with a 70 has 1.065^10 = ~88% increased odds of being hired
vs the candidate with a 60.
================================================
FILE: docs/materials/module-exercises/03A-Binomial_regression.Rmd
================================================
---
title: "03A - Binomial Logistic Regression"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will conduct binomial logistic regression modeling on a data set relating to recruiting data and whether a person is hired or not hired based on test scores, interviews, and gender. Data fields:
- gender: gender
- sat: SAT test score of applicant
- gpa: GPA of applicant
- apttest: Score on an aptitude test given to applicant
- int1: applicant rating given by one of two line manager interviewers (1-5 where high is positive)
- int2: applicant rating given by second of two line manager interviewers (1-5 where high is positive)
- int3: applicant rating given by HR interviewer (1-5 where high is positive)
- hired: hired (1) or not hired (0)
## Exercise 1 - Running a simple binomial logistic regression model
```{r}
# Download the recruiting dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/recruiting.csv"
recruiting <- read.csv(url)
```
```{r}
# view the first few rows in the data set to acquaint yourself with the data
```
```{r}
# What do you think the datatypes are?
# gender:
# sat:
# gpa:
# apttest:
# int1:
# int2:
# int3:
# hired:
```
```{r}
# Perform any necessary datatype adjustments
```
```{r}
# get to the know the data a bit. what is the split of hired/not hired,
# do you notice differences between the interviewers, etc
# Hint: summary(), GGally::ggpairs() are good first steps
```
```{r}
# Run a simple binomial logistic regression model to estimate the influence of SAT scores
# on hire success, saving your model using a name of your choice
```
## Exercise 2 - Interpreting the coefficients
```{r}
# Examine the coefficients of your saved model
```
```{r}
# Take a look at the odds ratio for our independent variable. How do you interpret this?
```
```{r}
# Do you think this is a good model?
```
## Exercise 3 - Running a multiple binomial logistic regression model
```{r}
# What variables look like they might be interesting to include?
```
```{r}
# make a new model with gender and apttest
```
```{r}
# View the coefficients and log odds.
```
```{r}
# Assess model fit - is this better than the simple model?
```
Write a few sentences on the data and the results of your model. Odds can be difficult to explain - can you try to
explain to a stakeholder what this means for a candidate with a 60 on their aptitude test vs a candidate with a 70?
================================================
FILE: docs/materials/module-exercises/03B-Ordinal_regression - SOLUTIONS.Rmd
================================================
---
title: "03B-Ordinal_regression - SOLUTIONS"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will conduct ordinal logistic regression on fictional data on employee performance evaluation metrics for a group of salespeople.
- sales: annual sales of the individual in millions of dollars
- new_customers: number of new customers acquired by individual
- region: region individual works in (North, South, East, West)
- gender: gender of individual
- rating: performance rating of individual (1 = Low, 2 = Middle, 3 = High)
## Exercise 1 - Running a simple ordinal logistic regression model
```{r}
# Download the employee performance dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/employee_performance.csv"
perf <- read.csv(url)
```
```{r}
# view the first few rows in the data set to acquaint yourself with the data
head(perf)
summary(perf)
```
```{r}
# What do you think the datatypes are?
# sales: numeric
# new_customers: numeric
# region: factor
# gender: factor
# rating: ordered factor
```
```{r}
# Perform any necessary datatype adjustments
perf$region <- as.factor(perf$region)
perf$gender <- as.factor(perf$gender)
perf$rating <- ordered(perf$rating,
levels = 1:3)
```
```{r}
# Take a look at the pairs plot. What do you notice?
GGally::ggpairs(perf)
# Things you might notice are:
# rating seems to be pretty well aligned with sales amount and new customer count
# looks like a lower proportion of women in North and West?
```
```{r}
# Run a simple ordinal logistic regression model to understand sales influence
# on rating, saving your model using a name of your choice
library(MASS)
model <- polr(formula = rating ~ sales, data = perf)
model
```
## Exercise 2 - Interpreting the coefficients
```{r}
# Examine the coefficients of your saved model
summary(model)$coefficients
```
```{r}
# Add p-values and odds ratios, and view
# What do you notice?
coefficients <- summary(model)$coefficients
# calculate p-values
p_value <- (1 - pnorm(abs(coefficients[ ,"t value"]), 0, 1))*2
# bind back to coefficients
coefficients <- cbind(coefficients, p_value)
# take exponents of coefficients to find odds
odds_ratio <- exp(coefficients[ ,"Value"])
# combine with coefficient and p_value
(coefficients <- cbind(coefficients[ ,c("Value", "p_value")],odds_ratio))
```
Write a sentence on the model results above.
Each additional million dollars in sales leaders to a 55% increase in odds of being in the next highest performance group.
```{r}
# Do you think this is a good model? Use the lipsitz test.
DescTools::PseudoR2(model)
generalhoslem::lipsitz.test(model)
```
Write a sentence on the results of this test.
Since the null hypothesis is the model is a good fit and our p-value is very low, we can conclude that this model isn't a good fit for our data.
## Exercise 3 - Add more information to the model
```{r}
# Let's try a model to see how sales, new_customers, and gender impact rating
model2 <- polr(rating ~ sales + gender + new_customers, data = perf)
summary(model2)
```
```{r}
# Add p-values and odds ratios, and view
# What do you notice?
coefficients <- summary(model2)$coefficients
# calculate p-values
p_value <- (1 - pnorm(abs(coefficients[ ,"t value"]), 0, 1))*2
# bind back to coefficients
coefficients <- cbind(coefficients, p_value)
# take exponents of coefficients to find odds
odds_ratio <- exp(coefficients[ ,"Value"])
# combine with coefficient and p_value
(coefficients <- cbind(coefficients[ ,c("Value", "p_value")],odds_ratio))
```
Write a few sentences on the results of the model.
Each additional $1 million in sales results in a 46% increase in odds of being in the next highest performance group.
Each additional new customer results in a 48% increase in odds of being in the next highest performance group.
```{r}
# Do you think this is a good model?
DescTools::PseudoR2(model2)
generalhoslem::lipsitz.test(model2)
```
Write a sentence on the results of the Lipsitz test.
Our p-values is now > 0.05, so we do not reject the null hypothesis and conclude that the model is a good fit.
# Exercise 4: Test the proportional odds assumption
```{r}
# First try the method where we compare the binary models to each other and use
# our judgement
perf$rating23 <- ifelse(perf$rating %in% c(2,3), 1, 0)
perf$rating3 <- ifelse(perf$rating == 3, 1, 0)
mod_23 <- glm(
rating23 ~ sales + gender + new_customers, data = perf, family = "binomial"
)
mod_3 <-glm(
rating3 ~ sales + gender + new_customers, data = perf, family = "binomial"
)
(coefficient_comparison <- data.frame(
mod_23 = summary(mod_23)$coefficients[ , "Estimate"],
mod_2 = summary(mod_3)$coefficients[ ,"Estimate"],
diff = summary(mod_3)$coefficients[ ,"Estimate"] -
summary(mod_23)$coefficients[ , "Estimate"]
))
```
Using your best judgement, do you think the proportional odds assumption is met?
These differences seem quite small, I would say that the assumption is met.
```{r}
# Alternatively with the Brant-Wald test
# What do you notice?
library(brant)
brant::brant(model2)
```
Write your interpretation of the brant-wald test results.
The test shows that the assumption holds. Sales is the only potentially problematic variable. We could try removing that from our model.
================================================
FILE: docs/materials/module-exercises/03B-Ordinal_regression---SOLUTIONS.html
================================================
In this document we will conduct ordinal logistic regression on
fictional data on employee performance evaluation metrics for a group of
salespeople.
- sales: annual sales of the individual in millions of dollars
- new_customers: number of new customers acquired by individual
- region: region individual works in (North, South, East, West)
- gender: gender of individual
- rating: performance rating of individual (1 = Low, 2 = Middle, 3 =
High)
Exercise 1 - Running a simple ordinal logistic regression model
# Download the employee performance dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/employee_performance.csv"
perf <- read.csv(url)
# view the first few rows in the data set to acquaint yourself with the data
head(perf)
## sales new_customers region gender rating
## 1 10.10 9 North M 2
## 2 11.67 17 West F 3
## 3 8.91 13 North M 3
## 4 7.73 10 South F 2
## 5 11.36 12 North M 2
## 6 8.06 12 North M 2
summary(perf)
## sales new_customers region gender
## Min. : 2.000 Min. : 1.000 Length:366 Length:366
## 1st Qu.: 5.362 1st Qu.: 6.000 Class :character Class :character
## Median : 7.485 Median : 8.000 Mode :character Mode :character
## Mean : 7.543 Mean : 8.025
## 3rd Qu.: 9.877 3rd Qu.:10.750
## Max. :15.660 Max. :20.000
## rating
## Min. :1.000
## 1st Qu.:1.000
## Median :2.000
## Mean :1.937
## 3rd Qu.:3.000
## Max. :3.000
# What do you think the datatypes are?
# sales: numeric
# new_customers: numeric
# region: factor
# gender: factor
# rating: ordered factor
# Perform any necessary datatype adjustments
perf$region <- as.factor(perf$region)
perf$gender <- as.factor(perf$gender)
perf$rating <- ordered(perf$rating,
levels = 1:3)
# Take a look at the pairs plot. What do you notice?
GGally::ggpairs(perf)
## Registered S3 method overwritten by 'GGally':
## method from
## +.gg ggplot2
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
# Things you might notice are:
# rating seems to be pretty well aligned with sales amount and new customer count
# looks like a lower proportion of women in North and West?
# Run a simple ordinal logistic regression model to understand sales influence
# on rating, saving your model using a name of your choice
library(MASS)
model <- polr(formula = rating ~ sales, data = perf)
model
## Call:
## polr(formula = rating ~ sales, data = perf)
##
## Coefficients:
## sales
## 0.4396276
##
## Intercepts:
## 1|2 2|3
## 2.362490 4.711265
##
## Residual Deviance: 656.7903
## AIC: 662.7903
Exercise 2 - Interpreting the coefficients
# Examine the coefficients of your saved model
summary(model)$coefficients
##
## Re-fitting to get Hessian
## Value Std. Error t value
## sales 0.4396276 0.04195604 10.478292
## 1|2 2.3624897 0.31440068 7.514264
## 2|3 4.7112647 0.38787767 12.146264
# Add p-values and odds ratios, and view
# What do you notice?
coefficients <- summary(model)$coefficients
##
## Re-fitting to get Hessian
# calculate p-values
p_value <- (1 - pnorm(abs(coefficients[ ,"t value"]), 0, 1))*2
# bind back to coefficients
coefficients <- cbind(coefficients, p_value)
# take exponents of coefficients to find odds
odds_ratio <- exp(coefficients[ ,"Value"])
# combine with coefficient and p_value
(coefficients <- cbind(coefficients[ ,c("Value", "p_value")],odds_ratio))
## Value p_value odds_ratio
## sales 0.4396276 0.000000e+00 1.552129
## 1|2 2.3624897 5.728751e-14 10.617352
## 2|3 4.7112647 0.000000e+00 111.192698
Write a sentence on the model results above.
Each additional million dollars in sales leaders to a 55% increase in
odds of being in the next highest performance group.
# Do you think this is a good model? Use the lipsitz test.
DescTools::PseudoR2(model)
## McFadden
## 0.170429
generalhoslem::lipsitz.test(model)
##
## Lipsitz goodness of fit test for ordinal response models
##
## data: formula: rating ~ sales
## LR statistic = 48.845, df = 9, p-value = 1.775e-07
Write a sentence on the results of this test.
Since the null hypothesis is the model is a good fit and our p-value
is very low, we can conclude that this model isn’t a good fit for our
data.
Exercise 3 - Add more information to the model
# Let's try a model to see how sales, new_customers, and gender impact rating
model2 <- polr(rating ~ sales + gender + new_customers, data = perf)
summary(model2)
##
## Re-fitting to get Hessian
## Call:
## polr(formula = rating ~ sales + gender + new_customers, data = perf)
##
## Coefficients:
## Value Std. Error t value
## sales 0.38000 0.04715 8.059
## genderM -0.04535 0.22788 -0.199
## new_customers 0.38875 0.04114 9.450
##
## Intercepts:
## Value Std. Error t value
## 1|2 4.7504 0.4912 9.6704
## 2|3 7.7564 0.6115 12.6842
##
## Residual Deviance: 541.1673
## AIC: 551.1673
# Add p-values and odds ratios, and view
# What do you notice?
coefficients <- summary(model2)$coefficients
##
## Re-fitting to get Hessian
# calculate p-values
p_value <- (1 - pnorm(abs(coefficients[ ,"t value"]), 0, 1))*2
# bind back to coefficients
coefficients <- cbind(coefficients, p_value)
# take exponents of coefficients to find odds
odds_ratio <- exp(coefficients[ ,"Value"])
# combine with coefficient and p_value
(coefficients <- cbind(coefficients[ ,c("Value", "p_value")],odds_ratio))
## Value p_value odds_ratio
## sales 0.37999918 6.661338e-16 1.4622834
## genderM -0.04534768 8.422617e-01 0.9556652
## new_customers 0.38875312 0.000000e+00 1.4751403
## 1|2 4.75035125 0.000000e+00 115.6248910
## 2|3 7.75643923 0.000000e+00 2336.5697976
Write a few sentences on the results of the model.
Each additional $1 million in sales results in a 46% increase in odds
of being in the next highest performance group. Each additional new
customer results in a 48% increase in odds of being in the next highest
performance group.
# Do you think this is a good model?
DescTools::PseudoR2(model2)
## McFadden
## 0.3164687
generalhoslem::lipsitz.test(model2)
##
## Lipsitz goodness of fit test for ordinal response models
##
## data: formula: rating ~ sales + gender + new_customers
## LR statistic = 12.595, df = 9, p-value = 0.1818
Write a sentence on the results of the Lipsitz test.
Our p-values is now > 0.05, so we do not reject the null
hypothesis and conclude that the model is a good fit.
Exercise 4: Test the proportional odds assumption
# First try the method where we compare the binary models to each other and use
# our judgement
perf$rating23 <- ifelse(perf$rating %in% c(2,3), 1, 0)
perf$rating3 <- ifelse(perf$rating == 3, 1, 0)
mod_23 <- glm(
rating23 ~ sales + gender + new_customers, data = perf, family = "binomial"
)
mod_3 <-glm(
rating3 ~ sales + gender + new_customers, data = perf, family = "binomial"
)
(coefficient_comparison <- data.frame(
mod_23 = summary(mod_23)$coefficients[ , "Estimate"],
mod_2 = summary(mod_3)$coefficients[ ,"Estimate"],
diff = summary(mod_3)$coefficients[ ,"Estimate"] -
summary(mod_23)$coefficients[ , "Estimate"]
))
## mod_23 mod_2 diff
## (Intercept) -5.7833168 -6.4370177 -0.6537010
## sales 0.4807825 0.3124403 -0.1683422
## genderM 0.1535632 -0.1687183 -0.3222815
## new_customers 0.4332273 0.3223194 -0.1109080
Using your best judgement, do you think the proportional odds
assumption is met?
These differences seem quite small, I would say that the assumption
is met.
# Alternatively with the Brant-Wald test
# What do you notice?
library(brant)
brant::brant(model2)
## --------------------------------------------
## Test for X2 df probability
## --------------------------------------------
## Omnibus 6.18 3 0.1
## sales 4.02 1 0.04
## genderM 0.7 1 0.4
## new_customers 2.45 1 0.12
## --------------------------------------------
##
## H0: Parallel Regression Assumption holds
Write your interpretation of the brant-wald test results.
The test shows that the assumption holds. Sales is the only
potentially problematic variable. We could try removing that from our
model.
================================================
FILE: docs/materials/module-exercises/03B-Ordinal_regression.Rmd
================================================
---
title: "03B-Ordinal_regression"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will conduct ordinal logistic regression on fictional data on employee performance evaluation metrics for a group of salespeople.
- sales: annual sales of the individual in millions of dollars
- new_customers: number of new customers acquired by individual
- region: region individual works in (North, South, East, West)
- gender: gender of individual
- rating: performance rating of individual (1 = Low, 2 = Middle, 3 = High)
## Exercise 1 - Running a simple ordinal logistic regression model
```{r}
# Download the employee performance dataset from the URL provided
url <- "https://peopleanalytics-regression-book.org/data/employee_performance.csv"
perf <- read.csv(url)
```
```{r}
# view the first few rows in the data set to acquaint yourself with the data
```
```{r}
# What do you think the datatypes are?
# sales:
# new_customers:
# region:
# gender:
# rating:
```
```{r}
# Perform any necessary datatype adjustments
```
```{r}
# Take a look at the pairs plot. What do you notice?
# Hint: Use GGally::ggpairs()
```
```{r}
# Run a simple ordinal logistic regression model to understand sales influence
# on rating, saving your model using a name of your choice
```
## Exercise 2 - Interpreting the coefficients
```{r}
# Examine the coefficients of your saved model
```
```{r}
# Add p-values and odds ratios, and view
# What do you notice?
```
Write a sentence on the model results above.
```{r}
# Do you think this is a good model? Use the lipsitz test.
```
Write a sentence on the results of this test.
## Exercise 3 - Add more information to the model
```{r}
# Let's try a model to see how sales, new_customers, and gender impact rating
```
```{r}
# Add p-values and odds ratios, and view
# What do you notice?
```
Write a few sentences on the results of the model.
```{r}
# Do you think this is a good model?
```
Write a sentence on the results of the Lipsitz test.
# Exercise 4: Test the proportional odds assumption
```{r}
# First try the method where we compare the binary models to each other and use
# our judgement
```
Using your best judgement, do you think the proportional odds assumption is met?
```{r}
# Alternatively with the Brant-Wald test
```
Write your interpretation of the brant-wald test results.
================================================
FILE: docs/materials/module-exercises/04-survival_analysis-SOLUTIONS.Rmd
================================================
---
title: "Survival Analysis Exercises"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will conduct survival analysis on a data set relating employee turnover to several variables that were measured at the time an employee was hired.
## Exercise 1 - Load, explore, and structure the survival data
```{r}
library(dplyr)
library(survival)
library(survminer)
library(lubridate)
# Load the survival analysis data file from the url provided
url <- "https://rstudio-conf-2022.github.io/people-analytics-rstats/data/survival_analysis_data.csv"
surv_data <- read.csv(url)
```
```{r}
# view the first few rows in the data set to acquaint yourself with the data
head(surv_data)
# convert columns ending in 'DATE' to date format
surv_data <- surv_data |>
dplyr::mutate(across(ends_with("DATE"), as.Date))
```
```{r}
# Create a censor indicator variable that is 1 if the employee has left and 0 otherwise
surv_data <-
surv_data |>
dplyr::mutate(
CENSOR = dplyr::case_when(
TURNOVER == "Yes" ~ 1,
TRUE ~ 0
)
)
```
```{r}
# Replace missing TURNOVER_DATE values with "2022-07-01" -- think about what missing TURNOVER_DATES mean
surv_data <-
surv_data |>
dplyr::mutate(
TURNOVER_DATE = dplyr::case_when(
is.na(TURNOVER_DATE) ~ as.Date("2022-07-01"),
TRUE ~ TURNOVER_DATE
)
)
```
```{r}
# Use the lubridate::interval() function to create the EVENT_TIME variable
# Hint: Use %/% months(1) to transform the time difference into months
surv_data <-
surv_data |>
dplyr::mutate(
EVENT_TIME = lubridate::interval(HIRE_DATE, TURNOVER_DATE) %/% months(1)
)
```
```{r}
# Calculate some descriptive statistics for EVENT_TIME using the full sample, then group the data by CENSOR to see how the descriptives
# change.
mean(surv_data$EVENT_TIME)
median(surv_data$EVENT_TIME)
surv_data |>
dplyr::group_by(
CENSOR
) |>
dplyr::summarise(
MEAN_EVENT_TIME = mean(EVENT_TIME),
MEDIAN_EVENT_TIME = median(EVENT_TIME),
SD_EVENT_TIME = sd(EVENT_TIME)
)
```
## Exercise 2 - Create a survival object and estimate survival functions using Kaplan Meier estimates
```{r}
# Create a survival object using survival::Surv().
# Remember it requires two arguments EVENT_TIME and CENSOR
surv_object <- survival::Surv(
event = surv_data$CENSOR,
time = surv_data$EVENT_TIME
)
```
```{r}
# Use survival::survfit() to estimate survival probabilities using the Kaplan Meier estimator for the entire sample
# Save the survfit output into an object called km_all
# How many months after hiring would you expect 50% of the sample to remain at the firm? (e.g. the median survival time)
# How many months after hiring would you expect 75% of the sample to remain at the firm?
km_all <- survival::survfit(surv_object ~ 1, data = surv_data)
summary(km_all)
```
```{r}
# Look at the structure of km_all using str()
str(km_all)
```
```{r}
# Using km_all, create a new data frame called km_calc which contains the following variables from km_all:
# time, n.risk, n.censor, n.event, and surv
km_calc <-
tibble::tibble(
time = km_all$time,
n.risk = km_all$n.risk,
n.censor = km_all$n.censor,
n.event = km_all$n.event,
survival = km_all$surv
)
```
```{r}
# Using km_calc, determine the following:
# How many turnovers occurred in the dataset?
sum(km_calc$n.event)
# How many censored observations are in the dataset?
sum(km_calc$n.censor)
# At what time point do the first censored observations appear?
min(which(km_calc$n.censor != 0))
# Subtract n.risk at time point 2 from n.risk at time point 1.
km_calc$n.risk[1] - km_calc$n.risk[2]
# Why did n.risk decrease from time point 1 to time point 2?
# n.risk at time point 2 = n.risk at time point 1 - n.events at time point 1 - n.censor at time point 1
# Subtract n.risk at time point 56 from time point 55.
km_calc$n.risk[55] - km_calc$n.risk[56]
# Why did n.risk decrease from time point 55 to time point 56?
# n.risk at time point 56 = n.risk at time point 55 - n.events at time point 55 - n.censor at time point 55
```
```{r}
# The formula to calculate the survival probabilities using the KM estimator is:
# survival(t - 1) * (1 - (n.event[t] / n.risk[t]))
# That is, the survival probability at time t is equal to the survival probability at time t-1 multiplied by 1 - (number of events at
# time t / number of individuals at risk at time t).
# Using the formula above, manual calculate the survival probabilities and save them as variable in km_calc as surv_calc. Take a moment to think about how censored observations are used in the calculation as well.
km_calc <-
km_calc |>
dplyr::mutate(
surv_calc_1 = (1 - n.event / n.risk),
surv_calc = cumprod(surv_calc_1)
)
```
Median: 47 months
75: 24 months
```{r}
# Use survminer::ggsurvplot() to plot the overall survival function.
survminer::ggsurvplot(fit = km_all)
```
```{r}
# Use survival::survfit() to estimate survival probabilities by the REFERRAL variable.
# For the portion of the sample that was referred for the job (REFERRAL == "Yes"), how many months after hiring would you expect 50% of the sample to remain at the firm? What about for the portion of the sample that was not referred?
# Why would the median survival time be missing?
km_ref <- survival::survfit(surv_object ~ REFERRAL, data = surv_data)
summary(km_ref)
```
Referral == "Yes"
Median is undefined as more than 50% remain after end of study.
Referral == "No"
Median: 44 months
```{r}
# Use survminer::ggsurvplot() to plot the survival function by REFERRAL status. Are the two curves different?
survminer::ggsurvplot(km_ref)
```
```{r}
# Using the survfit function, estimate the survival probabilities for the interaction between REFERRAL and NUMBER_JOBS variables in
# surv_data. Then plot the survival curve using ggsurvplot and provide an interpretation of the curves. Does their appear to be an
# interaction?
#
# HINT: You don't need to create a new variable!
km_ref_job <- survival::survfit(surv_object ~ REFERRAL + NUMBER_JOBS, data = surv_data)
survminer::ggsurvplot(km_ref_job)
```
## Exercise 3 - Fit a cox proportional hazards model to your data.
```{r}
# Estimate a cox proportional hazards model. Include all of the main effects and the interactions between INTPER_RATE and PROG_EXER_RATE as well as HIRE_REC and REFERRAL.
# HINT: An interaction variable is created by multiplying Variable 1 with Variable 2 (Variable 1 * Variable 2).
mod_1 <- survival::coxph(
surv_object ~ NUMBER_JOBS + PROG_EXER_RATE +
INTPER_RATE + PRIOR_EXP + HIRE_REC*REFERRAL + INTPER_RATE*PROG_EXER_RATE,
data = surv_data
)
```
```{r}
# View the coefficient estimates and standard errors of the model
summary(mod_1)
```
```{r}
# Estimate a cox proportional hazards model that only includes the main effects (no interactions).
mod_2 <- survival::coxph(
surv_object ~ NUMBER_JOBS + PROG_EXER_RATE +
INTPER_RATE + PRIOR_EXP + HIRE_REC + REFERRAL,
data = surv_data
)
```
```{r}
# View the coefficient estimates and standard errors for the main effects model.
summary(mod_2)
```
```{r}
# Compare the model you fit above to a model that only includes the main effects (no interactions). Use the anova() function to determine if the model with interactions fits your data significantly better than the model with main effects only. If you are unsure of how to use the anova() function, then view the help documentation on it ?anova.coxph or exercise solutions.
anova(mod_1, mod_2)
```
```{r}
# Based on the model comparison above, decide if you should choose the more complicated interaction model or the less complicated main effects model. Using the model you decided on, test the proportional hazard assumption and determine if any variables violate it. If they do decide if you should drop them from the model.
survival::cox.zph(mod_2)
mod <- survival::coxph(
surv_object ~ REFERRAL + NUMBER_JOBS + PROG_EXER_RATE +
INTPER_RATE + HIRE_REC,
data = surv_data
)
```
Prior experience is close to violating the assumption and is unrelated to attrition, so we can safely drop it from the model
## Exercise 4 - Interpreting the proportional hazards results.
```{r}
# Using the final model you decided on during last exercise, provide an interpretation of each of the predictors you kept in the model.
summary(mod)
```
Referral reduces hazard by a factor of .38 (~62%).
No difference between 0-1 and 2 jobs prior to hiring.
Having 3+ jobs in the year before hire increases hazard by a factor of 1.50 (50%).
Compared to a "Concerns" rating on the programming exercise, Pass and Pass+ both reduce hazard by factors of .79 (21%) and .73 (27%), respectively.
Every unit increase in interpersonal skills reduces the hazard by a factor of .91 (9%).
Every additional increase in hiring rec reduces hazard by a factor of .92 (8%).
```{r}
# Use the function confint() to calculate the 95% confidence intervals for each coefficient.
# Transform the confidence intervals so that they can be interpreted as confidence intervals for exp(coef).
confint(mod)
exp(confint(mod))
```
## Exercise 5 - Creating predicted survival curves from your proportional hazards model.
```{r}
# Create a new data frame that contains a column for each of the variables you included in your Cox regression model. Pick of variable you are interested in and provide different values for that variable (the values need to occur in the original data frame) while holding the other variables constant (e.g. NUMBER_JOBS == "0-1" for all rows in the new data frame).
new_data <- data.frame(REFERRAL = c("No", "Yes"),
NUMBER_JOBS = c("3+", "3+"),
PROG_EXER_RATE = c("Concerns", "Concerns"),
INTPER_RATE = c(1, 1),
PRIOR_EXP = c("No", "No"),
HIRE_REC = c(0, 0))
```
```{r}
# With your new data frame and your estimated Cox regression model, use the function: survival::survfit() to create predicted survival probabilities from your model and new data frame.
# Using summary(), explore these new probabilities.
predicted_surv_prob <- survival::survfit(mod, newdata = new_data)
summary(predicted_surv_prob)
```
```{r}
# With your new data frame and your estimated Cox regression model, use the function: survminer::ggadjustedcurves() to plot your predicted survival functions. If you are familiar with ggplot2, then try to customize the plot output.
survminer::ggadjustedcurves(mod,
data = new_data, variable = "REFERRAL",
ylab = "Probability of Staying",
xlab = "Months Since Hire",
ggtheme = ggplot2::theme_minimal()) +
ggplot2::labs(color = "Referral")
```
Using the results of your final Cox regression model and your predicted survival functions to write a high-level business summary of what predictor or predictors you believe to be the most important to focus on to reduce attrition.
================================================
FILE: docs/materials/module-exercises/04-survival_analysis-SOLUTIONS.html
================================================
In this document we will conduct survival analysis on a data set
relating employee turnover to several variables that were measured at
the time an employee was hired.
Exercise 1 - Load, explore, and structure the survival data
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
library(survival)
library(survminer)
## Loading required package: ggplot2
## Loading required package: ggpubr
##
## Attaching package: 'survminer'
## The following object is masked from 'package:survival':
##
## myeloma
library(lubridate)
##
## Attaching package: 'lubridate'
## The following objects are masked from 'package:base':
##
## date, intersect, setdiff, union
# Load the survival analysis data file from the url provided
url <- "https://rstudio-conf-2022.github.io/people-analytics-rstats/data/survival_analysis_data.csv"
surv_data <- read.csv(url)
# view the first few rows in the data set to acquaint yourself with the data
head(surv_data)
## EID REFERRAL NUMBER_JOBS PROG_EXER_RATE INTPER_RATE PRIOR_EXP HIRE_REC
## 1 453921 No 2 Pass 6 Yes 2
## 2 732470 No 3+ Pass 10 No 2
## 3 169619 No 3+ Concerns 10 No 1
## 4 953421 No 0-1 Concerns 6 No 2
## 5 363973 No 2 Pass 10 Yes 3
## 6 779914 No 0-1 Pass 7 No 2
## HIRE_DATE TURNOVER_DATE TURNOVER
## 1 2017-02-01 <NA> No
## 2 2016-02-01 2017-12-01 Yes
## 3 2016-02-01 <NA> No
## 4 2017-02-01 2017-07-01 Yes
## 5 2016-02-01 <NA> No
## 6 2017-01-01 2021-01-01 Yes
# convert columns ending in 'DATE' to date format
surv_data <- surv_data |>
dplyr::mutate(across(ends_with("DATE"), as.Date))
# Create a censor indicator variable that is 1 if the employee has left and 0 otherwise
surv_data <-
surv_data |>
dplyr::mutate(
CENSOR = dplyr::case_when(
TURNOVER == "Yes" ~ 1,
TRUE ~ 0
)
)
# Replace missing TURNOVER_DATE values with "2022-07-01" -- think about what missing TURNOVER_DATES mean
surv_data <-
surv_data |>
dplyr::mutate(
TURNOVER_DATE = dplyr::case_when(
is.na(TURNOVER_DATE) ~ as.Date("2022-07-01"),
TRUE ~ TURNOVER_DATE
)
)
# Use the lubridate::interval() function to create the EVENT_TIME variable
# Hint: Use %/% months(1) to transform the time difference into months
surv_data <-
surv_data |>
dplyr::mutate(
EVENT_TIME = lubridate::interval(HIRE_DATE, TURNOVER_DATE) %/% months(1)
)
# Calculate some descriptive statistics for EVENT_TIME using the full sample, then group the data by CENSOR to see how the descriptives
# change.
mean(surv_data$EVENT_TIME)
## [1] 43.20513
median(surv_data$EVENT_TIME)
## [1] 47
surv_data |>
dplyr::group_by(
CENSOR
) |>
dplyr::summarise(
MEAN_EVENT_TIME = mean(EVENT_TIME),
MEDIAN_EVENT_TIME = median(EVENT_TIME),
SD_EVENT_TIME = sd(EVENT_TIME)
)
## # A tibble: 2 x 4
## CENSOR MEAN_EVENT_TIME MEDIAN_EVENT_TIME SD_EVENT_TIME
## <dbl> <dbl> <dbl> <dbl>
## 1 0 69.9 66 6.54
## 2 1 28.0 27 17.6
Exercise 2 - Create a survival object and estimate survival
functions using Kaplan Meier estimates
# Create a survival object using survival::Surv().
# Remember it requires two arguments EVENT_TIME and CENSOR
surv_object <- survival::Surv(
event = surv_data$CENSOR,
time = surv_data$EVENT_TIME
)
# Use survival::survfit() to estimate survival probabilities using the Kaplan Meier estimator for the entire sample
# Save the survfit output into an object called km_all
# How many months after hiring would you expect 50% of the sample to remain at the firm? (e.g. the median survival time)
# How many months after hiring would you expect 75% of the sample to remain at the firm?
km_all <- survival::survfit(surv_object ~ 1, data = surv_data)
summary(km_all)
## Call: survfit(formula = surv_object ~ 1, data = surv_data)
##
## time n.risk n.event survival std.err lower 95% CI upper 95% CI
## 1 8000 182 0.977 0.00167 0.974 0.981
## 2 7818 181 0.955 0.00233 0.950 0.959
## 3 7637 187 0.931 0.00283 0.926 0.937
## 4 7450 135 0.914 0.00313 0.908 0.921
## 5 7315 128 0.898 0.00338 0.892 0.905
## 6 7187 110 0.885 0.00357 0.878 0.892
## 7 7077 87 0.874 0.00371 0.867 0.881
## 8 6990 68 0.865 0.00382 0.858 0.873
## 9 6922 41 0.860 0.00388 0.853 0.868
## 10 6881 58 0.853 0.00396 0.845 0.861
## 11 6823 36 0.848 0.00401 0.841 0.856
## 12 6787 35 0.844 0.00406 0.836 0.852
## 13 6752 27 0.841 0.00409 0.833 0.849
## 14 6725 29 0.837 0.00413 0.829 0.845
## 15 6696 38 0.832 0.00418 0.824 0.840
## 16 6658 41 0.827 0.00423 0.819 0.835
## 17 6617 36 0.823 0.00427 0.814 0.831
## 18 6581 46 0.817 0.00432 0.808 0.825
## 19 6535 57 0.810 0.00439 0.801 0.818
## 20 6478 69 0.801 0.00446 0.792 0.810
## 21 6409 93 0.789 0.00456 0.781 0.798
## 22 6316 117 0.775 0.00467 0.766 0.784
## 23 6199 134 0.758 0.00479 0.749 0.768
## 24 6065 124 0.743 0.00489 0.733 0.752
## 25 5941 163 0.722 0.00501 0.713 0.732
## 26 5778 218 0.695 0.00515 0.685 0.705
## 27 5560 197 0.670 0.00526 0.660 0.681
## 28 5363 199 0.645 0.00535 0.635 0.656
## 29 5164 178 0.623 0.00542 0.613 0.634
## 30 4986 160 0.603 0.00547 0.593 0.614
## 31 4826 117 0.589 0.00550 0.578 0.600
## 32 4709 94 0.577 0.00552 0.566 0.588
## 33 4615 76 0.567 0.00554 0.557 0.578
## 34 4539 51 0.561 0.00555 0.550 0.572
## 35 4488 32 0.557 0.00555 0.546 0.568
## 36 4456 15 0.555 0.00556 0.544 0.566
## 37 4441 12 0.554 0.00556 0.543 0.565
## 38 4429 16 0.552 0.00556 0.541 0.563
## 39 4413 15 0.550 0.00556 0.539 0.561
## 40 4398 26 0.547 0.00557 0.536 0.558
## 41 4372 47 0.541 0.00557 0.530 0.552
## 42 4325 55 0.534 0.00558 0.523 0.545
## 43 4270 59 0.526 0.00558 0.516 0.537
## 44 4211 59 0.519 0.00559 0.508 0.530
## 45 4152 85 0.508 0.00559 0.498 0.519
## 46 4067 64 0.500 0.00559 0.490 0.511
## 47 4003 83 0.490 0.00559 0.479 0.501
## 48 3920 100 0.478 0.00558 0.467 0.489
## 49 3820 122 0.462 0.00557 0.451 0.473
## 50 3698 97 0.450 0.00556 0.439 0.461
## 51 3601 90 0.439 0.00555 0.428 0.450
## 52 3511 91 0.428 0.00553 0.417 0.438
## 53 3420 88 0.417 0.00551 0.406 0.427
## 54 3332 88 0.406 0.00549 0.395 0.416
## 55 3244 68 0.397 0.00547 0.386 0.408
## 56 3152 57 0.390 0.00545 0.379 0.401
## 57 3088 41 0.385 0.00544 0.374 0.395
## 58 3040 39 0.380 0.00543 0.369 0.390
## 59 2951 39 0.375 0.00542 0.364 0.385
## 60 2868 18 0.372 0.00541 0.362 0.383
## 61 2813 11 0.371 0.00541 0.360 0.382
## 62 2726 2 0.371 0.00541 0.360 0.381
## 63 2645 3 0.370 0.00540 0.360 0.381
## 64 2496 3 0.370 0.00540 0.359 0.380
## 65 2353 1 0.370 0.00540 0.359 0.380
## 67 1502 2 0.369 0.00541 0.359 0.380
## 68 1485 9 0.367 0.00543 0.356 0.378
## 69 1461 9 0.365 0.00545 0.354 0.375
## 70 1445 10 0.362 0.00547 0.352 0.373
## 71 1403 13 0.359 0.00549 0.348 0.370
## 72 1348 9 0.356 0.00551 0.346 0.367
# Look at the structure of km_all using str()
str(km_all)
## List of 16
## $ n : int 8000
## $ time : num [1:78] 1 2 3 4 5 6 7 8 9 10 ...
## $ n.risk : num [1:78] 8000 7818 7637 7450 7315 ...
## $ n.event : num [1:78] 182 181 187 135 128 110 87 68 41 58 ...
## $ n.censor : num [1:78] 0 0 0 0 0 0 0 0 0 0 ...
## $ surv : num [1:78] 0.977 0.955 0.931 0.914 0.898 ...
## $ std.err : num [1:78] 0.00171 0.00244 0.00304 0.00342 0.00376 ...
## $ cumhaz : num [1:78] 0.0227 0.0459 0.0704 0.0885 0.106 ...
## $ std.chaz : num [1:78] 0.00169 0.00241 0.003 0.00338 0.00372 ...
## $ type : chr "right"
## $ logse : logi TRUE
## $ conf.int : num 0.95
## $ conf.type: chr "log"
## $ lower : num [1:78] 0.974 0.95 0.926 0.908 0.892 ...
## $ upper : num [1:78] 0.981 0.959 0.937 0.921 0.905 ...
## $ call : language survfit(formula = surv_object ~ 1, data = surv_data)
## - attr(*, "class")= chr "survfit"
# Using km_all, create a new data frame called km_calc which contains the following variables from km_all:
# time, n.risk, n.censor, n.event, and surv
km_calc <-
tibble::tibble(
time = km_all$time,
n.risk = km_all$n.risk,
n.censor = km_all$n.censor,
n.event = km_all$n.event,
survival = km_all$surv
)
# Using km_calc, determine the following:
# How many turnovers occurred in the dataset?
sum(km_calc$n.event)
## [1] 5090
# How many censored observations are in the dataset?
sum(km_calc$n.censor)
## [1] 2910
# At what time point do the first censored observations appear?
min(which(km_calc$n.censor != 0))
## [1] 55
# Subtract n.risk at time point 2 from n.risk at time point 1.
km_calc$n.risk[1] - km_calc$n.risk[2]
## [1] 182
# Why did n.risk decrease from time point 1 to time point 2?
# n.risk at time point 2 = n.risk at time point 1 - n.events at time point 1 - n.censor at time point 1
# Subtract n.risk at time point 56 from time point 55.
km_calc$n.risk[55] - km_calc$n.risk[56]
## [1] 92
# Why did n.risk decrease from time point 55 to time point 56?
# n.risk at time point 56 = n.risk at time point 55 - n.events at time point 55 - n.censor at time point 55
# The formula to calculate the survival probabilities using the KM estimator is:
# survival(t - 1) * (1 - (n.event[t] / n.risk[t]))
# That is, the survival probability at time t is equal to the survival probability at time t-1 multiplied by 1 - (number of events at
# time t / number of individuals at risk at time t).
# Using the formula above, manual calculate the survival probabilities and save them as variable in km_calc as surv_calc. Take a moment to think about how censored observations are used in the calculation as well.
km_calc <-
km_calc |>
dplyr::mutate(
surv_calc_1 = (1 - n.event / n.risk),
surv_calc = cumprod(surv_calc_1)
)
Median: 47 months 75: 24 months
# Use survminer::ggsurvplot() to plot the overall survival function.
survminer::ggsurvplot(fit = km_all)
# Use survival::survfit() to estimate survival probabilities by the REFERRAL variable.
# For the portion of the sample that was referred for the job (REFERRAL == "Yes"), how many months after hiring would you expect 50% of the sample to remain at the firm? What about for the portion of the sample that was not referred?
# Why would the median survival time be missing?
km_ref <- survival::survfit(surv_object ~ REFERRAL, data = surv_data)
summary(km_ref)
## Call: survfit(formula = surv_object ~ REFERRAL, data = surv_data)
##
## REFERRAL=No
## time n.risk n.event survival std.err lower 95% CI upper 95% CI
## 1 7230 178 0.975 0.00182 0.972 0.979
## 2 7052 171 0.952 0.00252 0.947 0.957
## 3 6881 180 0.927 0.00306 0.921 0.933
## 4 6701 131 0.909 0.00339 0.902 0.915
## 5 6570 122 0.892 0.00365 0.885 0.899
## 6 6448 105 0.877 0.00386 0.870 0.885
## 7 6343 86 0.865 0.00401 0.858 0.873
## 8 6257 65 0.856 0.00412 0.848 0.865
## 9 6192 40 0.851 0.00419 0.843 0.859
## 10 6152 55 0.843 0.00428 0.835 0.852
## 11 6097 32 0.839 0.00432 0.830 0.847
## 12 6065 32 0.834 0.00437 0.826 0.843
## 13 6033 27 0.831 0.00441 0.822 0.839
## 14 6006 28 0.827 0.00445 0.818 0.836
## 15 5978 34 0.822 0.00450 0.813 0.831
## 16 5944 39 0.817 0.00455 0.808 0.826
## 17 5905 35 0.812 0.00460 0.803 0.821
## 18 5870 42 0.806 0.00465 0.797 0.815
## 19 5828 55 0.798 0.00472 0.789 0.808
## 20 5773 67 0.789 0.00480 0.780 0.799
## 21 5706 87 0.777 0.00489 0.768 0.787
## 22 5619 110 0.762 0.00501 0.752 0.772
## 23 5509 129 0.744 0.00513 0.734 0.754
## 24 5380 116 0.728 0.00523 0.718 0.738
## 25 5264 157 0.706 0.00536 0.696 0.717
## 26 5107 210 0.677 0.00550 0.667 0.688
## 27 4897 191 0.651 0.00561 0.640 0.662
## 28 4706 192 0.624 0.00570 0.613 0.636
## 29 4514 170 0.601 0.00576 0.590 0.612
## 30 4344 148 0.580 0.00580 0.569 0.592
## 31 4196 111 0.565 0.00583 0.554 0.577
## 32 4085 86 0.553 0.00585 0.542 0.565
## 33 3999 71 0.543 0.00586 0.532 0.555
## 34 3928 49 0.537 0.00586 0.525 0.548
## 35 3879 30 0.532 0.00587 0.521 0.544
## 36 3849 14 0.530 0.00587 0.519 0.542
## 37 3835 12 0.529 0.00587 0.517 0.540
## 38 3823 15 0.527 0.00587 0.515 0.538
## 39 3808 14 0.525 0.00587 0.513 0.536
## 40 3794 24 0.521 0.00587 0.510 0.533
## 41 3770 45 0.515 0.00588 0.504 0.527
## 42 3725 48 0.509 0.00588 0.497 0.520
## 43 3677 55 0.501 0.00588 0.490 0.513
## 44 3622 54 0.493 0.00588 0.482 0.505
## 45 3568 83 0.482 0.00588 0.471 0.494
## 46 3485 59 0.474 0.00587 0.462 0.486
## 47 3426 77 0.463 0.00586 0.452 0.475
## 48 3349 93 0.450 0.00585 0.439 0.462
## 49 3256 115 0.434 0.00583 0.423 0.446
## 50 3141 89 0.422 0.00581 0.411 0.434
## 51 3052 86 0.410 0.00578 0.399 0.422
## 52 2966 84 0.399 0.00576 0.387 0.410
## 53 2882 81 0.387 0.00573 0.376 0.399
## 54 2801 86 0.376 0.00570 0.365 0.387
## 55 2715 59 0.367 0.00567 0.356 0.379
## 56 2638 53 0.360 0.00565 0.349 0.371
## 57 2579 39 0.355 0.00563 0.344 0.366
## 58 2534 35 0.350 0.00561 0.339 0.361
## 59 2451 36 0.345 0.00559 0.334 0.356
## 60 2376 16 0.342 0.00558 0.331 0.353
## 61 2329 9 0.341 0.00558 0.330 0.352
## 62 2256 2 0.341 0.00558 0.330 0.352
## 63 2183 3 0.340 0.00558 0.329 0.351
## 64 2058 3 0.340 0.00558 0.329 0.351
## 65 1942 1 0.339 0.00558 0.329 0.351
## 67 1227 2 0.339 0.00558 0.328 0.350
## 68 1212 9 0.336 0.00560 0.326 0.348
## 69 1189 8 0.334 0.00562 0.323 0.345
## 70 1177 9 0.332 0.00564 0.321 0.343
## 71 1143 12 0.328 0.00567 0.317 0.339
## 72 1100 9 0.325 0.00570 0.314 0.337
##
## REFERRAL=Yes
## time n.risk n.event survival std.err lower 95% CI upper 95% CI
## 1 770 4 0.995 0.00259 0.990 1.000
## 2 766 10 0.982 0.00481 0.972 0.991
## 3 756 7 0.973 0.00587 0.961 0.984
## 4 749 4 0.968 0.00639 0.955 0.980
## 5 745 6 0.960 0.00708 0.946 0.974
## 6 739 5 0.953 0.00761 0.938 0.968
## 7 734 1 0.952 0.00771 0.937 0.967
## 8 733 3 0.948 0.00800 0.933 0.964
## 9 730 1 0.947 0.00809 0.931 0.963
## 10 729 3 0.943 0.00836 0.927 0.959
## 11 726 4 0.938 0.00871 0.921 0.955
## 12 722 3 0.934 0.00896 0.916 0.951
## 14 719 1 0.932 0.00904 0.915 0.950
## 15 718 4 0.927 0.00936 0.909 0.946
## 16 714 2 0.925 0.00951 0.906 0.944
## 17 712 1 0.923 0.00959 0.905 0.942
## 18 711 4 0.918 0.00988 0.899 0.938
## 19 707 2 0.916 0.01002 0.896 0.935
## 20 705 2 0.913 0.01016 0.893 0.933
## 21 703 6 0.905 0.01056 0.885 0.926
## 22 697 7 0.896 0.01100 0.875 0.918
## 23 690 5 0.890 0.01129 0.868 0.912
## 24 685 8 0.879 0.01174 0.857 0.903
## 25 677 6 0.871 0.01206 0.848 0.895
## 26 671 8 0.861 0.01247 0.837 0.886
## 27 663 6 0.853 0.01275 0.829 0.879
## 28 657 7 0.844 0.01307 0.819 0.870
## 29 650 8 0.834 0.01342 0.808 0.860
## 30 642 12 0.818 0.01390 0.791 0.846
## 31 630 6 0.810 0.01413 0.783 0.839
## 32 624 8 0.800 0.01441 0.772 0.829
## 33 616 5 0.794 0.01459 0.765 0.823
## 34 611 2 0.791 0.01465 0.763 0.820
## 35 609 2 0.788 0.01472 0.760 0.818
## 36 607 1 0.787 0.01475 0.759 0.816
## 38 606 1 0.786 0.01479 0.757 0.815
## 39 605 1 0.784 0.01482 0.756 0.814
## 40 604 2 0.782 0.01488 0.753 0.812
## 41 602 2 0.779 0.01495 0.750 0.809
## 42 600 7 0.770 0.01516 0.741 0.800
## 43 593 4 0.765 0.01528 0.736 0.795
## 44 589 5 0.758 0.01543 0.729 0.789
## 45 584 2 0.756 0.01548 0.726 0.787
## 46 582 5 0.749 0.01562 0.719 0.781
## 47 577 6 0.742 0.01578 0.711 0.773
## 48 571 7 0.732 0.01595 0.702 0.764
## 49 564 7 0.723 0.01612 0.692 0.756
## 50 557 8 0.713 0.01630 0.682 0.746
## 51 549 4 0.708 0.01639 0.676 0.741
## 52 545 7 0.699 0.01653 0.667 0.732
## 53 538 7 0.690 0.01667 0.658 0.723
## 54 531 2 0.687 0.01671 0.655 0.721
## 55 529 9 0.675 0.01687 0.643 0.709
## 56 514 4 0.670 0.01695 0.638 0.704
## 57 509 2 0.667 0.01698 0.635 0.702
## 58 506 4 0.662 0.01705 0.630 0.696
## 59 500 3 0.658 0.01710 0.626 0.693
## 60 492 2 0.656 0.01714 0.623 0.690
## 61 484 2 0.653 0.01717 0.620 0.687
## 69 272 1 0.650 0.01728 0.617 0.685
## 70 268 1 0.648 0.01738 0.615 0.683
## 71 260 1 0.645 0.01749 0.612 0.681
Referral == “Yes” Median is undefined as more than 50% remain after
end of study.
Referral == “No” Median: 44 months
# Use survminer::ggsurvplot() to plot the survival function by REFERRAL status. Are the two curves different?
survminer::ggsurvplot(km_ref)
# Using the survfit function, estimate the survival probabilities for the interaction between REFERRAL and NUMBER_JOBS variables in
# surv_data. Then plot the survival curve using ggsurvplot and provide an interpretation of the curves. Does their appear to be an
# interaction?
#
# HINT: You don't need to create a new variable!
km_ref_job <- survival::survfit(surv_object ~ REFERRAL + NUMBER_JOBS, data = surv_data)
survminer::ggsurvplot(km_ref_job)
Exercise 3 - Fit a cox proportional hazards model to your data.
# Estimate a cox proportional hazards model. Include all of the main effects and the interactions between INTPER_RATE and PROG_EXER_RATE as well as HIRE_REC and REFERRAL.
# HINT: An interaction variable is created by multiplying Variable 1 with Variable 2 (Variable 1 * Variable 2).
mod_1 <- survival::coxph(
surv_object ~ NUMBER_JOBS + PROG_EXER_RATE +
INTPER_RATE + PRIOR_EXP + HIRE_REC*REFERRAL + INTPER_RATE*PROG_EXER_RATE,
data = surv_data
)
# View the coefficient estimates and standard errors of the model
summary(mod_1)
## Call:
## survival::coxph(formula = surv_object ~ NUMBER_JOBS + PROG_EXER_RATE +
## INTPER_RATE + PRIOR_EXP + HIRE_REC * REFERRAL + INTPER_RATE *
## PROG_EXER_RATE, data = surv_data)
##
## n= 8000, number of events= 5090
##
## coef exp(coef) se(coef) z Pr(>|z|)
## NUMBER_JOBS2 0.01200 1.01207 0.03188 0.376 0.7067
## NUMBER_JOBS3+ 0.40501 1.49932 0.04401 9.204 < 2e-16 ***
## PROG_EXER_RATEPass -0.29343 0.74570 0.14419 -2.035 0.0418 *
## PROG_EXER_RATEPass+ -0.47220 0.62363 0.24214 -1.950 0.0512 .
## INTPER_RATE -0.10119 0.90376 0.01485 -6.816 9.38e-12 ***
## PRIOR_EXPYes -0.01543 0.98469 0.03225 -0.478 0.6323
## HIRE_REC -0.08397 0.91946 0.01986 -4.227 2.36e-05 ***
## REFERRALYes -0.90587 0.40419 0.19274 -4.700 2.60e-06 ***
## HIRE_REC:REFERRALYes -0.02592 0.97441 0.08550 -0.303 0.7618
## PROG_EXER_RATEPass:INTPER_RATE 0.00691 1.00693 0.01700 0.406 0.6844
## PROG_EXER_RATEPass+:INTPER_RATE 0.01875 1.01893 0.02841 0.660 0.5093
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## exp(coef) exp(-coef) lower .95 upper .95
## NUMBER_JOBS2 1.0121 0.9881 0.9508 1.0773
## NUMBER_JOBS3+ 1.4993 0.6670 1.3754 1.6344
## PROG_EXER_RATEPass 0.7457 1.3410 0.5621 0.9892
## PROG_EXER_RATEPass+ 0.6236 1.6035 0.3880 1.0024
## INTPER_RATE 0.9038 1.1065 0.8778 0.9304
## PRIOR_EXPYes 0.9847 1.0156 0.9244 1.0489
## HIRE_REC 0.9195 1.0876 0.8843 0.9560
## REFERRALYes 0.4042 2.4741 0.2770 0.5897
## HIRE_REC:REFERRALYes 0.9744 1.0263 0.8241 1.1522
## PROG_EXER_RATEPass:INTPER_RATE 1.0069 0.9931 0.9739 1.0411
## PROG_EXER_RATEPass+:INTPER_RATE 1.0189 0.9814 0.9637 1.0773
##
## Concordance= 0.59 (se = 0.004 )
## Likelihood ratio test= 621.4 on 11 df, p=<2e-16
## Wald test = 573.6 on 11 df, p=<2e-16
## Score (logrank) test = 596.4 on 11 df, p=<2e-16
# Estimate a cox proportional hazards model that only includes the main effects (no interactions).
mod_2 <- survival::coxph(
surv_object ~ NUMBER_JOBS + PROG_EXER_RATE +
INTPER_RATE + PRIOR_EXP + HIRE_REC + REFERRAL,
data = surv_data
)
# View the coefficient estimates and standard errors for the main effects model.
summary(mod_2)
## Call:
## survival::coxph(formula = surv_object ~ NUMBER_JOBS + PROG_EXER_RATE +
## INTPER_RATE + PRIOR_EXP + HIRE_REC + REFERRAL, data = surv_data)
##
## n= 8000, number of events= 5090
##
## coef exp(coef) se(coef) z Pr(>|z|)
## NUMBER_JOBS2 0.011914 1.011985 0.031884 0.374 0.709
## NUMBER_JOBS3+ 0.404358 1.498340 0.043982 9.194 < 2e-16 ***
## PROG_EXER_RATEPass -0.236436 0.789437 0.034121 -6.929 4.23e-12 ***
## PROG_EXER_RATEPass+ -0.316998 0.728333 0.055603 -5.701 1.19e-08 ***
## INTPER_RATE -0.094790 0.909564 0.006966 -13.607 < 2e-16 ***
## PRIOR_EXPYes -0.015768 0.984356 0.032248 -0.489 0.625
## HIRE_REC -0.085417 0.918129 0.019324 -4.420 9.86e-06 ***
## REFERRALYes -0.962249 0.382033 0.062635 -15.363 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## exp(coef) exp(-coef) lower .95 upper .95
## NUMBER_JOBS2 1.0120 0.9882 0.9507 1.0772
## NUMBER_JOBS3+ 1.4983 0.6674 1.3746 1.6332
## PROG_EXER_RATEPass 0.7894 1.2667 0.7384 0.8440
## PROG_EXER_RATEPass+ 0.7283 1.3730 0.6531 0.8122
## INTPER_RATE 0.9096 1.0994 0.8972 0.9221
## PRIOR_EXPYes 0.9844 1.0159 0.9241 1.0486
## HIRE_REC 0.9181 1.0892 0.8840 0.9536
## REFERRALYes 0.3820 2.6176 0.3379 0.4319
##
## Concordance= 0.59 (se = 0.004 )
## Likelihood ratio test= 620.9 on 8 df, p=<2e-16
## Wald test = 572.2 on 8 df, p=<2e-16
## Score (logrank) test = 590.3 on 8 df, p=<2e-16
# Compare the model you fit above to a model that only includes the main effects (no interactions). Use the anova() function to determine if the model with interactions fits your data significantly better than the model with main effects only. If you are unsure of how to use the anova() function, then view the help documentation on it ?anova.coxph or exercise solutions.
anova(mod_1, mod_2)
## Analysis of Deviance Table
## Cox model: response is surv_object
## Model 1: ~ NUMBER_JOBS + PROG_EXER_RATE + INTPER_RATE + PRIOR_EXP + HIRE_REC * REFERRAL + INTPER_RATE * PROG_EXER_RATE
## Model 2: ~ NUMBER_JOBS + PROG_EXER_RATE + INTPER_RATE + PRIOR_EXP + HIRE_REC + REFERRAL
## loglik Chisq Df P(>|Chi|)
## 1 -43245
## 2 -43245 0.551 3 0.9076
# Based on the model comparison above, decide if you should choose the more complicated interaction model or the less complicated main effects model. Using the model you decided on, test the proportional hazard assumption and determine if any variables violate it. If they do decide if you should drop them from the model.
survival::cox.zph(mod_2)
## chisq df p
## NUMBER_JOBS 2.461 2 0.292
## PROG_EXER_RATE 1.294 2 0.523
## INTPER_RATE 0.129 1 0.720
## PRIOR_EXP 3.790 1 0.052
## HIRE_REC 1.542 1 0.214
## REFERRAL 0.174 1 0.677
## GLOBAL 9.414 8 0.309
mod <- survival::coxph(
surv_object ~ REFERRAL + NUMBER_JOBS + PROG_EXER_RATE +
INTPER_RATE + HIRE_REC,
data = surv_data
)
Prior experience is close to violating the assumption and is
unrelated to attrition, so we can safely drop it from the model ##
Exercise 4 - Interpreting the proportional hazards results.
# Using the final model you decided on during last exercise, provide an interpretation of each of the predictors you kept in the model.
summary(mod)
## Call:
## survival::coxph(formula = surv_object ~ REFERRAL + NUMBER_JOBS +
## PROG_EXER_RATE + INTPER_RATE + HIRE_REC, data = surv_data)
##
## n= 8000, number of events= 5090
##
## coef exp(coef) se(coef) z Pr(>|z|)
## REFERRALYes -0.962134 0.382077 0.062635 -15.361 < 2e-16 ***
## NUMBER_JOBS2 0.012290 1.012366 0.031874 0.386 0.7
## NUMBER_JOBS3+ 0.404310 1.498268 0.043982 9.193 < 2e-16 ***
## PROG_EXER_RATEPass -0.236269 0.789568 0.034119 -6.925 4.37e-12 ***
## PROG_EXER_RATEPass+ -0.316808 0.728470 0.055602 -5.698 1.21e-08 ***
## INTPER_RATE -0.094830 0.909528 0.006966 -13.613 < 2e-16 ***
## HIRE_REC -0.085499 0.918054 0.019324 -4.425 9.66e-06 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## exp(coef) exp(-coef) lower .95 upper .95
## REFERRALYes 0.3821 2.6173 0.3379 0.4320
## NUMBER_JOBS2 1.0124 0.9878 0.9511 1.0776
## NUMBER_JOBS3+ 1.4983 0.6674 1.3745 1.6332
## PROG_EXER_RATEPass 0.7896 1.2665 0.7385 0.8442
## PROG_EXER_RATEPass+ 0.7285 1.3727 0.6533 0.8123
## INTPER_RATE 0.9095 1.0995 0.8972 0.9220
## HIRE_REC 0.9181 1.0893 0.8839 0.9535
##
## Concordance= 0.59 (se = 0.004 )
## Likelihood ratio test= 620.6 on 7 df, p=<2e-16
## Wald test = 571.8 on 7 df, p=<2e-16
## Score (logrank) test = 590 on 7 df, p=<2e-16
Referral reduces hazard by a factor of .38 (~62%). No difference
between 0-1 and 2 jobs prior to hiring. Having 3+ jobs in the year
before hire increases hazard by a factor of 1.50 (50%). Compared to a
“Concerns” rating on the programming exercise, Pass and Pass+ both
reduce hazard by factors of .79 (21%) and .73 (27%), respectively. Every
unit increase in interpersonal skills reduces the hazard by a factor of
.91 (9%). Every additional increase in hiring rec reduces hazard by a
factor of .92 (8%).
# Use the function confint() to calculate the 95% confidence intervals for each coefficient.
# Transform the confidence intervals so that they can be interpreted as confidence intervals for exp(coef).
confint(mod)
## 2.5 % 97.5 %
## REFERRALYes -1.0848963 -0.83937218
## NUMBER_JOBS2 -0.0501824 0.07476316
## NUMBER_JOBS3+ 0.3181076 0.49051261
## PROG_EXER_RATEPass -0.3031419 -0.16939606
## PROG_EXER_RATEPass+ -0.4257857 -0.20783126
## INTPER_RATE -0.1084834 -0.08117663
## HIRE_REC -0.1233720 -0.04762507
exp(confint(mod))
## 2.5 % 97.5 %
## REFERRALYes 0.3379368 0.4319816
## NUMBER_JOBS2 0.9510559 1.0776289
## NUMBER_JOBS3+ 1.3745241 1.6331532
## PROG_EXER_RATEPass 0.7384943 0.8441745
## PROG_EXER_RATEPass+ 0.6532563 0.8123441
## INTPER_RATE 0.8971938 0.9220308
## HIRE_REC 0.8839348 0.9534912
Exercise 5 - Creating predicted survival curves from your
proportional hazards model.
# Create a new data frame that contains a column for each of the variables you included in your Cox regression model. Pick of variable you are interested in and provide different values for that variable (the values need to occur in the original data frame) while holding the other variables constant (e.g. NUMBER_JOBS == "0-1" for all rows in the new data frame).
new_data <- data.frame(REFERRAL = c("No", "Yes"),
NUMBER_JOBS = c("3+", "3+"),
PROG_EXER_RATE = c("Concerns", "Concerns"),
INTPER_RATE = c(1, 1),
PRIOR_EXP = c("No", "No"),
HIRE_REC = c(0, 0))
# With your new data frame and your estimated Cox regression model, use the function: survival::survfit() to create predicted survival probabilities from your model and new data frame.
# Using summary(), explore these new probabilities.
predicted_surv_prob <- survival::survfit(mod, newdata = new_data)
summary(predicted_surv_prob)
## Call: survfit(formula = mod, newdata = new_data)
##
## time n.risk n.event survival1 survival2
## 1 8000 182 0.90443 0.962
## 2 7818 181 0.81626 0.925
## 3 7637 187 0.73205 0.888
## 4 7450 135 0.67541 0.861
## 5 7315 128 0.62480 0.836
## 6 7187 110 0.58362 0.814
## 7 7077 87 0.55252 0.797
## 8 6990 68 0.52909 0.784
## 9 6922 41 0.51533 0.776
## 10 6881 58 0.49631 0.765
## 11 6823 36 0.48477 0.758
## 12 6787 35 0.47374 0.752
## 13 6752 27 0.46536 0.747
## 14 6725 29 0.45648 0.741
## 15 6696 38 0.44504 0.734
## 16 6658 41 0.43293 0.726
## 17 6617 36 0.42250 0.720
## 18 6581 46 0.40945 0.711
## 19 6535 57 0.39370 0.700
## 20 6478 69 0.37524 0.688
## 21 6409 93 0.35140 0.671
## 22 6316 117 0.32306 0.649
## 23 6199 134 0.29276 0.625
## 24 6065 124 0.26667 0.604
## 25 5941 163 0.23509 0.575
## 26 5778 218 0.19733 0.538
## 27 5560 197 0.16728 0.505
## 28 5363 199 0.14057 0.473
## 29 5164 178 0.11955 0.444
## 30 4986 160 0.10278 0.419
## 31 4826 117 0.09171 0.401
## 32 4709 94 0.08349 0.387
## 33 4615 76 0.07728 0.376
## 34 4539 51 0.07330 0.368
## 35 4488 32 0.07089 0.364
## 36 4456 15 0.06978 0.362
## 37 4441 12 0.06890 0.360
## 38 4429 16 0.06774 0.358
## 39 4413 15 0.06667 0.355
## 40 4398 26 0.06484 0.352
## 41 4372 47 0.06163 0.345
## 42 4325 55 0.05804 0.337
## 43 4270 59 0.05436 0.329
## 44 4211 59 0.05087 0.320
## 45 4152 85 0.04613 0.309
## 46 4067 64 0.04280 0.300
## 47 4003 83 0.03875 0.289
## 48 3920 100 0.03428 0.276
## 49 3820 122 0.02936 0.260
## 50 3698 97 0.02586 0.247
## 51 3601 90 0.02290 0.236
## 52 3511 91 0.02017 0.225
## 53 3420 88 0.01778 0.214
## 54 3332 88 0.01561 0.204
## 55 3244 68 0.01408 0.196
## 56 3152 57 0.01288 0.190
## 57 3088 41 0.01207 0.185
## 58 3040 39 0.01133 0.181
## 59 2951 39 0.01061 0.176
## 60 2868 18 0.01029 0.174
## 61 2813 11 0.01009 0.173
## 62 2726 2 0.01006 0.172
## 63 2645 3 0.01000 0.172
## 64 2496 3 0.00994 0.172
## 65 2353 1 0.00992 0.172
## 67 1502 2 0.00986 0.171
## 68 1485 9 0.00957 0.169
## 69 1461 9 0.00928 0.167
## 70 1445 10 0.00897 0.165
## 71 1403 13 0.00856 0.162
## 72 1348 9 0.00829 0.160
# With your new data frame and your estimated Cox regression model, use the function: survminer::ggadjustedcurves() to plot your predicted survival functions. If you are familiar with ggplot2, then try to customize the plot output.
survminer::ggadjustedcurves(mod,
data = new_data, variable = "REFERRAL",
ylab = "Probability of Staying",
xlab = "Months Since Hire",
ggtheme = ggplot2::theme_minimal()) +
ggplot2::labs(color = "Referral")
Using the results of your final Cox regression model and your
predicted survival functions to write a high-level business summary of
what predictor or predictors you believe to be the most important to
focus on to reduce attrition.
================================================
FILE: docs/materials/module-exercises/04-survival_analysis.Rmd
================================================
---
title: "Survival Analysis Exercises"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will conduct survival analysis on a data set relating employee turnover to several variables that were measured at the time an employee was hired.
## Exercise 1 - Load, explore, and structure the survival data
```{r}
# Load the survival analysis data file from the url provided
url <- "https://rstudio-conf-2022.github.io/people-analytics-rstats/data/survival_analysis_data.csv"
```
```{r}
# view the first few rows in the data set to acquaint yourself with the data
# convert columns ending in 'DATE' to date format
```
```{r}
# Create a censor indicator variable that is 1 if the employee has left and 0 otherwise
```
```{r}
# Replace missing TURNOVER_DATE values with "2022-07-01" -- think about what missing TURNOVER_DATES mean
```
```{r}
# Use the lubridate::interval() function to create the EVENT_TIME variable
# Hint: Use %/% months(1) to transform the time difference into months
```
```{r}
# Calculate some descriptive statistics for EVENT_TIME using the full sample, then group the data by CENSOR to see how the descriptives
# change.
```
## Exercise 2 - Create a survival object and estimate survival functions using Kaplan Meier estimates
```{r}
# Create a survival object using survival::Surv().
# Remember it requires two arguments EVENT_TIME and CENSOR
```
```{r}
# Use survival::survfit() to estimate survival probabilities using the Kaplan Meier estimator for the entire sample
# Save the survfit output into an object called km_all
# How many months after hiring would you expect 50% of the sample to remain at the firm? (e.g. the median survival time)
# How many months after hiring would you expect 75% of the sample to remain at the firm?
```
```{r}
# Look at the structure of km_all using str()
```
```{r}
# Using km_all, create a new data frame called km_calc which contains the following variables from km_all:
# time, n.risk, n.censor, n.event, and surv
```
```{r}
# Using km_calc, determine the following:
# How many turnovers occurred in the dataset?
# How many censored observations are in the dataset?
# At what time point do the first censored observations appear?
# Subtract n.risk at time point 2 from n.risk at time point 1.
# Why did n.risk decrease from time point 1 to time point 2?
# n.risk at time point 2 = n.risk at time point 1 - n.events at time point 1 - n.censor at time point 1
# Subtract n.risk at time point 56 from time point 55.
# Why did n.risk decrease from time point 55 to time point 56?
# n.risk at time point 56 = n.risk at time point 55 - n.events at time point 55 - n.censor at time point 55
```
```{r}
# The formula to calculate the survival probabilities using the KM estimator is:
# survival(t - 1) * (1 - (n.event[t] / n.risk[t]))
# That is, the survival probability at time t is equal to the survival probability at time t-1 multiplied by 1 - (number of events at
# time t / number of individuals at risk at time t).
# Using the formula above, manual calculate the survival probabilities and save them as variable in km_calc as surv_calc. Take a moment to think about how censored observations are used in the calculation as well.
```
```{r}
# Use survminer::ggsurvplot() to plot the overall survival function.
```
```{r}
# Use survival::survfit() to estimate survival probabilities by the REFERRAL variable.
# For the portion of the sample that was referred for the job (REFERRAL == "Yes"), how many months after hiring would you expect 50% of the sample to remain at the firm? What about for the portion of the sample that was not referred?
# Why would the median survival time be missing?
```
```{r}
# Use survminer::ggsurvplot() to plot the survival function by REFERRAL status. Are the two curves different?
```
```{r}
# Using the survfit function, estimate the survival probabilities for the interaction between REFERRAL and NUMBER_JOBS variables in
# surv_data. Then plot the survival curve using ggsurvplot and provide an interpretation of the curves. Does their appear to be an
# interaction?
#
# HINT: You don't need to create a new variable!
```
## Exercise 3 - Fit a cox proportional hazards model to your data.
```{r}
# Estimate a cox proportional hazards model. Include all of the main effects and the interactions between INTPER_RATE and PROG_EXER_RATE as well as HIRE_REC and REFERRAL.
# HINT: An interaction variable is created by multiplying Variable 1 with Variable 2 (Variable 1 * Variable 2).
```
```{r}
# View the coefficient estimates and standard errors of the model
```
```{r}
# Estimate a cox proportional hazards model that only includes the main effects (no interactions).
```
```{r}
# View the coefficient estimates and standard errors for the main effects model.
```
```{r}
# Compare the model you fit above to a model that only includes the main effects (no interactions). Use the anova() function to determine if the model with interactions fits your data significantly better than the model with main effects only. If you are unsure of how to use the anova() function, then view the help documentation on it ?anova.coxph or exercise solutions.
```
```{r}
# Based on the model comparison above, decide if you should choose the more complicated interaction model or the less complicated main effects model. Using the model you decided on, test the proportional hazard assumption and determine if any variables violate it. If they do decide if you should drop them from the model.
```
## Exercise 4 - Interpreting the proportional hazards results.
```{r}
# Using the final model you decided on during last exercise, provide an interpretation of each of the predictors you kept in the model.
```
```{r}
# Use the function confint() to calculate the 95% confidence intervals for each coefficient.
# Transform the confidence intervals so that they can be interpreted as confidence intervals for exp(coef).
```
## Exercise 5 - Creating predicted survival curves from your proportional hazards model.
```{r}
# Create a new data frame that contains a column for each of the variables you included in your Cox regression model. Pick of variable you are interested in and provide different values for that variable (the values need to occur in the original data frame) while holding the other variables constant (e.g. NUMBER_JOBS == "0-1" for all rows in the new data frame).
```
```{r}
# With your new data frame and your estimated Cox regression model, use the function: survival::survfit() to create predicted survival probabilities from your model and new data frame.
# Using summary(), explore these new probabilities.
```
```{r}
# With your new data frame and your estimated Cox regression model, use the function: survminer::ggadjustedcurves() to plot your predicted survival functions. If you are familiar with ggplot2, then try to customize the plot output.
```
Using the results of your final Cox regression model and your predicted survival functions to write a high-level business summary of what predictor or predictors you believe to be the most important to focus on to reduce attrition.
================================================
FILE: docs/materials/module-exercises/05-Creating_and_visualizing_graphs - SOLUTIONS.Rmd
================================================
---
title: "5 - Creating and Visualizing Graphs"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will practice creating and examining graph objects in R, and visualizing those graphs using common visualization packages.
## Exercise 1 - Creating an undirected graph object
```{r}
# Download the karate dataset from the URL provided
url <- "https://ona-book.org/data/karate.csv"
karate_edgelist <- read.csv(url)
```
```{r}
# this dataset is the edgelist from a study of a karate club by Wayne W. Zachary in 1977
# an edge between two vertices means that the two members socialized outside the club
# create an undirected graph from the edgelist
library(igraph)
karate_graph <- igraph::graph_from_data_frame(
karate_edgelist,
directed = FALSE
)
```
```{r}
# View the graph object - how many vertices and edges are there?
karate_graph
```
```{r}
# View the vertex set
V(karate_graph)
```
```{r}
# View the edge set
E(karate_graph)
```
## Exercise 2 - Creating a directed graph object
```{r}
# Download the schoolfriends edgelist from the URL provided
url <- "https://ona-book.org/data/schoolfriends_edgelist.csv"
schoolfriends_edgelist <- read.csv(url)
```
```{r}
# This network is from a research project on French high school children
# This edgelist gives two types of relationships.
# The first type is a reported friendship, where the first person reported
# the second person as a a friend in a survey.
# The second type is a known Facebook friendship connection between the two.
# filter the edgelist to just the reported friendships.
library(dplyr)
schoolfriends_rp_edgelist <- schoolfriends_edgelist |>
dplyr::filter(type == "reported")
```
```{r}
# create an appropriate graph object from this filtered edgelist.
schoolfriends_rp_graph <- igraph::graph_from_data_frame(
schoolfriends_rp_edgelist,
directed = TRUE
)
```
```{r}
# Examine the graph object - how many vertices and edges does it have
schoolfriends_rp_graph
```
## Exercise 3 - Comparing graphs
```{r}
# Filter the schoolfriends data set to just the facebook friendships
schoolfriends_fb_edgelist <- schoolfriends_edgelist |>
dplyr::filter(type == "facebook")
```
```{r}
# Create and examine an appropriate graph object from this filtered data set
(schoolfriends_fb_graph <- igraph::graph_from_data_frame(
schoolfriends_fb_edgelist,
directed = FALSE
))
```
Write below a comparison of the basic properties of the two types of `schoolfriends` networks:
1. The reported friendship graph is directed, whereas the Facebook friendship graph is undirected.
2. The reported friendship graph has 134 vertices, compared to 156 vertices for the Facebook friendship graph, indicting that it is more more students had Facebook friendships versus reported friendships.
3. There are 668 edges in the reported friendship graph, but 1437 in the Facebook friendship graph. This indicates that Facebook friendships are more common than reported friendships.
## Exercise 4 - Loading a graph with edge properties
```{r}
# Load the workfrance_edgelist data set from the URL provided.
# This is an edgelist of a network of interactions between office employees
# in various departments based on how much time they spent together during a given day
url <- "https://ona-book.org/data/workfrance_edgelist.csv"
workfrance_edgelist <- read.csv(url)
```
```{r}
# Create a undirected graph object from this edgelist including any edge properties
workfrance_graph <- igraph::graph_from_data_frame(
workfrance_edgelist,
directed = FALSE
)
```
```{r}
# verify that there is an edge property called mins and show the first ten values
# of this edge property
E(workfrance_graph)$mins[1:10]
```
## Exercise 5 - Loading a graph with vertex properties
```{r}
# Load the workfrance_vertices data set from the URL provided
url <- "https://ona-book.org/data/workfrance_vertices.csv"
workfrance_vertices <- read.csv(url)
```
```{r}
# Recreate the undirected graph object with both edge and vertex properties
workfrance_graph <- igraph::graph_from_data_frame(
workfrance_edgelist,
vertices = workfrance_vertices,
directed = FALSE
)
```
```{r}
# find the vertex properties in your new graph
# choose one vertex property and show the first ten values
V(workfrance_graph)$dept[1:10]
```
## Exercise 6 - Examining graph properties
```{r}
# Identify the data types of each of the edge and vertex properties in your
# workfrance graph
workfrance_graph
```
```{r}
# Use the graph object to find the mean number of mins for all edges in your
# workfrance graph
mean(E(workfrance_graph)$mins)
```
```{r}
# EXTENSION - Create a subgraph of all vertices in the 'SSI' department
# calculate the mean number of mins for all edges in this subgraph
# Hint: try the igraph::induced_subgraph() function
SSI_vertices <- V(workfrance_graph)[V(workfrance_graph)$dept == 'SSI']
SSI_subgraph <- igraph::induced_subgraph(
workfrance_graph,
vids = SSI_vertices
)
mean(E(SSI_subgraph)$mins)
```
## Exercise 7 - Plotting a network graph
```{r}
# Run a basic plot of the undirected karate graph
plot(karate_graph)
```
```{r}
# Remove all labels except 'Mr Hi' and 'John A'
V(karate_graph)$label <- ifelse(V(karate_graph)$name %in% c('Mr Hi', 'John A'),
V(karate_graph)$name,
"")
plot(karate_graph)
```
```{r}
# Re-do the layout using the Kamada-Kawaii layout
# Set a seed of 123 to control randomness
# Check whether your neighbor generated an identical plot
set.seed(123)
karate_graph$layout <- igraph::layout_with_kk(karate_graph)
plot(karate_graph)
```
## Exercise 8 - Plotting a network graph (EXTENSION)
```{r}
# Plot the undirected workfrance network graph without labels and using a
# Fruchterman-Reingold force directed layout. Use a seed of 123.
set.seed(123)
workfrance_graph$layout <- igraph::layout_with_fr(workfrance_graph)
V(workfrance_graph)$label <- ""
plot(workfrance_graph)
```
```{r}
# Resize the vertices to size 5
V(workfrance_graph)$size <- 5
plot(workfrance_graph)
```
```{r}
# Resize the vertices to size 5
V(workfrance_graph)$size <- 5
plot(workfrance_graph)
```
```{r}
# Try to color the vertices of the graph by the dept of the vertex
V(workfrance_graph)$color <- factor(V(workfrance_graph)$dept)
plot(workfrance_graph)
```
## Exercise 9 - Plotting a network graph using `ggraph` (EXTENSION)
```{r}
# Create a basic Plot of the workfrance undirected network using ggraph
# use a Kamada-Kawaii layout and set a seed of 123
library(ggraph)
set.seed(123)
ggraph(workfrance_graph, layout = "kk") +
geom_edge_link(color = "grey") +
geom_node_point(size = 3) +
theme_void()
```
```{r}
# Redo the plot again using an aesthetic to color the vertices by dept
set.seed(123)
ggraph(workfrance_graph, layout = "kk") +
geom_edge_link(color = "grey") +
geom_node_point(size = 3, aes(color = dept)) +
theme_void()
```
```{r}
# (EXTENSION) Try to scale the edge by the mins edge property
set.seed(123)
ggraph(workfrance_graph, layout = "kk") +
geom_edge_link(aes(color = mins)) +
geom_node_point(size = 3, aes(color = dept),
show.legend = FALSE) +
theme_void()
```
## Exercise 10 - Interactive network visualization using `networkD3` (EXTENSION)
```{r}
# Create a group in the karate graph containing Mr Hi and John A
V(karate_graph)$group <- ifelse(V(karate_graph)$name %in% c("Mr Hi", "John A"), 1, 0)
```
```{r}
# Convert the karate graph for the purposes of using networkD3
# Use you new group in the conversion
library(networkD3)
karate_d3 <- networkD3::igraph_to_networkD3(karate_graph,
group = V(karate_graph)$group)
```
```{r}
# Run a force network visualization of the karate graph in networkD3
networkD3::forceNetwork(Links = karate_d3$links,
Nodes = karate_d3$nodes,
NodeID = "name",
Source = "source",
Target = "target",
Group = "group",
opacity = 1)
```
================================================
FILE: docs/materials/module-exercises/05-Creating_and_visualizing_graphs---SOLUTIONS.html
================================================
In this document we will practice creating and examining graph
objects in R, and visualizing those graphs using common visualization
packages.
Exercise 1 - Creating an undirected graph object
# Download the karate dataset from the URL provided
url <- "https://ona-book.org/data/karate.csv"
karate_edgelist <- read.csv(url)
# this dataset is the edgelist from a study of a karate club by Wayne W. Zachary in 1977
# an edge between two vertices means that the two members socialized outside the club
# create an undirected graph from the edgelist
library(igraph)
##
## Attaching package: 'igraph'
## The following objects are masked from 'package:stats':
##
## decompose, spectrum
## The following object is masked from 'package:base':
##
## union
karate_graph <- igraph::graph_from_data_frame(
karate_edgelist,
directed = FALSE
)
# View the graph object - how many vertices and edges are there?
karate_graph
## IGRAPH bb139a8 UN-- 34 78 --
## + attr: name (v/c)
## + edges from bb139a8 (vertex names):
## [1] Mr Hi --Actor 2 Mr Hi --Actor 3 Mr Hi --Actor 4 Mr Hi --Actor 5
## [5] Mr Hi --Actor 6 Mr Hi --Actor 7 Mr Hi --Actor 8 Mr Hi --Actor 9
## [9] Mr Hi --Actor 11 Mr Hi --Actor 12 Mr Hi --Actor 13 Mr Hi --Actor 14
## [13] Mr Hi --Actor 18 Mr Hi --Actor 20 Mr Hi --Actor 22 Mr Hi --Actor 32
## [17] Actor 2--Actor 3 Actor 2--Actor 4 Actor 2--Actor 8 Actor 2--Actor 14
## [21] Actor 2--Actor 18 Actor 2--Actor 20 Actor 2--Actor 22 Actor 2--Actor 31
## [25] Actor 3--Actor 4 Actor 3--Actor 8 Actor 3--Actor 9 Actor 3--Actor 10
## [29] Actor 3--Actor 14 Actor 3--Actor 28 Actor 3--Actor 29 Actor 3--Actor 33
## + ... omitted several edges
# View the vertex set
V(karate_graph)
## + 34/34 vertices, named, from bb139a8:
## [1] Mr Hi Actor 2 Actor 3 Actor 4 Actor 5 Actor 6 Actor 7 Actor 9
## [9] Actor 10 Actor 14 Actor 15 Actor 16 Actor 19 Actor 20 Actor 21 Actor 23
## [17] Actor 24 Actor 25 Actor 26 Actor 27 Actor 28 Actor 29 Actor 30 Actor 31
## [25] Actor 32 Actor 33 Actor 8 Actor 11 Actor 12 Actor 13 Actor 18 Actor 22
## [33] Actor 17 John A
# View the edge set
E(karate_graph)
## + 78/78 edges from bb139a8 (vertex names):
## [1] Mr Hi --Actor 2 Mr Hi --Actor 3 Mr Hi --Actor 4 Mr Hi --Actor 5
## [5] Mr Hi --Actor 6 Mr Hi --Actor 7 Mr Hi --Actor 8 Mr Hi --Actor 9
## [9] Mr Hi --Actor 11 Mr Hi --Actor 12 Mr Hi --Actor 13 Mr Hi --Actor 14
## [13] Mr Hi --Actor 18 Mr Hi --Actor 20 Mr Hi --Actor 22 Mr Hi --Actor 32
## [17] Actor 2--Actor 3 Actor 2--Actor 4 Actor 2--Actor 8 Actor 2--Actor 14
## [21] Actor 2--Actor 18 Actor 2--Actor 20 Actor 2--Actor 22 Actor 2--Actor 31
## [25] Actor 3--Actor 4 Actor 3--Actor 8 Actor 3--Actor 9 Actor 3--Actor 10
## [29] Actor 3--Actor 14 Actor 3--Actor 28 Actor 3--Actor 29 Actor 3--Actor 33
## [33] Actor 4--Actor 8 Actor 4--Actor 13 Actor 4--Actor 14 Actor 5--Actor 7
## [37] Actor 5--Actor 11 Actor 6--Actor 7 Actor 6--Actor 11 Actor 6--Actor 17
## + ... omitted several edges
Exercise 2 - Creating a directed graph object
# Download the schoolfriends edgelist from the URL provided
url <- "https://ona-book.org/data/schoolfriends_edgelist.csv"
schoolfriends_edgelist <- read.csv(url)
# This network is from a research project on French high school children
# This edgelist gives two types of relationships.
# The first type is a reported friendship, where the first person reported
# the second person as a a friend in a survey.
# The second type is a known Facebook friendship connection between the two.
# filter the edgelist to just the reported friendships.
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:igraph':
##
## as_data_frame, groups, union
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
schoolfriends_rp_edgelist <- schoolfriends_edgelist |>
dplyr::filter(type == "reported")
# create an appropriate graph object from this filtered edgelist.
schoolfriends_rp_graph <- igraph::graph_from_data_frame(
schoolfriends_rp_edgelist,
directed = TRUE
)
# Examine the graph object - how many vertices and edges does it have
schoolfriends_rp_graph
## IGRAPH aa32e60 DN-- 134 668 --
## + attr: name (v/c), type (e/c)
## + edges from aa32e60 (vertex names):
## [1] 1 ->55 1 ->205 1 ->272 1 ->494 1 ->779 1 ->894 3 ->1 3 ->28 3 ->147
## [10] 3 ->272 3 ->407 3 ->674 3 ->884 27->63 27->173 28->202 28->327 28->353
## [19] 28->407 28->429 28->441 28->492 28->545 32->440 32->624 32->797 32->920
## [28] 34->151 34->277 34->502 34->866 45->48 45->79 45->335 45->496 45->601
## [37] 45->674 45->765 46->117 46->196 46->257 46->268 48->45 48->79 48->496
## [46] 55->1 55->170 55->205 55->252 55->272 55->779 55->883 55->894 61->797
## [55] 63->27 63->125 63->173 70->101 70->132 70->240 70->425 70->447 72->407
## [64] 72->674 72->857 79->45 79->48 79->335 79->496 79->601 79->674 79->765
## + ... omitted several edges
Exercise 3 - Comparing graphs
# Filter the schoolfriends data set to just the facebook friendships
schoolfriends_fb_edgelist <- schoolfriends_edgelist |>
dplyr::filter(type == "facebook")
# Create and examine an appropriate graph object from this filtered data set
(schoolfriends_fb_graph <- igraph::graph_from_data_frame(
schoolfriends_fb_edgelist,
directed = FALSE
))
## IGRAPH 14bdb55 UN-- 156 1437 --
## + attr: name (v/c), type (e/c)
## + edges from 14bdb55 (vertex names):
## [1] 1 --883 1 --132 1 --339 1 --653 1 --545 1 --171 1 --117 1 --196
## [9] 1 --587 1 --372 1 --147 1 --55 1 --859 1 --106 1 --504 1 --471
## [17] 1 --425 1 --170 1 --939 1 --272 1 --3 1 --119 1 --494 1 --205
## [25] 1 --265 1 --779 1 --364 1 --240 1 --477 1 --101 1 --884 3 --504
## [33] 3 --171 3 --545 3 --147 3 --441 3 --477 3 --272 3 --653 3 --884
## [41] 3 --471 3 --372 9 --1594 9 --488 9 --471 9 --190 9 --272 9 --779
## [49] 9 --55 9 --106 9 --325 14--232 14--520 14--65 14--605 14--621
## [57] 20--387 20--615 20--151 20--977 20--1232 20--513 20--634 20--156
## + ... omitted several edges
Write below a comparison of the basic properties of the two types of
schoolfriends networks:
- The reported friendship graph is directed, whereas the Facebook
friendship graph is undirected.
- The reported friendship graph has 134 vertices, compared to 156
vertices for the Facebook friendship graph, indicting that it is more
more students had Facebook friendships versus reported friendships.
- There are 668 edges in the reported friendship graph, but 1437 in
the Facebook friendship graph. This indicates that Facebook friendships
are more common than reported friendships.
Exercise 4 - Loading a graph with edge properties
# Load the workfrance_edgelist data set from the URL provided.
# This is an edgelist of a network of interactions between office employees
# in various departments based on how much time they spent together during a given day
url <- "https://ona-book.org/data/workfrance_edgelist.csv"
workfrance_edgelist <- read.csv(url)
# Create a undirected graph object from this edgelist including any edge properties
workfrance_graph <- igraph::graph_from_data_frame(
workfrance_edgelist,
directed = FALSE
)
# verify that there is an edge property called mins and show the first ten values
# of this edge property
E(workfrance_graph)$mins[1:10]
## [1] 8 14 17 10 7 7 20 7 21 6
Exercise 5 - Loading a graph with vertex properties
# Load the workfrance_vertices data set from the URL provided
url <- "https://ona-book.org/data/workfrance_vertices.csv"
workfrance_vertices <- read.csv(url)
# Recreate the undirected graph object with both edge and vertex properties
workfrance_graph <- igraph::graph_from_data_frame(
workfrance_edgelist,
vertices = workfrance_vertices,
directed = FALSE
)
# find the vertex properties in your new graph
# choose one vertex property and show the first ten values
V(workfrance_graph)$dept[1:10]
## [1] "DCAR" "DCAR" "DCAR" "DCAR" "DCAR" "DCAR" "DCAR" "DCAR" "DCAR" "DCAR"
Exercise 6 - Examining graph properties
# Identify the data types of each of the edge and vertex properties in your
# workfrance graph
workfrance_graph
## IGRAPH 3edafda UN-- 211 932 --
## + attr: name (v/c), dept (v/c), mins (e/n)
## + edges from 3edafda (vertex names):
## [1] 3 --159 253--3 3 --447 3 --498 3 --694 3 --751 3 --859
## [8] 3 --908 14 --18 99 --14 14 --441 520--14 14 --544 14 --653
## [15] 14 --998 15 --120 15 --160 15 --162 15 --178 15 --259 15 --261
## [22] 15 --295 15 --353 15 --372 15 --464 15 --491 15 --498 15 --909
## [29] 15 --1090 39 --18 99 --18 429--18 488--18 527--18 18 --621
## [36] 18 --650 753--18 18 --797 18 --845 99 --27 160--27 259--27
## [43] 295--27 27 --346 27 --1392 34 --156 34 --250 34 --259 34 --489
## [50] 34 --615 34 --694 34 --884 34 --959 219--38 38 --435 39 --71
## + ... omitted several edges
# Use the graph object to find the mean number of mins for all edges in your
# workfrance graph
mean(E(workfrance_graph)$mins)
## [1] 23.9088
# EXTENSION - Create a subgraph of all vertices in the 'SSI' department
# calculate the mean number of mins for all edges in this subgraph
# Hint: try the igraph::induced_subgraph() function
SSI_vertices <- V(workfrance_graph)[V(workfrance_graph)$dept == 'SSI']
SSI_subgraph <- igraph::induced_subgraph(
workfrance_graph,
vids = SSI_vertices
)
mean(E(SSI_subgraph)$mins)
## [1] 26.4
Exercise 7 - Plotting a network graph
# Run a basic plot of the undirected karate graph
plot(karate_graph)
# Remove all labels except 'Mr Hi' and 'John A'
V(karate_graph)$label <- ifelse(V(karate_graph)$name %in% c('Mr Hi', 'John A'),
V(karate_graph)$name,
"")
plot(karate_graph)
# Re-do the layout using the Kamada-Kawaii layout
# Set a seed of 123 to control randomness
# Check whether your neighbor generated an identical plot
set.seed(123)
karate_graph$layout <- igraph::layout_with_kk(karate_graph)
plot(karate_graph)
Exercise 8 - Plotting a network graph (EXTENSION)
# Plot the undirected workfrance network graph without labels and using a
# Fruchterman-Reingold force directed layout. Use a seed of 123.
set.seed(123)
workfrance_graph$layout <- igraph::layout_with_fr(workfrance_graph)
V(workfrance_graph)$label <- ""
plot(workfrance_graph)
# Resize the vertices to size 5
V(workfrance_graph)$size <- 5
plot(workfrance_graph)
# Resize the vertices to size 5
V(workfrance_graph)$size <- 5
plot(workfrance_graph)
# Try to color the vertices of the graph by the dept of the vertex
V(workfrance_graph)$color <- factor(V(workfrance_graph)$dept)
plot(workfrance_graph)
Exercise 9 - Plotting a network graph using ggraph
(EXTENSION)
# Create a basic Plot of the workfrance undirected network using ggraph
# use a Kamada-Kawaii layout and set a seed of 123
library(ggraph)
## Loading required package: ggplot2
set.seed(123)
ggraph(workfrance_graph, layout = "kk") +
geom_edge_link(color = "grey") +
geom_node_point(size = 3) +
theme_void()
# Redo the plot again using an aesthetic to color the vertices by dept
set.seed(123)
ggraph(workfrance_graph, layout = "kk") +
geom_edge_link(color = "grey") +
geom_node_point(size = 3, aes(color = dept)) +
theme_void()
# (EXTENSION) Try to scale the edge by the mins edge property
set.seed(123)
ggraph(workfrance_graph, layout = "kk") +
geom_edge_link(aes(color = mins)) +
geom_node_point(size = 3, aes(color = dept),
show.legend = FALSE) +
theme_void()
Exercise 10 - Interactive network visualization using
networkD3 (EXTENSION)
# Create a group in the karate graph containing Mr Hi and John A
V(karate_graph)$group <- ifelse(V(karate_graph)$name %in% c("Mr Hi", "John A"), 1, 0)
# Convert the karate graph for the purposes of using networkD3
# Use you new group in the conversion
library(networkD3)
karate_d3 <- networkD3::igraph_to_networkD3(karate_graph,
group = V(karate_graph)$group)
# Run a force network visualization of the karate graph in networkD3
networkD3::forceNetwork(Links = karate_d3$links,
Nodes = karate_d3$nodes,
NodeID = "name",
Source = "source",
Target = "target",
Group = "group",
opacity = 1)
================================================
FILE: docs/materials/module-exercises/05-Creating_and_visualizing_graphs.Rmd
================================================
---
title: "5 - Creating and Visualizing Graphs"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will practice creating and examining graph objects in R, and visualizing those graphs using common visualization packages.
## Exercise 1 - Creating an undirected graph object
```{r}
# Download the karate dataset from the URL provided
url <- "https://ona-book.org/data/karate.csv"
```
```{r}
# this dataset is the edgelist from a study of a karate club by Wayne W. Zachary in 1977
# an edge between two vertices means that the two members socialized outside the club
# create an undirected graph from the edgelist
```
```{r}
# View the graph object - how many vertices and edges are there?
```
```{r}
# View the vertex set
```
```{r}
# View the edge set
```
## Exercise 2 - Creating a directed graph object
```{r}
# Download the schoolfriends edgelist from the URL provided
url <- "https://ona-book.org/data/schoolfriends_edgelist.csv"
```
```{r}
# This network is from a research project on French high school children
# This edgelist gives two types of relationships.
# The first type is a reported friendship, where the first person reported
# the second person as a a friend in a survey.
# The second type is a known Facebook friendship connection between the two.
# filter the edgelist to just the reported friendships.
```
```{r}
# create an appropriate graph object from this filtered edgelist.
```
```{r}
# Examine the graph object - how many vertices and edges does it have
```
## Exercise 3 - Comparing graphs
```{r}
# Filter the schoolfriends data set to just the facebook friendships
```
```{r}
# Create and examine an appropriate graph object from this filtered data set
```
Write below a comparison of the basic properties of the two types of `schoolfriends` networks:
## Exercise 4 - Loading a graph with edge properties
```{r}
# Load the workfrance_edgelist data set from the URL provided.
# This is an edgelist of a network of interactions between office employees
# in various departments based on how much time they spent together during a given day
url <- "https://ona-book.org/data/workfrance_edgelist.csv"
```
```{r}
# Create a undirected graph object from this edgelist including any edge properties
```
```{r}
# verify that there is an edge property called mins and show the first ten values
# of this edge property
```
## Exercise 5 - Loading a graph with vertex properties
```{r}
# Load the workfrance_vertices data set from the URL provided
url <- "https://ona-book.org/data/workfrance_vertices.csv"
```
```{r}
# Recreate the undirected graph object with both edge and vertex properties
```
```{r}
# find the vertex properties in your new graph
# choose one vertex property and show the first ten values
```
## Exercise 6 - Examining graph properties
```{r}
# Identify the data types of each of the edge and vertex properties in your
# workfrance graph
```
```{r}
# Use the graph object to find the mean number of mins for all edges in your
# workfrance graph
```
```{r}
# EXTENSION - Create a subgraph of all vertices in the 'SSI' department
# calculate the mean number of mins for all edges in this subgraph
# Hint: try the igraph::induced_subgraph() function
```
## Exercise 7 - Plotting a network graph using `igraph`
```{r}
# Run a basic plot of the undirected karate graph
```
```{r}
# Remove all labels except 'Mr Hi' and 'John A'
```
```{r}
# Re-do the layout using the Kamada-Kawaii layout
# Set a seed of 123 to control randomness
# Check whether your neighbor generated an identical plot
```
## Exercise 8 - Plotting a network graph using `igraph` (EXTENSION)
```{r}
# Plot the undirected workfrance network graph without labels and using a
# Fruchterman-Reingold force directed layout. Use a seed of 123.
```
```{r}
# Resize the vertices to size 5
```
```{r}
# Try to color the vertices of the graph by the dept of the vertex
```
## Exercise 9 - Plotting a network graph using `ggraph` (EXTENSION)
```{r}
# Create a basic Plot of the workfrance undirected network using ggraph
# use a Kamada-Kawaii layout and set a seed of 123
```
```{r}
# Redo the plot again using an aesthetic to color the vertices by dept
```
```{r}
# (EXTENSION) Try to scale the edge by the mins edge property
```
## Exercise 10 - Interactive network visualization using `networkD3` (EXTENSION)
```{r}
# Create a group in the karate graph containing Mr Hi and John A
```
```{r}
# Convert the karate graph for the purposes of using networkD3
# Use you new group in the conversion
```
```{r}
# Run a force network visualization of the karate graph in networkD3
```
================================================
FILE: docs/materials/module-exercises/06-Graph_metrics - SOLUTIONS.Rmd
================================================
---
title: "6 - Graph Metrics and Analysis"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will practice various types of network analyses using an edgelist of dolphins
## Exercise 1 - Basic graph summary metrics
```{r}
# Download the dolphin dataset from the URL provided
url <- "https://ona-book.org/data/dolphins.csv"
dolphin_edgelist <- read.csv(url)
# look at the data to see what you're dealing with
```
```{r}
# create an undirected graph
library(igraph)
dolphin_graph <- igraph::graph_from_data_frame(
dolphin_edgelist,
directed = FALSE
)
```
```{r}
# View the graph object - how many vertices and edges are there?
dolphin_graph
```
```{r}
# what is the distance between Zig and Fork
distances(dolphin_graph, weights = NULL)["Zig","Fork"]
```
```{r}
# Is this a dense network?
edge_density(dolphin_graph)
```
```{r}
# How many components are in this network?
components(dolphin_graph)
# What does this mean for our network?
# we have a complete graph where all dolphins are somehow connected
```
```{r}
# What is the network diameter? What does this mean?
diameter(dolphin_graph)
```
```{r}
# how large is the largest clique?
clique_num(dolphin_graph)
# how many cliques are between size 3 and 5?
length(cliques(dolphin_graph, min = 3, max = 5))
```
## Exercise 2 - Centrality measures
```{r}
# Continuing with our same dolphin graph, let's calculate centrality metrics.
# HINT: try using the tidygraph package
cent <-
dolphin_graph |>
tidygraph::as_tbl_graph() |>
dplyr::mutate(
DEGREE_CENT = tidygraph::centrality_degree(),
BTWN_CENT = tidygraph::centrality_betweenness(),
CLOSE_CENT = tidygraph::centrality_closeness()
)
# Which dolphin is an important connector? (SN100)
cent %>%
dplyr::arrange(
desc(BTWN_CENT)
)
# Which dolphin has the most connections? (Grin)
cent %>%
dplyr::arrange(
desc(DEGREE_CENT)
)
# Which dolphin is the most central? (SN100)
cent %>%
dplyr::arrange(
desc(CLOSE_CENT)
)
```
```{r}
library(ggraph)
# plot the dolphin graph and locate Grin and SN100 to see if these results make intuitive sense
V(dolphin_graph)$highcent <- ifelse(V(dolphin_graph)$name %in% c("SN100","Grin"),1,0)
ggraph::ggraph(dolphin_graph) +
geom_edge_link(color = "grey") +
geom_node_point(aes(color = as.factor(highcent), size = 3), show.legend = FALSE) +
scale_color_manual(values = c("lightblue","pink")) +
geom_node_text(aes(label = name)) +
theme_void()
```
## Exercise 3: Community detection
```{r}
# What communities do you see in the dolphin graph? Try out a couple of methods and compare results
# e.g. cluster_louvain, cluster_leiden, cluster_fast_greedy
set.seed(123)
communities <- cluster_louvain(dolphin_graph)
V(dolphin_graph)$community <- membership(communities)
sizes(communities)
```
```{r}
# plot your favorite option
set.seed(123)
ggraph(dolphin_graph, layout = "fr") +
geom_edge_link(color = "grey") +
geom_node_point(aes(color = as.factor(community)),
show.legend = FALSE) +
theme_void()
```
## Exercise 4 - Do people tend to email with people in their same department?
```{r}
# Download the email dataset from the URL provided
url <- "https://ona-book.org/data/email_edgelist.csv"
email_edgelist <- read.csv(url)
# Download the corresponding department mappings from the URL provided
url_v <- "https://ona-book.org/data/email_vertices.csv"
email_dept <- read.csv(url_v)
# look through the edges and vertices to understand the data source
```
```{r}
# create the graph with vertice labels
email_graph <- igraph::graph_from_data_frame(
email_edgelist,
directed = FALSE,
vertices = email_dept
)
# Calculate assortativity
assortativity_nominal(email_graph, factor(V(email_graph)$dept))
```
## Exercise 5 - Exploring the friends graph (EXTENSION)
```{r}
# Download the friends dataset from the URL provided
url <- "https://ona-book.org/data/friends_tv_edgelist.csv"
friends_edgelist <- read.csv(url)
```
```{r}
# which two characters interact most?
friends_edgelist |>
dplyr::arrange(desc(weight)) |>
head()
# is this a connected network?
friends_graph <-
igraph::graph_from_data_frame(
friends_edgelist,
directed = FALSE
)
components(friends_graph)
# who is the most "important" character?
c_vals <-
friends_graph |>
tidygraph::as_tbl_graph() |>
dplyr::mutate(
DEGREE_CENT = tidygraph::centrality_degree(),
BTWN_CENT = tidygraph::centrality_betweenness(),
CLOSE_CENT = tidygraph::centrality_closeness()
)
# Ross and Joey come out on top of all metrics
c_vals |>
dplyr::arrange(desc(DEGREE_CENT))
c_vals |>
dplyr::arrange(desc(BTWN_CENT))
c_vals |>
dplyr::arrange(desc(CLOSE_CENT))
```
```{r}
# Are the friends part of the same community? Who else is in the community?
# Does it make intuitive sense (if you're a friends fan :-) )
set.seed(123)
communities <- cluster_louvain(friends_graph, weights = NULL)
V(friends_graph)$community <- membership(communities)
membership(communities)[c("Joey","Monica","Chandler","Ross","Phoebe","Rachel")]
# is anyone else in cluster 5? so many random people....
length(membership(communities)[membership(communities) == 5])
# try leiden
set.seed(123)
communities <- cluster_leiden(friends_graph, weights = NULL)
V(friends_graph)$community <- membership(communities)
membership(communities)[c("Joey","Monica","Chandler","Ross","Phoebe","Rachel")]
# this list of people makes a lot more sense to a Friends fan
membership(communities)[membership(communities) == 49]
```
================================================
FILE: docs/materials/module-exercises/06-Graph_metrics---SOLUTIONS.html
================================================
In this document we will practice various types of network analyses
using an edgelist of dolphins
Exercise 1 - Basic graph summary metrics
# Download the dolphin dataset from the URL provided
url <- "https://ona-book.org/data/dolphins.csv"
dolphin_edgelist <- read.csv(url)
# look at the data to see what you're dealing with
# create an undirected graph
library(igraph)
##
## Attaching package: 'igraph'
## The following objects are masked from 'package:stats':
##
## decompose, spectrum
## The following object is masked from 'package:base':
##
## union
dolphin_graph <- igraph::graph_from_data_frame(
dolphin_edgelist,
directed = FALSE
)
# View the graph object - how many vertices and edges are there?
dolphin_graph
## IGRAPH b67d85b UN-- 62 159 --
## + attr: name (v/c)
## + edges from b67d85b (vertex names):
## [1] CCL --Double DN16 --Feather DN21 --Feather
## [4] Beak --Fish Bumper --Fish DN16 --Gallatin
## [7] DN21 --Gallatin Feather --Gallatin Beak --Grin
## [10] CCL --Grin Beak --Haecksel Grin --Hook
## [13] Beescratch--Jet DN21 --Jet Feather --Jet
## [16] Gallatin --Jet Haecksel --Jonah Beescratch--Knit
## [19] DN63 --Knit Double --Kringel Hook --Kringel
## [22] Jonah --Kringel Jonah --MN105 Jet --MN23
## + ... omitted several edges
# what is the distance between Zig and Fork
distances(dolphin_graph, weights = NULL)["Zig","Fork"]
## [1] 7
# Is this a dense network?
edge_density(dolphin_graph)
## [1] 0.0840825
# How many components are in this network?
components(dolphin_graph)
## $membership
## CCL DN16 DN21 Beak Bumper Feather
## 1 1 1 1 1 1
## Grin Beescratch Gallatin Haecksel DN63 Double
## 1 1 1 1 1 1
## Hook Jonah Jet Mus Notch Kringel
## 1 1 1 1 1 1
## Fish MN105 MN83 Knit Oscar Fork
## 1 1 1 1 1 1
## Scabs Patchback MN60 Shmuddel SN100 SN4
## 1 1 1 1 1 1
## PL SN63 Stripes SN96 TR120 Topless
## 1 1 1 1 1 1
## Cross Five TR99 SN9 SN90 Trigger
## 1 1 1 1 1 1
## SN89 TR82 Upbang Ripplefluke TSN83 MN23
## 1 1 1 1 1 1
## Number1 Quasi SMN5 Thumper TR77 TR88
## 1 1 1 1 1 1
## TSN103 Vau Wave Web Whitetip Zap
## 1 1 1 1 1 1
## Zig Zipfel
## 1 1
##
## $csize
## [1] 62
##
## $no
## [1] 1
# What does this mean for our network?
# we have a complete graph where all dolphins are somehow connected
# What is the network diameter? What does this mean?
diameter(dolphin_graph)
## [1] 8
# how large is the largest clique?
clique_num(dolphin_graph)
## [1] 5
# how many cliques are between size 3 and 5?
length(cliques(dolphin_graph, min = 3, max = 5))
## [1] 125
Exercise 2 - Centrality measures
# Continuing with our same dolphin graph, let's calculate centrality metrics.
# HINT: try using the tidygraph package
cent <-
dolphin_graph |>
tidygraph::as_tbl_graph() |>
dplyr::mutate(
DEGREE_CENT = tidygraph::centrality_degree(),
BTWN_CENT = tidygraph::centrality_betweenness(),
CLOSE_CENT = tidygraph::centrality_closeness()
)
## Warning in betweenness(graph = graph, v = V(graph), directed = directed, :
## 'nobigint' is deprecated since igraph 1.3 and will be removed in igraph 1.4
# Which dolphin is an important connector? (SN100)
cent %>%
dplyr::arrange(
desc(BTWN_CENT)
)
## # A tbl_graph: 62 nodes and 159 edges
## #
## # An undirected simple graph with 1 component
## #
## # Node Data: 62 x 4 (active)
## name DEGREE_CENT BTWN_CENT CLOSE_CENT
## <chr> <dbl> <dbl> <dbl>
## 1 SN100 7 454. 0.00685
## 2 Beescratch 8 390. 0.00610
## 3 SN9 8 262. 0.00662
## 4 SN4 11 254. 0.00654
## 5 DN63 5 216. 0.00599
## 6 Jet 9 209. 0.00508
## # … with 56 more rows
## #
## # Edge Data: 159 x 2
## from to
## <int> <int>
## 1 31 48
## 2 32 44
## 3 26 32
## # … with 156 more rows
# Which dolphin has the most connections? (Grin)
cent %>%
dplyr::arrange(
desc(DEGREE_CENT)
)
## # A tbl_graph: 62 nodes and 159 edges
## #
## # An undirected simple graph with 1 component
## #
## # Node Data: 62 x 4 (active)
## name DEGREE_CENT BTWN_CENT CLOSE_CENT
## <chr> <dbl> <dbl> <dbl>
## 1 Grin 12 113. 0.00617
## 2 SN4 11 254. 0.00654
## 3 Topless 11 74.4 0.00568
## 4 Scabs 10 105. 0.00599
## 5 Trigger 10 155. 0.00541
## 6 Jet 9 209. 0.00508
## # … with 56 more rows
## #
## # Edge Data: 159 x 2
## from to
## <int> <int>
## 1 23 42
## 2 14 37
## 3 14 21
## # … with 156 more rows
# Which dolphin is the most central? (SN100)
cent %>%
dplyr::arrange(
desc(CLOSE_CENT)
)
## # A tbl_graph: 62 nodes and 159 edges
## #
## # An undirected simple graph with 1 component
## #
## # Node Data: 62 x 4 (active)
## name DEGREE_CENT BTWN_CENT CLOSE_CENT
## <chr> <dbl> <dbl> <dbl>
## 1 SN100 7 454. 0.00685
## 2 SN9 8 262. 0.00662
## 3 SN4 11 254. 0.00654
## 4 Kringel 9 188. 0.00641
## 5 Grin 12 113. 0.00617
## 6 Beescratch 8 390. 0.00610
## # … with 56 more rows
## #
## # Edge Data: 159 x 2
## from to
## <int> <int>
## 1 10 37
## 2 50 56
## 3 46 50
## # … with 156 more rows
library(ggraph)
## Loading required package: ggplot2
# plot the dolphin graph and locate Grin and SN100 to see if these results make intuitive sense
V(dolphin_graph)$highcent <- ifelse(V(dolphin_graph)$name %in% c("SN100","Grin"),1,0)
ggraph::ggraph(dolphin_graph) +
geom_edge_link(color = "grey") +
geom_node_point(aes(color = as.factor(highcent), size = 3), show.legend = FALSE) +
scale_color_manual(values = c("lightblue","pink")) +
geom_node_text(aes(label = name)) +
theme_void()
## Using `stress` as default layout
Exercise 4 - Do people tend to email with people in their same
department?
# Download the email dataset from the URL provided
url <- "https://ona-book.org/data/email_edgelist.csv"
email_edgelist <- read.csv(url)
# Download the corresponding department mappings from the URL provided
url_v <- "https://ona-book.org/data/email_vertices.csv"
email_dept <- read.csv(url_v)
# look through the edges and vertices to understand the data source
# create the graph with vertice labels
email_graph <- igraph::graph_from_data_frame(
email_edgelist,
directed = FALSE,
vertices = email_dept
)
# Calculate assortativity
assortativity_nominal(email_graph, factor(V(email_graph)$dept))
## [1] 0.3139728
Exercise 5 - Exploring the friends graph (EXTENSION)
# Download the friends dataset from the URL provided
url <- "https://ona-book.org/data/friends_tv_edgelist.csv"
friends_edgelist <- read.csv(url)
# which two characters interact most?
friends_edgelist |>
dplyr::arrange(desc(weight)) |>
head()
## from to weight
## 1 Chandler Monica 938
## 2 Chandler Joey 889
## 3 Rachel Ross 836
## 4 Monica Phoebe 800
## 5 Monica Rachel 774
## 6 Phoebe Rachel 771
# is this a connected network?
friends_graph <-
igraph::graph_from_data_frame(
friends_edgelist,
directed = FALSE
)
components(friends_graph)
## $membership
## a Casino Boss a Crew Member a Disembodied Voice a Drunken Gambler
## 1 1 1 1
## a Female Student a Male Customer a Student a Tourist
## 1 1 1 1
## a Waiter a Waiter in Drag a Woman Actor
## 1 1 1 1
## Adoption Agency Guy Adrienne Agency Guy Air Stewardess
## 1 1 1 1
## Airline Employee Alan Alex Alexandra Steele
## 1 1 1 1
## Alice Alison Amanda Amber
## 1 1 1 1
## Amy Amy Storms Out Anchorwoman Andrea
## 1 1 1 1
## Angela Annabelle Announcer Another Extra
## 1 1 1 1
## Another Man's Voice Another Scientist Another Tour Guide Answering Machine
## 1 1 1 1
## Arthur Ashley Assistant Aunt Iris
## 1 1 1 1
## Aunt Lillian Aunt Lisa Aunt Millie Aurora
## 1 1 1 1
## Bandleader Bank Officer Barry Bass Singer
## 1 1 1 1
## Ben Benjamin Bernice Best Man
## 1 1 1 1
## Big Bully Big Nosed Rachel Bill Billy Crystal
## 1 1 1 1
## Bitter Lady Bitter Woman Blackjack Dealer Blonde Girl
## 1 1 1 1
## Bob Bonnie Boy Boy in the Cape
## 1 1 1 1
## Boys Burt C.h.e.e.s.e C.h.e.e.s.e.
## 1 1 1 1
## Cailin Caitlin Carl Carol
## 1 1 1 1
## Caroline Casey Cashier Cassie
## 1 1 1 1
## Casting Assistant Casting Director #1 Casting Director #2 Casting Director #3
## 1 1 1 1
## Casting Guy Cecilia Celia Chandler
## 1 1 1 1
## Chandlers Charity Guy Charlie Charlton Heston
## 1 1 1 1
## Chase Lassiter Cheryl Chip Chloe
## 1 1 1 1
## Claudia Clerk Cliff Clown
## 1 1 1 1
## Colleen Coma Guy Cookie Cop
## 1 1 1 1
## Cowgirl Croupler Customer Customers
## 1 1 1 1
## Cut to Cynthia Dan Danielle
## 1 1 1 1
## Danny Danny's Sister Dave David
## 1 1 1 1
## Delivery Girl Delivery Guy Dennis Phillips Devon
## 1 1 1 1
## Dick Clark Dina Director Dirk
## 1 1 1 1
## Doctor Doctor Connelly Don Donny
## 1 1 1 1
## Donny Osmond Doug Dr Baldhara Dr Biely
## 1 1 1 1
## Dr Burke Dr Drake Ramoray Dr Drake Remoray Dr Franzblau
## 1 1 1 1
## Dr Gettleman Dr Green Dr Harad Dr Horton
## 1 1 1 1
## Dr Johnson Dr Ledbetter Dr Leedbetter Dr Li
## 1 1 1 1
## Dr Long Dr Miller Dr Mitchell Dr Oberman
## 1 1 1 1
## Dr Remore Dr Rhodes Dr Roger Dr Rosen
## 1 1 1 1
## Dr Schiff Dr Stryker Remoray Dr Timothy Burke Dr Wesley
## 1 1 1 1
## Dr Zane Drew Drunk Man Drunken Gambler
## 1 1 1 1
## Duncan Earl Eddie Eldad
## 1 1 1 1
## Elizabeth Emeril Emil Alexander Emily
## 1 1 1 1
## Emma Employee Eric Erica
## 1 1 1 1
## Erin Ernie Estelle Estl
## 1 1 1 1
## Evil Bitch Extra Fake Monica Fat Girl
## 1 1 1 1
## Fat Monica Fbob Felicity Female Clerk
## 1 1 1 1
## Female Jeweler Female Student Fergie Fireman
## 1 1 1 1
## Fireman #1 Fireman #2 Fireman No. 1 Fireman No. 2
## 1 1 1 1
## Fireman No. 3 First Dorm Guy Fran Frank
## 1 1 1 1
## Frank Jr. Frank Sr. Frannie Fredrick
## 1 1 1 1
## Front Desk Clerk Funny Gail Gang
## 1 1 1 1
## Gary Gary Collins Gary's Radio Gate Agent
## 1 1 1 1
## Gavin Gene Gerston Gert
## 1 1 1 1
## Ginger Girl Girl's Voice Girls
## 1 1 1 1
## Grandma Tribbiani Grandmom Guest #1 Guest #2
## 1 1 1 1
## Guest #3 Gunther Guru Saj Guy
## 1 1 1 1
## Guy #1 Guy #2 Guys Gym Employee
## 1 1 1 1
## Handyman Hayley Hayley's Roommate Health Inspector
## 1 1 1 1
## Heather Helen Helena Henrietta
## 1 1 1 1
## Hilda Hillary Hitchhiker Hold Voice
## 1 1 1 1
## Hombre Man Homo Ergaster Hooker Hope
## 1 1 1 1
## Hoshi Host Hotel Clerk Housekeeper
## 1 1 1 1
## Hums While He Pees Hypnosis Tape i Understand Intercom
## 1 1 1 1
## Interviewer Isabella Issac It's 6
## 1 1 1 1
## It's 9 Jack Jade Jake
## 1 1 1 1
## Jamie Jane Janice Janice's Voice
## 1 1 1 1
## Janine Janitor Jasmine Jason
## 1 1 1 1
## Jay Leno Jeanette Jeannie Jeannine
## 1 1 1 1
## Jen Jennifer Jessica Ashley Jessica Lockhart
## 1 1 1 1
## Jester Jill Jim Jo Lynn
## 1 1 1 1
## Joanna Joanne Joey Joey Laughs
## 1 1 1 1
## Joey Nods Joey on Tv Joey's Co-Star Joey's Date
## 1 1 1 1
## Joey's Doctor Joey's Grandmom Joey's Hand Twin Joey's Head
## 1 1 1 1
## Joey's Sister Joey's Sisters Josh Joshua
## 1 1 1 1
## Judge Judy Julie Julio
## 1 1 1 1
## Kara Karin Kash Kate
## 1 1 1 1
## Kathy Kathy's Co-Star Katie Ken
## 1 1 1 1
## Kevin Kid Kids Kiki
## 1 1 1 1
## Kim Kitchen Worker Kori Krista
## 1 1 1 1
## Kristen Kristin Kyle Kyle Lowder
## 1 1 1 1
## Lady Larry Laura Lauren
## 1 1 1 1
## Leader Lecturer Leslie Lewis
## 1 1 1 1
## Liam Lipson Lisa Little Bully
## 1 1 1 1
## Little Girl Lizzie Locksmith Lorraine
## 1 1 1 1
## Luisa Lydia Mac Machine
## 1 1 1 1
## Maitre D' Malcom Male Guest Male Jeweler
## 1 1 1 1
## Male Student Man Man at the Wedding Man on Tv
## 1 1 1 1
## Man with a Bow Tie Man's Voice Manny Marc
## 1 1 1 1
## Marge Margha Marjorie Mark
## 1 1 1 1
## Marsha Mary Ellen Mary-Angela Matire'd
## 1 1 1 1
## Matress King Matthew Ashford Max Meg
## 1 1 1 1
## Megan Mel Melanie Melissa
## 1 1 1 1
## Message Mich Michelle Mike
## 1 1 1 1
## Mike's Dad Mike's Mom Mindy Minister
## 1 1 1 1
## Minster Mischa Missy Molly
## 1 1 1 1
## Mona Mona's Date Monica Morse
## 1 1 1 1
## Mover Mr a Mr Bing Mr Bowmont
## 1 1 1 1
## Mr Boyle Mr Buffay Mr Burgin Mr Campbell
## 1 1 1 1
## Mr Douglas Mr Franklin Mr Geller Mr Green
## 1 1 1 1
## Mr Greene Mr Heckles Mr Kaplan Mr Oberblau
## 1 1 1 1
## Mr Posner Mr Simon Mr Thompson Mr Treeger
## 1 1 1 1
## Mr Tribbiani Mr Waltham Mr Wineburg Mr Zellner
## 1 1 1 1
## Mr Zelner Mrs Bing Mrs Burgin Mrs Burkart
## 1 1 1 1
## Mrs Chatracus Mrs Geller Mrs Green Mrs Greene
## 1 1 1 1
## Mrs Lynch Mrs Potter Mrs Tedlock Mrs Waltham
## 1 1 1 1
## Mrs Wineburg Ms Geller Ms Lambert Nancy
## 1 1 1 1
## Narrator Nina Nurse Nurse #1
## 1 1 1 1
## Nurse #2 Old Woman Older Scientist Others
## 1 1 1 1
## Oven Pa Paleontologist Paolo
## 1 1 1 1
## Parker Party Guests Passenger Passenger #1
## 1 1 1 1
## Passenger #2 Passenger #3 Patrick Paul
## 1 1 1 1
## Paulo Pbs Volunteer Pete Pete's Mom
## 1 1 1 1
## Peter Petrie Phil Phoebe
## 1 1 1 1
## Phoebe Sr Photographer Pizza Guy Policeman
## 1 1 1 1
## Priest on Tv Prof. Sherman Professor Feesen Professor Sherman
## 1 1 1 1
## Professor Spafford Professore Clerk Quartet Racel
## 1 1 1 1
## Rache Rachel Radio Rahcel
## 1 1 1 1
## Raymond Receptionist Referee Richard
## 1 1 1 1
## Rita Rob Robbie Robert
## 1 1 1 1
## Robin Williams Roger Ross Salon Girl
## 1 1 1 1
## Same Man's Voice Sarah Second Dorm Guy Second Message
## 1 1 1 1
## Security Guard Sherman Whitfield Sleep Clinic Worker Soothing Male Voice
## 1 1 1 1
## Stanley Stephanie Steve Supervisor
## 1 1 1 1
## Susan Susie Teacher Terry
## 1 1 1 1
## The Colonel The Conductor The Cooking Teacher The Director
## 1 1 1 1
## The Doctor The Girls The Guys The Head Librarian
## 1 1 1 1
## The Hot Girl The Interviewer The Little Girl The Lurker
## 1 1 1 1
## The Other Woman The Producer The Second Guest Ticket Agent
## 1 1 1 1
## Trainer Tv Announcer Ursula Waiter
## 1 1 1 1
## Waitress Woman No. 1 The Fireman The Croupier
## 1 1 1 1
## Woman The Waiter Waiter in Drag Woman at Door
## 1 1 1 1
## Store Guy The Presenter Tour Guide Second Girl
## 1 1 1 1
## Uncle Dan The Woman The Teacher Owen
## 1 1 1 1
## Wayne Tommy The Writer Dana
## 1 1 1 1
## Frankie Lowell Mary-Theresa Ms Mckenna
## 1 1 1 1
## Phoebe Sr. Realtor Richard's Date Ronni
## 1 1 1 1
## Roy Russ Sandy Santos
## 1 1 1 1
## Scott Sebastian Shelley Singer
## 1 1 1 1
## Sister 1 Sophie Stevens Stripper
## 1 1 1 1
## Tag The Chorus Line The Cigarette Guy The Knocker
## 1 1 1 1
## The Man The Museum Official The Paramedic The Photographer
## 1 1 1 1
## The Rabbi The Salesman The Stripper The Vampire
## 1 1 1 1
## The Waitress Tilly Tim Tom
## 1 1 1 1
## Tony Tv Tv Doctor Van Damme
## 1 1 1 1
## Vince Voice Walker Whitfield
## 1 1 1 1
## will Witch Woman No. 2 Woman on Tv
## 1 1 1 1
## Woman's Voice Zack Shop Assistant Patron
## 1 1 1 1
## Woman Giving Birth Stage Manager The "Hey Guy" Guy Zoe
## 1 1 1 1
## Secretary Ray Sick Bastard Stage Director
## 1 1 1 1
## Mackenzie The Fan The Porsche Owner Sid
## 1 1 1 1
## Mrs Tribbiani Phoebe-Estelle Smart Kid Sonia
## 1 1 1 1
## Student Tape The A.d The Acting Teacher
## 1 1 1 1
## The Dr Cleaner The Food Critic The Grip The Husband
## 1 1 1 1
## The Old Man The Pastor The Security Guard The Singing Man
## 1 1 1 1
## The Woman Dealer Waiters We Have 8 Young Ethan
## 1 1 1 1
## Ralph Lauren Whitney The Bass Barber Strange Man
## 1 1 1 1
## Precious Sergei Paula Rtst
## 1 1 1 1
## Spokeswoman Stu The Cute Guy The Professor
## 1 1 1 1
## The Saleslady The Wedding Guest Video Rick
## 1 1 1 1
## The Housekeeper Phoebe's Assistant Producer Ryan
## 1 1 1 1
## Smoke Detector Stranger Tattoo Artist The Smoking Woman
## 1 1 1 1
## Trudie Styler Russell Wedding Planner Salesman
## 1 1 1 1
## The Instructor The Librarian The Saleswoman Waiter #2
## 1 1 1 1
## Woman on Train Waiter No. 2
## 1 1
##
## $csize
## [1] 650
##
## $no
## [1] 1
# who is the most "important" character?
c_vals <-
friends_graph |>
tidygraph::as_tbl_graph() |>
dplyr::mutate(
DEGREE_CENT = tidygraph::centrality_degree(),
BTWN_CENT = tidygraph::centrality_betweenness(),
CLOSE_CENT = tidygraph::centrality_closeness()
)
## Warning in betweenness(graph = graph, v = V(graph), directed = directed, :
## 'nobigint' is deprecated since igraph 1.3 and will be removed in igraph 1.4
# Ross and Joey come out on top of all metrics
c_vals |>
dplyr::arrange(desc(DEGREE_CENT))
## # A tbl_graph: 650 nodes and 2976 edges
## #
## # An undirected simple graph with 1 component
## #
## # Node Data: 650 x 4 (active)
## name DEGREE_CENT BTWN_CENT CLOSE_CENT
## <chr> <dbl> <dbl> <dbl>
## 1 Ross 359 46721. 0.00106
## 2 Joey 353 46871. 0.00106
## 3 Chandler 342 35337. 0.00105
## 4 Monica 339 33493. 0.00104
## 5 Phoebe 334 39774. 0.00104
## 6 Rachel 331 32353. 0.00103
## # … with 644 more rows
## #
## # Edge Data: 2,976 x 3
## from to weight
## <int> <int> <int>
## 1 243 244 1
## 2 3 243 1
## 3 2 243 1
## # … with 2,973 more rows
c_vals |>
dplyr::arrange(desc(BTWN_CENT))
## # A tbl_graph: 650 nodes and 2976 edges
## #
## # An undirected simple graph with 1 component
## #
## # Node Data: 650 x 4 (active)
## name DEGREE_CENT BTWN_CENT CLOSE_CENT
## <chr> <dbl> <dbl> <dbl>
## 1 Joey 353 46871. 0.00106
## 2 Ross 359 46721. 0.00106
## 3 Phoebe 334 39774. 0.00104
## 4 Chandler 342 35337. 0.00105
## 5 Monica 339 33493. 0.00104
## 6 Rachel 331 32353. 0.00103
## # … with 644 more rows
## #
## # Edge Data: 2,976 x 3
## from to weight
## <int> <int> <int>
## 1 164 171 1
## 2 4 164 1
## 3 1 164 1
## # … with 2,973 more rows
c_vals |>
dplyr::arrange(desc(CLOSE_CENT))
## # A tbl_graph: 650 nodes and 2976 edges
## #
## # An undirected simple graph with 1 component
## #
## # Node Data: 650 x 4 (active)
## name DEGREE_CENT BTWN_CENT CLOSE_CENT
## <chr> <dbl> <dbl> <dbl>
## 1 Ross 359 46721. 0.00106
## 2 Joey 353 46871. 0.00106
## 3 Chandler 342 35337. 0.00105
## 4 Monica 339 33493. 0.00104
## 5 Phoebe 334 39774. 0.00104
## 6 Rachel 331 32353. 0.00103
## # … with 644 more rows
## #
## # Edge Data: 2,976 x 3
## from to weight
## <int> <int> <int>
## 1 219 220 1
## 2 3 219 1
## 3 2 219 1
## # … with 2,973 more rows
# Are the friends part of the same community? Who else is in the community?
# Does it make intuitive sense (if you're a friends fan :-) )
set.seed(123)
communities <- cluster_louvain(friends_graph, weights = NULL)
V(friends_graph)$community <- membership(communities)
membership(communities)[c("Joey","Monica","Chandler","Ross","Phoebe","Rachel")]
## Joey Monica Chandler Ross Phoebe Rachel
## 5 5 5 5 5 5
# is anyone else in cluster 5? so many random people....
length(membership(communities)[membership(communities) == 5])
## [1] 246
# try leiden
set.seed(123)
communities <- cluster_leiden(friends_graph, weights = NULL)
V(friends_graph)$community <- membership(communities)
membership(communities)[c("Joey","Monica","Chandler","Ross","Phoebe","Rachel")]
## Joey Monica Chandler Ross Phoebe Rachel
## 49 49 49 49 49 49
# this list of people makes a lot more sense to a Friends fan
membership(communities)[membership(communities) == 49]
## Ben Carol Chandler Charlie Elizabeth
## 49 49 49 49 49
## Emily Erica Frank Gary Gunther
## 49 49 49 49 49
## Guy Janice Janine Jill Joey
## 49 49 49 49 49
## Julie Kathy Man Mike Mona
## 49 49 49 49 49
## Monica Mr Geller Mrs Bing Mrs Geller Nurse
## 49 49 49 49 49
## Paul Pete Phoebe Rachel Richard
## 49 49 49 49 49
## Ross Susan The Guys The Interviewer Waiter
## 49 49 49 49 49
## Woman Tag
## 49 49
================================================
FILE: docs/materials/module-exercises/06-Graph_metrics.Rmd
================================================
---
title: "6 - Graph Metrics and Analysis"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
In this document we will practice various types of network analyses using an edgelist of dolphins
## Exercise 1 - Basic graph summary metrics
```{r}
# Download the dolphin dataset from the URL provided
url <- "https://ona-book.org/data/dolphins.csv"
dolphin_edgelist <- read.csv(url)
# look at the data to see what you're dealing with
```
```{r}
# create an undirected graph
```
```{r}
# View the graph object - how many vertices and edges are there?
```
```{r}
# what is the distance between Zig and Fork
```
```{r}
# Is this a dense network?
```
```{r}
# How many components are in this network?
# What does this mean for our network?
```
```{r}
# What is the network diameter? What does this mean?
```
```{r}
# how large is the largest clique?
# how many cliques are between size 3 and 5?
```
## Exercise 2 - Centrality measures
```{r}
# Continuing with our same dolphin graph, let's calculate centrality metrics.
# HINT: try using the tidygraph package
# Which dolphin is an important connector?
# Which dolphin has the most connections?
# Which dolphin is the most central?
```
```{r}
# plot the dolphin graph and locate our highly central dolphins to see if these results make intuitive sense
# HINT: create a node property to help you identify the dolphins of interest in a plot
```
## Exercise 3: Community detection
```{r}
# What communities do you see in the dolphin graph? Try out a couple of methods and compare results
# e.g. cluster_louvain, cluster_leiden, cluster_fast_greedy
```
```{r}
# plot your favorite option
```
## Exercise 4 - Do people tend to email with people in their same department?
```{r}
# Download the email dataset from the URL provided
url <- "https://ona-book.org/data/email_edgelist.csv"
email_edgelist <- read.csv(url)
# Download the corresponding department mappings from the URL provided
url_v <- "https://ona-book.org/data/email_vertices.csv"
email_dept <- read.csv(url_v)
# look through the edges and vertices to understand the data source
```
```{r}
# create the graph with vertice labels
# Calculate assortativity
```
## Exercise 5 - Exploring the friends graph (EXTENSION)
```{r}
# Download the friends dataset from the URL provided
url <- "https://ona-book.org/data/friends_tv_edgelist.csv"
friends_edgelist <- read.csv(url)
```
```{r}
# which two characters interact most?
# is this a connected network?
# who is the most "important" character?
```
```{r}
# Are the friends part of the same community? Who else is in the community?
# Does it make intuitive sense (if you're a friends fan :-) )
```
================================================
FILE: docs/materials/talks/1-preliminaries.Rmd
================================================
---
title: "Welcome to R for People Analytics"
subtitle: "Introduction and Preliminaries"
author: "
> "People analytics is a data-driven approach to understanding people related phenomena."
>
> `r tufte::quote_footer('--- Keith')`
---
class: left, middle, rstudio-logo
## What is people analytics?
A lot of what constitutes 'people analytics' is no different from other types of analytics.
* Processing, cleaning and structuring data
* Identifying patterns of interest
* Reporting descriptive statistics
But we will focus on quantitative techniques which are used more frequently in people analytics than in most other fields:
* Explanatory modeling
* Network analysis
---
class: left, middle, rstudio-logo
## Explanatory modeling: what is it?
Explanatory modeling uses a sample of data to draw inferences about the potential causes of an outcome of interest. It is also sometimes called *inferential modeling*.
Examples:
* Does working schedule and/or pay rate influence likelihood to leave an organization?
* Does academic performance in earlier years of a program influence academic performance in the final year?
* Do certain demographic factors influence choice of career?
---
class: left, middle, rstudio-logo
## Explanatory modeling: what we will learn
We will focus on regression analysis as a way to explain outcomes of interest using data. You will learn:
1. How to choose an appropriate model type for the problem at hand.
2. How to prepare your data for your model.
3. How to execute the model.
4. How to view a variety of outputs from the model.
5. How to interpret those outputs against the problem at hand.
---
class: left, middle, rstudio-logo
## Network analysis: what is it?
Network analysis uses graph theory to store, visualize and analyze data on relationships. This can be used to answer questions about people, groups, organizational structures and many other things.
Examples:
* Who are the important or influential actors in a group?
* Are there 'hidden but important' subgroups?
* What factors drive connection in an organization?
---
class: left, middle, rstudio-logo
## Network analysis: what we will learn
We will focus on creating, visualizing and analyzing network structures to draw insights about a problem. You will learn:
1. How to store data in graph structures
2. How to visualize those structures
3. How to understand relationships/connections within those structures
4. How to measure importance and influence in a network
5. How to identify community structures in networks and how to describe those structures.
---
class: left, middle, rstudio-logo, reallybigfont
## How we will learn
👩🏫 Talks and instruction
👨🏽💻 Frequent short coding exercises
🤹 Project work
😲 A few other things
---
class: left, middle, rstudio-logo, reallybigfont
## How to ask questions
📣 Ask instructors or TAs (during breaks if possible!)
💻 Post to our [Github Discussions](https://github.com/rstudio-conf-2022/people-analytics-rstats/discussions) page!
---
class: left, middle, rstudio-logo, reallybigfont
## How to get help
This
work is licensed under a Creative Commons
Attribution 4.0 International License.