Calculating and Examining AUC

This script looks at how to calculate between-person difference in the area under the curve (AUC).

This script shares The Cortisol Data, an N = 34, T = 9 time points data set we have used to illustrate a variety of growth modeling and mixture modeling methods.

The data are shared with intent that others may find them useful for learning about growth modeling or developing new methods for analysis of change.

New publications based on these data require citation and acknowledgement of the full set of papers that have used the data, and …

         Ram, N., & Grimm, K. (2007). Using simple and complex growth models to
         articulate developmental change: Matching theory to method.
         International Journal of Behavioral Development, 31(4), 303-316.
         https://doi.org/10.1177/0165025407077751

         Ram, N., & Grimm, K. (2009). Growth mixture modeling: A method for
         identifying differences in longitudinal change among unobserved groups.
         International Journal of Behavioral Development, 33(6), 565-576.
         https://doi.org/10.1177/0165025409343765

         Ram, N., Grimm, K., Gatzke-Kopp, L. & Molenaar, P.C.M. (2011).
         Longitudinal mixture models and the identification of archetypes:
         Action-adventure, mystery, science fiction, fantasy, or romance? In B.
         Laursen, T. Little, & N. Card (Eds.) Handbook of Developmental Research
         Methods (pp. 481-500). New York: Guilford.

         Grimm, K.J., Steele, J.S., Ram, N., & Nesselroade, J.R. (2013).
         Exploratory latent growth models in the structural equation modeling
         framework. Structural Equation Modeling, 20(4), 568-591.
         https://doi.org/10.1080/10705511.2013.824775

Outline

This script covers …

  • Loading the Cortisol Data

  • Reshaping the Cortisol Data

  • Calculating AUC with the Cortisol Data

  • Plotting AUC with the Cortisol Data

Set-Up

Packages

#Loading Packages
library(psych)           # data descriptives
library(DescTools)       # Lin's Correspondance Coefficient
library(ggridges)        # drawing ridgelines
library(tidyverse)       # data manipulation

Reading in the data

Loading the public data

#set filepath for data file
filepath <- "https://raw.githubusercontent.com/The-Change-Lab/collaborations/main/TheCortisolData/TheCortisolData.csv"

#read in the .csv file using the url() function
cortisol_wide <- read.csv(file=url(filepath),header=TRUE)

Looking at the top few rows of the wide data.

head(cortisol_wide,6)
##   id cort_0 cort_1 cort_2 cort_3 cort_4 cort_5 cort_6 cort_7 cort_8
## 1  1    4.2    4.1    9.7   14.0   19.0   18.0   20.0   23.0   24.0
## 2  2    5.5    5.6   14.0   16.0   19.0   17.0   18.0   20.0   19.0
## 3  3    4.0    3.8    7.5   12.0   14.0   13.0    9.1    8.2    7.9
## 4  4    6.1    5.6   14.0   20.0   26.0   23.0   26.0   25.0   26.0
## 5  5    4.6    4.4    7.2   12.3   15.8   16.1   17.0   17.8   19.1
## 6  6    6.8    9.5   14.2   19.6   19.0   13.9   13.4   12.5   11.7

Reshaping the data

To use our data, we need to make two changes:

  1. We need our data in long form. Instead of having one row per PID with multiple columns of info per PID we want one row per informational instance.

  2. We want to get the information contained in the variable names as variables.

#reshaping wide to long
cortisol_long <- reshape(data=cortisol_wide, 
                         timevar=c("time"), 
                         idvar="id",
                         varying=c("cort_0","cort_1","cort_2","cort_3",
                                   "cort_4","cort_5","cort_6","cort_7","cort_8"),
                         direction="long", sep="_")

#sorting for easy viewing
#order by id and time
cortisol_long <- cortisol_long[order(cortisol_long$id,cortisol_long$time), ]

Looking at the top few rows of the long data.

head(cortisol_long, 18)
##     id time cort
## 1.0  1    0  4.2
## 1.1  1    1  4.1
## 1.2  1    2  9.7
## 1.3  1    3 14.0
## 1.4  1    4 19.0
## 1.5  1    5 18.0
## 1.6  1    6 20.0
## 1.7  1    7 23.0
## 1.8  1    8 24.0
## 2.0  2    0  5.5
## 2.1  2    1  5.6
## 2.2  2    2 14.0
## 2.3  2    3 16.0
## 2.4  2    4 19.0
## 2.5  2    5 17.0
## 2.6  2    6 18.0
## 2.7  2    7 20.0
## 2.8  2    8 19.0

Plotting a within-person trajectory

Plot of individual-level trajectories

#plotting example participant 30
cortisol_long %>%       
  filter(id == 30) %>%  
  ggplot(., aes(x = time, y = cort, group = id, color=factor(id))) +
  geom_hline(aes(yintercept = max(cort)), color="red") +
  geom_line() +
  geom_point() +
  xlab("Time") + 
  ylab("Cortisol (mmol/L") +
  scale_x_continuous(breaks=seq(0,8, by=1)) +
  guides(color="none") +
  theme_minimal()

Calculating AUCs for all participants (one row per person)

#calculating person-level AUC (a few different kinds)

#Our baseline for the cortisol data is T = 0 and T = 1
#Calculating various baseline centered cortisol values
cortisol_long <- cortisol_long %>% 
  group_by(id) %>% 
  #creating new variables
  mutate(#calculating max cort value
         cort_baseline = mean(c(cort[time==0], cort[time==1])),
         #centering cort on first two time points
         cort_c = cort - cort_baseline, 
         #only negative displacements
         cort_neg = ifelse(cort_c <= 0, cort_c, 0),
         #only positive displacements
         cort_pos = ifelse(cort_c >= 0, cort_c, 0)) 

#Calculating AUC
df_AUCall  <- cortisol_long %>%
  group_by(id) %>% #group by person
  summarise(AUC_cumulative = DescTools::AUC(time, cort_c, 
                                  from = 0, to = 8,
                                  method = "spline",
                                  absolutearea = FALSE),
            AUC_all = DescTools::AUC(time, cort_c, 
                                  from = 0, to = 8,
                                  method = "spline",
                                  absolutearea = TRUE),
            AUC_neg = DescTools::AUC(time, cort_neg, 
                                  from = 0, to = 8,
                                  method = "spline",
                                  absolutearea = FALSE),
            AUC_pos = DescTools::AUC(time, cort_pos, 
                                  from = 0, to = 8,
                                  method = "spline",
                                  absolutearea = FALSE))

head(df_AUCall)
## # A tibble: 6 × 5
##      id AUC_cumulative AUC_all AUC_neg AUC_pos
##   <int>          <dbl>   <dbl>   <dbl>   <dbl>
## 1     1           88.5    89.3 -0.0567    88.6
## 2     2           77.4    78.7 -0.0197    77.4
## 3     3           42.3    42.8 -0.113     42.4
## 4     4          108.    110.  -0.284    109. 
## 5     5           66.3    66.6 -0.113     66.4
## 6     6           46.4    47.2 -0.532     46.9
describe(df_AUCall)
##                vars  n  mean    sd median trimmed   mad   min    max range
## id                1 34 17.50  9.96  17.50   17.50 12.60  1.00  34.00 33.00
## AUC_cumulative    2 34 69.02 23.92  72.65   69.86 22.71 11.85 109.16 97.31
## AUC_all           3 34 70.25 23.41  73.36   70.72 22.95 21.03 110.06 89.03
## AUC_neg           4 34 -0.41  1.04  -0.14   -0.24  0.20 -6.12   0.00  6.12
## AUC_pos           5 34 69.43 23.47  72.75   70.07 22.98 17.97 109.16 91.19
##                 skew kurtosis   se
## id              0.00    -1.31 1.71
## AUC_cumulative -0.40    -0.43 4.10
## AUC_all        -0.26    -0.71 4.01
## AUC_neg        -4.91    24.23 0.18
## AUC_pos        -0.32    -0.60 4.02

Plotting Calulated AUC Values

#plotting
cortisol_long %>% 
  ggplot(., aes(x = time, y = cort_c, group = id, color=factor(id))) +
  geom_line() +
  geom_point() +
  xlab("Time") + 
  ylab("Cortisol Level Centered") +
  scale_x_continuous(breaks=seq(0, 8, by = 2)) +
  guides(color="none") +
  geom_ribbon(aes(ymin=cort_c), ymax=0, fill='red', alpha=0.2) + 
  geom_ribbon(ymin=0, aes(ymax=ifelse(cort_c >= 0, cort_c,0)), fill='green', alpha=0.2) +
  facet_wrap(~ id) +
  theme_minimal()

#plotting with differential displacement
cortisol_long %>%
  ggplot(., aes(x = time, y = cort_neg, group = id, color=factor(id))) +
  geom_line() +
  geom_point() +
  xlab("Time") + 
  ylab("Cortisol Level Centered") +
  scale_x_continuous(breaks=seq(0, 8, by=2)) +
  guides(color="none") +
  geom_ribbon(aes(ymin=cort_c), ymax=0, fill='red', alpha=0.2) + 
  geom_ribbon(ymin=0, aes(ymax=ifelse(cort_c >= 0, cort_c,0)), fill='green', alpha=0.2) +
  facet_wrap(~ id) +
  theme_minimal()

Plotting Using ridges from joyplot

#plotting displacements 
cortisol_long %>%
  #filter to only a subset of IDs for a clearer plot
  filter(id >= 20) %>%         
  ggplot(., aes(x = time, y = factor(id), group = factor(id))) +
  geom_ridgeline(aes(height = cort_c, fill = factor(id), min_height = -5),
                 scale = .05, alpha = .3, color = "#66000000") + # make line transparent
  xlab("Time") + 
  ylab("ID") +
  theme_minimal() +
  theme(legend.position = "none") #hides the legend

#gradient example
cortisol_long %>% 
  #filter to only a subset of IDs for a clearer plot
  filter(id >=20) %>%         
  ggplot(., aes(x = time, y = factor(id), group = factor(id))) +
  geom_ridgeline_gradient(aes(height = cort_c, fill = after_stat(x), min_height = -5), 
                          scale = .05) + 
  scale_fill_viridis_c(name = "time", option = "C") +
  xlab("Time") + 
  ylab("ID") +
  theme_minimal() +
  theme(legend.position = "none") #hides the legend

Histograms of the between-person differences in AUC (Various Different types)

#AUC Cumulative
df_AUCall %>%
  ggplot(aes(x=AUC_cumulative, y= after_stat(density))) +
  geom_histogram(fill="white", color="black", bins = 10) + 
  geom_density(color="red") +
  xlab("AUC Cumulative (Positive - Negative)") +
  ylab("Density") +
  theme_minimal()

#AUC Negative Displacement ONLY
df_AUCall %>%
  ggplot(aes(x=AUC_neg, y= after_stat(density))) +
  geom_histogram(fill="pink", color="black", bins = 10) + 
  geom_density(color="red") +
  xlab("AUC Negative Displacement Only") +
  ylab("Density") +
  theme_minimal()

#AUC Positive Displacement ONLY
df_AUCall %>%
  ggplot(aes(x=AUC_pos, y= after_stat(density))) +
  geom_histogram(fill="green", color="black", alpha = .5, bins = 10) + 
  geom_density(color="red") +
  xlab("AUC Positive Displacement Only") +
  ylab("Density") +
  theme_minimal()

#AUC TOTAL Displacement
df_AUCall %>%
  ggplot(aes(x=AUC_all, y= after_stat(density))) +
  geom_histogram(fill="purple", color="black", alpha = .5, bins = 10) + 
  geom_density(color="red") +
  xlab("AUC TOTAL Displacement") +
  ylab("Density") +
  theme_minimal()