ROC | Paul Riesthuis

ROC Curve Brady et al. (2022)

Sat, 23 Sep 2023 00:00:00 +0000

ROC cuve analysis of Brady et al. (2022).

In this blogpost, I will show how to construct the datasets of Tim and John and the Receiver Operator Characteristic (ROC) curves provided in the article of Brady et al. (2022)
- Then, I will show the following:
  - How to calculate common statistics that can be calculated based on this type of dataset. Most statistics are similar to the ones shown at the page about “old” and “new” memory task
  - How to construct (ROC) curves by hand and via logistic regression.
  - How to calculate the area under the ROC curve.
  - How to calculate confidence intervals for the AUC
  - How to calculate partial area under the curve.

Datasets constructed by hand

Dataset of Tim

old_items_tim <- c(50,50,50,150,500,200)
new_items_tim <- c(250,250,400,50,25,25)
confidence <- c("extreme weak","very weak", "fairly weak", "fairly strong", "very strong", "extreme strong")
df_tim <- data.frame(old_items_tim, new_items_tim, confidence)
nice_table(df_tim,
           title= "Dataset for Tim")

Dataset for Tim
old_items_tim	new_items_tim	confidence
50.00	250.00	extreme weak
50.00	250.00	very weak
50.00	400.00	fairly weak
150.00	50.00	fairly strong
500.00	25.00	very strong
200.00	25.00	extreme strong

Dataset John

old_items_john <- c(50,75,75,500,200,100)
new_items_john <- c(100,400,300,50,75,75) # changed very strong to 75 instead of 25 to have equal number items between tim and john
df_john <- data.frame(old_items_john, new_items_john, confidence)
nice_table(df_john,
           title = "Dataset for John")

Dataset for John
old_items_john	new_items_john	confidence
50.00	100.00	extreme weak
75.00	400.00	very weak
75.00	300.00	fairly weak
500.00	50.00	fairly strong
200.00	75.00	very strong
100.00	75.00	extreme strong

Add hit rate and false alarm rate

Tim

#hit rates Tim
tot_items_tim <- sum(old_items_tim) # to get the total amount of items
df_tim$hit <- c(old_items_tim[1]/tot_items_tim, 
         (old_items_tim[1]+old_items_tim[2])/tot_items_tim,
         (old_items_tim[1]+old_items_tim[2]+old_items_tim[3])/tot_items_tim,
         (old_items_tim[1]+old_items_tim[2]+old_items_tim[3]+old_items_tim[4])/tot_items_tim,
         (old_items_tim[1]+old_items_tim[2]+old_items_tim[3]+old_items_tim[4]+old_items_tim[5])/tot_items_tim,
         (old_items_tim[1]+old_items_tim[2]+old_items_tim[3]+old_items_tim[4]+old_items_tim[5]+old_items_tim[6])/tot_items_tim)
        
  
#false alarm rate Tim
tot_new_tim <- sum(new_items_tim)
df_tim$far <- c(new_items_tim[1]/tot_new_tim, 
         (new_items_tim[1]+new_items_tim[2])/tot_new_tim,
         (new_items_tim[1]+new_items_tim[2]+new_items_tim[3])/tot_new_tim,
         (new_items_tim[1]+new_items_tim[2]+new_items_tim[3]+new_items_tim[4])/tot_new_tim,
         (new_items_tim[1]+new_items_tim[2]+new_items_tim[3]+new_items_tim[4]+new_items_tim[5])/tot_new_tim,
         (new_items_tim[1]+new_items_tim[2]+new_items_tim[3]+new_items_tim[4]+new_items_tim[5]+new_items_tim[6])/tot_new_tim)
nice_table(df_tim,
           title= "Dataset + Hit and False Alarm rate for Tim")

Dataset + Hit and False Alarm rate for Tim
old_items_tim	new_items_tim	confidence	hit	far
50.00	250.00	extreme weak	0.05	0.25
50.00	250.00	very weak	0.10	0.50
50.00	400.00	fairly weak	0.15	0.90
150.00	50.00	fairly strong	0.30	0.95
500.00	25.00	very strong	0.80	0.97
200.00	25.00	extreme strong	1.00	1.00

John

#hit rates for john
tot_old_john <- sum(old_items_john)
df_john$hit <- c(old_items_john[1]/tot_old_john, 
         (old_items_john[1]+old_items_john[2])/tot_old_john,
         (old_items_john[1]+old_items_john[2]+old_items_john[3])/tot_old_john,
         (old_items_john[1]+old_items_john[2]+old_items_john[3]+old_items_john[4])/tot_old_john,
         (old_items_john[1]+old_items_john[2]+old_items_john[3]+old_items_john[4]+old_items_john[5])/tot_old_john,
         (old_items_john[1]+old_items_john[2]+old_items_john[3]+old_items_john[4]+old_items_john[5]+old_items_john[6])/tot_old_john)

# false alarm rate john
tot_new_john <- sum(new_items_john)
df_john$far <- c(new_items_john[1]/tot_new_john, 
         (new_items_john[1]+new_items_john[2])/tot_new_john,
         (new_items_john[1]+new_items_john[2]+new_items_john[3])/tot_new_john,
         (new_items_john[1]+new_items_john[2]+new_items_john[3]+new_items_john[4])/tot_new_john,
         (new_items_john[1]+new_items_john[2]+new_items_john[3]+new_items_john[4]+new_items_john[5])/tot_new_john,
         (new_items_john[1]+new_items_john[2]+new_items_john[3]+new_items_john[4]+new_items_john[5]+new_items_john[6])/tot_new_john)
nice_table(df_john,
           title= "Dataset + Hit and False Alarm rate for John")

Dataset + Hit and False Alarm rate for John
old_items_john	new_items_john	confidence	hit	far
50.00	100.00	extreme weak	0.05	0.10
75.00	400.00	very weak	0.12	0.50
75.00	300.00	fairly weak	0.20	0.80
500.00	50.00	fairly strong	0.70	0.85
200.00	75.00	very strong	0.90	0.92
100.00	75.00	extreme strong	1.00	1.00

Plot ROC Curves for Tim and John

roc_data <- data.frame(df_tim,df_john)
ggplot(roc_data, aes(x = 1- far, y = 1- hit, color = "Tim")) +
  geom_line()+ geom_point()+
  geom_line(aes(x = 1 - far.1, y = 1 - hit.1, color="John"))+ geom_point(aes(x = 1 - far.1, y = 1 - hit.1, color="John"))+
  geom_abline(intercept = 0, slope = 1, linetype = "dashed") +
  labs(x = "False Positive Rate (1 - Specificity)", y = "True Positive Rate (Sensitivity)") +
  ggtitle("ROC Curve")+
  theme_classic()+
  ylim(0,1)+
  geom_vline(xintercept = .10,
             lwd = 1,
             linetype="dashed")+
  annotate("text", x=.23, y=1, label="10% false positives")

ROC Curve via Logistic regression

Create datasets for Tim and John that are compatible for logistic regression.

correct_mem <- rep(c(1, 0), each = 1000)
confidence_tim  <- c(rep(1,50),
                 rep(2,50),
                 rep(3,50),
                 rep(4,150),
                 rep(5,500),
                 rep(6,200),
                 rep(1,250),
                 rep(2,250),
                 rep(3,400),
                 rep(4,50),
                 rep(5,25),
                 rep(6,25))
confidence_john  <- c(rep(1,50),
                 rep(2,75),
                 rep(3,75),
                 rep(4,500),
                 rep(5,200),
                 rep(6,100),
                 rep(1,100),
                 rep(2,400),
                 rep(3,300),
                 rep(4,50),
                 rep(5,75), # i made this 75 as in the article there are otherwise only 1950 items for john instead 2000 as with Tim's. It was orignally 25
                 rep(6,75))
df <- data.frame(correct_mem,confidence_tim,confidence_john)

Create ROC Curves for both

glm.fit_tim=glm(correct_mem ~ confidence_tim, family=binomial)
glm.fit_john=glm(correct_mem ~ confidence_john, family=binomial)

par(pty="s")
p1 <- roc(correct_mem, glm.fit_tim$fitted.values, 
    plot= TRUE,
    legacy.axes=TRUE, 
    percent=TRUE, 
    xlab="False Positive Percentage", 
    ylab="True Postive Percentage", 
    col="#377eb8", 
    lwd=4,
    print.auc = TRUE)

p2 <- roc(correct_mem, glm.fit_john$fitted.values, 
    plot= TRUE,
    legacy.axes=TRUE, 
    percent=TRUE, 
    xlab="False Positive Percentage", 
    ylab="True Postive Percentage", 
    col="red", 
    lwd=4,
    print.auc = TRUE,
    print.auc.y = 40,
    add=TRUE)
abline(v = 90, col = "black", lty = 2)
text(x = 60, y = 98, labels = "10% false positive", col = "black")
legend("bottomright", legend=c("Tim", "John"),
       col=c("Blue","red"), lwd=2)

True and False Positive per Threshold

This can be used to examine the blackstone ratio (10:1; false negative to false positive ratio)
True and False Positive percentages for each confidence threshold for Tim

info_tim <- roc(correct_mem, glm.fit_tim$fitted.values) 
tim.df <- data.frame(
  Confidence = c("","Extreme-very weak", "Very-fairly weak", "Weak-strong", "Fairly-very strong","Very-extreme strong",""),
  tpp=info_tim$sensitivities*100,
  fpp=(1-info_tim$specificities)*100, #to make sure the order goes from weak to high confidence
  thresholds = info_tim$thresholds,
  FN_FP = (length(info_tim$cases)*(1-info_tim$sensitivities))/(length(info_tim$controls)*(1-info_tim$specificities)))

tim.df <- tim.df[-c(1,7), ]  
nice_table(tim.df,
           title="True Positive and False Positive Percentages for each Threshold")

True Positive and False Positive Percentages for each Threshold
Confidence	tpp	fpp	thresholds	FN_FP
Extreme-very weak	95.00	75.00	0.09	0.07
Very-fairly weak	90.00	50.00	0.24	0.20
Weak-strong	85.00	10.00	0.49	1.50
Fairly-very strong	70.00	5.00	0.75	6.00
Very-extreme strong	20.00	2.50	0.90	32.00

True and False Positive percentages for each confidence threshold for John

info_john <- roc(correct_mem, glm.fit_john$fitted.values) 
john.df <- data.frame(
  Confidence = c("","Extreme-very weak", "Very-fairly weak", "Weak-strong", "Fairly-very strong","Very-extreme strong",""),
  tpp=info_john$sensitivities*100,
  fpp=(1-info_john$specificities)*100, #to make sure the order goes from weak to high confidence
  thresholds = info_john$thresholds,
  FN_FP = (length(info_john$cases)*(1-info_john$sensitivities))/(length(info_john$controls)*(1-info_john$specificities)))

john.df <- john.df[-c(1,7), ]  
nice_table(john.df,
           title="True Positive and False Positive Percentages for each Threshold for John")

True Positive and False Positive Percentages for each Threshold for John
Confidence	tpp	fpp	thresholds	FN_FP
Extreme-very weak	95.00	90.00	0.21	0.06
Very-fairly weak	87.50	50.00	0.35	0.25
Weak-strong	80.00	20.00	0.51	1.00
Fairly-very strong	30.00	15.00	0.68	4.67
Very-extreme strong	10.00	7.50	0.81	12.00

Confidence Intervals

The graphs provide important information for whos memory is better.
- For example, the ROC curve of Tim is greater at eacg threshold than the ROC curve of John.
However, to fully examine the AUC we would like 95% CI.
- This can be easily extracted in the pROC package.
- You can either choose to bootstrap or use the delong method.
- Using the 95%CI the AUC can be compared to the smallest effect size of interest (e.g., AUC_null = .8).

# Delong method
auc_tim <- roc(correct_mem, glm.fit_tim$fitted.values)
auc_john <- roc(correct_mem, glm.fit_john$fitted.values)
CI_delong_tim <- ci.auc(auc_tim) # default is 95%
CI_delong_john <- ci.auc(auc_john) 
CI_boot_tim <- ci.auc(auc_tim, method = "bootstrap", boot.n = 1000) # bootstrapping 1000 times
CI_boot_john <- ci.auc(auc_john, method = "bootstrap", boot.n = 1000) # bootstrapping 1000 times
p_tim <- power.roc.test(auc_tim) # null hypothesis is set to .5
p_john <- power.roc.test(auc_john)# null hypothesis is set to .5
tab_ci <- data.frame(
  Name = c("Tim","John"),
  AUC = c(CI_delong_tim[2],CI_delong_john[2]), #AUC values
  CI_low_Delong = c(CI_delong_tim[1],CI_delong_john[1]), # lower bound CI delong
  CI_upper_Delong = c(CI_delong_tim[3],CI_delong_john[3]),# upper bound CI delong
  CI_low_boot = c(CI_delong_tim[1],CI_delong_john[1]),# lower bound CI bootstrap
  CI_upper_boot = c(CI_delong_tim[3],CI_delong_john[3]),# upper bound CI bootstrap
  Power = c(p_tim$power,p_john$power)
)
nice_table(tab_ci,
           title = "AUC values with 95% CI via Delong or bootstrapping",
)

AUC values with 95% CI via Delong or bootstrapping
Name	AUC	CI_low_Delong	CI_upper_Delong	CI_low_boot	CI_upper_boot	Power
Tim	0.88	0.86	0.89	0.86	0.89	1.00
John	0.76	0.74	0.78	0.74	0.78	1.00

ROC curves with 95%

Preferably, we plot the confidence intervals along the ROC curve to better interpret the results

par(pty="s")
p1 <- roc(correct_mem, glm.fit_tim$fitted.values, 
    plot= TRUE,
    legacy.axes=TRUE, 
    percent=TRUE, 
    xlab="False Positive Percentage", 
    ylab="True Postive Percentage", 
    col="#377eb8", 
    lwd=4,
    print.auc = TRUE)
p3 <- ci.se(p1,                         # CI of Tim
            specificities = seq(0, 100, 1),  # CI of sensitivity at at what specificities? 0,5,10,15,....,100
            conf.level=0.95,                 # level of Confidence interval
) 

plot(p3, type = "shape", col = "blue")

p2 <- roc(correct_mem, glm.fit_john$fitted.values, 
    plot= TRUE,
    legacy.axes=TRUE, 
    percent=TRUE, 
    xlab="False Positive Percentage", 
    ylab="True Postive Percentage", 
    col="red", 
    lwd=4,
    print.auc = TRUE,
    print.auc.y = 40,
    add=TRUE)
p4 <- ci.se(p2,                         # CI of john 
            specificities = seq(0, 100, 1),  # CI at which thresholds?
            conf.level=0.95,                 # indicate confidence interval
) 
plot(p4, type = "shape", col = "red")     # plot as a blue shape

Partial AUC

We can calculate the area under the curve for a part of the curve.
- One example is to calculate the curve for values under the 10% false positive
- That is because we want to minimize the amount of false positive when it comes to eyewitness identification.

# Calculate the partial AUC
partial_auc_tim <- roc(correct_mem, glm.fit_tim$fitted.values, partial.auc=c(100,90), percent = T)
partial_auc_john <- roc(correct_mem, glm.fit_john$fitted.values, partial.auc=c(100,90), percent = T)

# Print the partial AUC
par(pty="s")
p1 <- plot(partial_auc_tim,
    plot= TRUE,
    legacy.axes=TRUE, 
    xlab="False Positive Percentage", 
    ylab="True Postive Percentage", 
    col="red", 
    lwd=4,
    print.auc = TRUE,
    print.auc.x = 50,
    print.auc.y = 40,
    auc.polygon=TRUE,
    percent=TRUE)
p1 <- plot(partial_auc_john,
    plot= TRUE,
    legacy.axes=TRUE, 
    xlab="False Positive Percentage", 
    ylab="True Postive Percentage", 
    col="blue", 
    lwd=4,
    print.auc = TRUE,
    print.auc.x = 50,
    print.auc.y = 30,
    auc.polygon=TRUE,
    percent=TRUE,
    add=T)
abline(v = 90, col = "black", lty = 2)
text(x = 65, y = 98, labels = "10% False positive", col = "black")
legend("bottomright", legend=c("Tim", "John"),
       col=c("Blue","red"), lwd=2)

New Old Memory Task Data Analysis

Fri, 22 Sep 2023 00:00:00 +0000

New_Old (yes/no) Memory task

In new_old memory task, participants receive an item (new or old).Then asked whether they studied this item (old) or whether they think it is new. In this scenario there are four possible outcomes:

hit (H) = recognizing studied item (indicating old when item is old)
false alarm (FA) = recognizing non studied item (indicating old when item is new)
miss (M) = Not recognizing studied item (indicating new when item is old)
correct rejection (CR) = Recognizing that an item was not studied (indicating new when item is new)

Let’s create a dataset.

Let’s take a study with 30 old and 30 new items (60 in total)

set.seed(2794)
participants <- seq(1,100,1) # This creates a column with 100 participants
hit   <- c(round(c(rnorm(100,20,2.5))))#  this creates a random number of hits that are normally distributed with a mean of 20 and standard deviation of 2.5
fa    <- c(round(c(rnorm(100,7.5,2.5))))#  this creates a random number of hits that are normally distributed with a mean of 7.5 and standard deviation of 2.5
miss  <- 30-hit
cr    <- 30-fa
df <- data.frame(participants,hit,fa,miss,cr)
head(df)

  participants hit fa miss cr
1            1  23  7    7 23
2            2  18  6   12 24
3            3  21  8    9 22
4            4  21  2    9 28
5            5  19  7   11 23
6            6  17  5   13 25

Analyzable Statistics

I will show the common statistics that can be calculated based on this type of dataset.

hit rate / True Positive Rate

Rate of choosing the old when old items are presented
In other fields also called called sensitivity, but we use sensitivity for d'

\begin{align*} hit \ rate = \frac{H}{H + M}\ \end{align*}

Click here for source of formula

df$hit_rate <- df$hit/(df$hit+df$miss)

cat(paste("The hit rate is",format(round(mean(df$hit_rate),2)))) # The function mean turns the hit rate into the mean for the group

The hit rate is 0.65

Overall Percent Correct

Percentage of hits and correct rejections together

\begin{align*} Overall \ Percent \ Correct = \frac{H + CR}{H + M + FA + CR}\ \end{align*}

Click here for source of formula

df$per_corr = (df$hit+df$cr)/(df$hit+df$fa+df$miss+df$cr)*100
cat(paste("The overall percentage correct is",format(round(mean(df$per_corr),2))))

The overall percentage correct is 70.28

false alarm rate / False Positive Rate

Rate of choosing the old when new items are presented

\begin{align*} False \ alarm \ rate = \frac{FA}{FA + CR}\ \end{align*} Click here for source of formula

df$FA_rate <- df$fa/(df$cr+df$fa) # this will give the FA rate for each participant
cat(paste("The false alarm rate is",format(round(mean(df$FA_rate),2))))

The false alarm rate is 0.24

Specificity

rate of choosing new when new items are presented

\begin{align*} Specificity = \frac{CR}{CR + FA}\ \end{align*} Click here for source of formula

df$spec <- df$cr/(df$fa+df$cr) # this will give the FA rate for each participant
# or 1 - fa_rate
cat(paste("The false alarm rate is",format(round(mean(df$spec),2))))

The false alarm rate is 0.76

sensitivity (d’)

Ability to discriminate between the signal and noise

\begin{align*} Sensitivity = Z(H) - Z(FA)\ \end{align*} Click here for source of formula

df$sens = qnorm(df$hit_rate) - qnorm(df$FA_rate)
cat(paste("The sensitivity d' is",format(round(mean(df$sens,2)))))

The sensitivity d' is 1

Response Bias (c)

Individual’s tendency to favor one response alternative over the other

\begin{align*} Response \ Bias = -\frac{Z(hit \ rate) + Z(false \ alarm)}{2}\ \end{align*} Click here for source of formula

df$c = -((qnorm(df$hit_rate) + qnorm(df$FA_rate)) / 2)
cat(paste("The response bias c is",format(round(mean(df$c),2))))

The response bias c is 0.17

Diagnositicity ratio

The ratio of recognizing “old” items as old to recognizing new items as “old”.

\begin{align*} Diagnositicity \ ratio = \frac{hit \ rate}{false \ alarm \ rate}\ \end{align*} Click here for source of formula

df$diag = df$hit_rate/df$FA_rate
cat(paste("The diagnosticity is",format(round(mean(df$diag),2))))

The diagnosticity is 3.35

Positive likelihood ratio (PLR)

Probability that participants indicate “old” when the item is “old” divided by the probability that participants indicate “old” for “new” items

\begin{align*} Positive \ likelihood \ ratio = \frac{hit \ rate}{1 - false \ alarm \ rate}\ \end{align*} Click here for source of formula

# positive likelihood ratio
df$plr <- df$hit_rate/(1-df$FA_rate)
cat(paste("The PLR is",format(round(mean(df$plr),2))))

The PLR is 0.87

Negative likelihood ratio (NLR)

The probability of participants indicating “new” when the item is “old” divided by the probability that participants indicate “new” when the items is “new” (specificity)

\begin{align*} Negative \ likelihood \ ratio = \frac{1- hit \ rate}{specificity}\ \end{align*} Click here for source of formula

# Negative likelihood ratio
df$nlr <- (1-df$hit_rate)/df$spec
cat(paste("The NLR is",format(round(mean(df$nlr),2))))

The NLR is 0.47

Positive predictive value (PPV)

Probability that of correctly indicating “old” out of all “old” responses (hits +false alarms)

\begin{align*} Positive \ predictive \ value = \frac{H}{H + FA}\ \end{align*} Click here for source of formula

# positive likelihood ratio
df$ppv <- df$hit/(df$hit+df$fa) * 100
cat(paste("The PPV is",format(round(mean(df$ppv),2))))

The PPV is 73.23

Negative predictive value (NPV)

The probability of correctly indicating “new” out of all “new” responses (misses + correct rejections)

\begin{align*} Negative \ predictive \ value = \frac{CR}{CR + M}\ \end{align*} Click here for source of formula

# Negative likelihood ratio
df$nlr <- df$cr/(df$cr+df$miss) * 100
cat(paste("The NPV is",format(round(mean(df$nlr),2))))

## The NPV is 68.54

Recognition Memory Analyses

Wed, 13 Sep 2023 00:00:00 +0000

Analyzing Recognition Memory

I recently listened to the first episode of the podcast “Quantitude” wherein they discussed the ROC and AUC and the added benefits of such analyses. Moreover, the great article named “Measuring memory is harder than you think: How to avoid problematic measurement practices in memory research” motivated me to create example for simple designs on how to analyze such data. As these analyses are frequently used in memory research, I wanted to create a short tutorial on how to conduct such analyses in R.

See below the analyses for the following types of memory tasks: