Eligibility Screening
library(readr)
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
#importing screening spreadsheets
Screening_AP<- read_csv("~/Downloads/APIM_Screening_AP - Sheet1.csv")
## Rows: 121 Columns: 5
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (4): Citation, Eligible, If no, why, Comments
## lgl (1): Eligible_final
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
Screening_SH<- read_csv("~/Downloads/APIM_Screening_SH - Sheet1.csv")
## Rows: 121 Columns: 4
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (4): Citation, Eligible, If no, why, Eligible_final
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
# Assigning each study an ID
Screening_AP$ID<- 1:121
Screening_SH$ID<- 1:121
# Moving ID variable so it appears first
Screening_AP <- Screening_AP %>% relocate(ID)
Screening_SH <- Screening_SH %>% relocate(ID)
# Merging data
Screening <- merge(Screening_AP, Screening_SH, by = "ID")
# Convering yes and nos to 1s and 0s
Screening$Eligible.x <- ifelse(Screening$Eligible.x == "Yes", 1, 0)
Screening$Eligible.y <- ifelse(Screening$Eligible.y == "Yes", 1, 0)
# Calculating agreement
library(irr)
## Loading required package: lpSolve
eligible <- Screening %>% dplyr::select(Eligible.x, Eligible.y)
agree(eligible) # so 99.2% agreement
## Percentage agreement (Tolerance=0)
##
## Subjects = 121
## Raters = 2
## %-agree = 99.2
# Creating a new variable that indicates whether AP and SH agreed
Screening <- Screening %>%
mutate(MATCH = Eligible.x == Eligible.y)
table(Screening$MATCH)
##
## FALSE TRUE
## 1 120
120/121
## [1] 0.9917355
# After inspecting study that we disagreed on AP agreed with SH that study should be considered eligible
# creating new variable that has final decisions, because AP and SH agreed on every study except 1 just using AP data
Screening$Eligible.fin<- Screening$Eligible.x
# now changing AP response for discrepant so that AP and SH agree
Screening$Eligible.fin[Screening$ID == 92] <- 1
table(Screening$Eligible.fin)
##
## 0 1
## 22 99
99/121
## [1] 0.8181818
# So 99 or 82% of studies were eligible
#reasons for exclusion
table(Screening$`If no, why.x`)
##
## Correction
## 3
## Dyadic but did not explicity approach as APIM
## 1
## Methodological paper
## 1
## Non-english text
## 1
## Non-romantic dyads
## 17
# selecting only studies considered eligible
Extraction<- subset(Screening, Eligible.fin==1)
# removing unnecessary variables
Extraction <- Extraction[, c("ID", "Citation.x")]
# Assigning coding teams to certain articles
Extraction$Coder<- NA
99/2 # Each coding team will code about 50
## [1] 49.5
Extraction$Coder <- c(rep("SHEC", 50), rep("APAB", 49))
table(Extraction$Coder)
##
## APAB SHEC
## 49 50
# looks good
write.csv(Extraction, "Extraction_AP.csv", row.names = FALSE)
#Training round reliability was calulated manually for sake of simplicity and pairwise agreement ranged from 90-100%
Coding
library(readxl)
AP<- read_excel("~/Downloads/Extraction_AP (1).xlsx")
AP <- AP[AP$Coder != "SHEC", ] # getting rid of rows not coded by AP and AB
AB<- read_excel("~/Downloads/Extraction_AB (1).xlsx")
AB <- AB[AB$Coder != "SHEC", ]
SH<- read_excel("~/Downloads/Extraction_SH (1).xlsx")
SH <- SH[SH$Coder != "APAB", ]
EC<- read_excel("~/Downloads/Extraction_EC (1).xlsx")
EC <- EC[EC$Coder != "APAB", ]
# Comparing AP and AB studies to find discrepancies
comparison_APAB <- data.frame(
ID = AP$ID,
Sexorient_div = AP$Sexorient_div_AP == AB$Sexorient_div_AB,
Gender_div = AP$Gender_div_AP == AB$Gender_div_AB,
distinguish = AP$distinguish_AP == AB$distinguish_AB,
Justification = AP$Justification_AP == AB$Justification_AB,
Justification_AP = AP$Justification_AP,
Justification_AB = AB$Justification_AB,
Pwr = AP$Pwr_AP == AB$Pwr_AB,
Prereg = AP$Prereg_AP == AB$Prereg_AB,
Prereg_disting = AP$Prereg_disting_AP == AB$Prereg_disting_AB,
Prereg_just = AP$Prereg_just_AP == AB$Prereg_just_AB,
Gen_diff = AP$Gen_diff_AP == AB$Gen_diff_AB,
Interpret_diff = AP$Interpret_diff_AP == AB$Interpret_diff_AB
)
# calculating percent agreement
agreement_APAB <- sapply(comparison_APAB[-1], function(x) {
mean(x, na.rm = TRUE) * 100
})
## Warning in mean.default(x, na.rm = TRUE): argument is not numeric or logical:
## returning NA
## Warning in mean.default(x, na.rm = TRUE): argument is not numeric or logical:
## returning NA
round(agreement_APAB, 4)
## Sexorient_div Gender_div distinguish Justification
## 95.9184 93.8776 95.9184 85.7143
## Justification_AP Justification_AB Pwr Prereg
## NA NA 100.0000 100.0000
## Prereg_disting Prereg_just Gen_diff Interpret_diff
## 100.0000 97.9592 100.0000 93.8776
# agreement for distinguishing variable was manually calculated in a separate spreadsheet because this was a character variable so any minor difference (e.g., Gender vs gender) was flagged as a discrepancy
# I'm also finding an ICC for the justification variable as this was an ordinal variable
comparison_SHEC <- data.frame(
ID = SH$ID,
Sexorient_div = SH$Sexorient_div_SH == EC$Sexorient_div_EC,
Gender_div = SH$Gender_div_SH == EC$Gender_div_EC,
distinguish = SH$distinguish_SH == EC$distinguish_EC,
Justification = SH$Justification_SH == EC$Justification_EC,
Pwr = SH$Pwr_SH == EC$Pwr_EC,
Prereg = SH$Prereg_SH == EC$Prereg_EC,
Prereg_disting = SH$Prereg_disting_SH == EC$Prereg_disting_EC,
Prereg_just = SH$Prereg_just_SH == EC$Prereg_just_EC,
Gen_diff = SH$Gen_diff_SH == EC$Gen_diff_EC,
Interpret_diff = SH$Interpret_diff_SH == EC$Interpret_diff_EC
)
agreement_SHEC <- sapply(comparison_SHEC[-1], function(x) {
mean(x, na.rm = TRUE) * 100
})
round(agreement_SHEC, 4)
## Sexorient_div Gender_div distinguish Justification Pwr
## 94.0000 96.0000 88.0000 62.0000 97.9592
## Prereg Prereg_disting Prereg_just Gen_diff Interpret_diff
## 100.0000 100.0000 96.0000 80.0000 90.0000
write.csv(comparison_APAB, "compare_APAP.csv", row.names = FALSE)
write.csv(comparison_SHEC, "compare_SHEC.csv", row.names = FALSE)
Justification Reliability
data<- read_csv("~/Downloads/Extraction_Compiled - Sheet1.csv")
## Rows: 99 Columns: 19
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (15): Citation, Coder, Journal, Study, Sexorient_div_c, Gender_div_c, di...
## dbl (4): ID, Justification_ABEC, Justification_SHAB, Prereg_just_c
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
# I'm calculating weighted kappa for justification as this was an ordinal variable that we will be calculating mean ratings of
data[data =="NA"] <- NA
# After resolving discrepancies there were some cases where people disagreed on whether analysis was distinguishable. I'm taking the final determination and making it so that if we ultimately decided a study was indistinguishable, the justification is treated as NA
which(data$distinguish_c == "Indistinguishable" & !is.na(data$Justification_ABEC))
## [1] 11 15 30
which(data$distinguish_c == "Indistinguishable" & !is.na(data$Justification_SHAB))
## [1] 14 19 59 63
data$Justification_ABEC[
data$distinguish_c == "Indistinguishable"
] <- NA
data$Justification_SHAB[
data$distinguish_c == "Indistinguishable"
] <- NA
# Now finding weighted kappa
library(irr)
data$Justification_APEC <- data$Justification_ABEC #renaming this variable as I previously erroneously labelled it. This column was ratings from AP and EC
# Percent agreement
mean(data$Justification_APEC[1:64] == data$Justification_SHAB[1:64], na.rm = TRUE) * 100
## [1] 75
mean(data$Justification_APEC[65:120] == data$Justification_SHAB[65:120], na.rm = TRUE) * 100
## [1] 85.71429
# so average pairwise agreement is 80.35%
Results
table(data$Journal)
##
## Addiction
## 1
## Anxiety, Stress, & Coping
## 1
## Applied Research in Quality of Life
## 1
## Assessment
## 1
## BMC Psychology
## 1
## British Psychological Society
## 1
## Child abuse & neglect
## 1
## Community, Work & Family
## 1
## Contemporary Family Therapy
## 3
## Couple and Family Psychology: Research and Practice
## 2
## Couple and Family Psychology: Research and Practice
## 1
## Culture, Health & Sexuality
## 1
## Current Psychological Research & Reviews
## 1
## Current Psychology
## 3
## Drug and alcohol dependence
## 1
## Early Childhood Research Quarterly
## 1
## Emerging adulthood
## 1
## European Journal of Oncology Nursing
## 1
## Family Process
## 3
## Family Relations
## 3
## Frontiers in Psychology
## 4
## International Journal of Developmental Disabilities
## 1
## Interpersona
## 1
## Japanese Psychological Research
## 1
## Journal of Affective Disorders
## 1
## Journal of Career Assessment
## 1
## Journal of Consulting and Clinical Psychology
## 1
## Journal of Family Communication
## 1
## Journal of Family Psychology
## 2
## Journal of Family Violence
## 4
## Journal of Happiness Studies
## 1
## Journal of Interpersonal Violence
## 2
## Journal of Marital and Family Therapy
## 1
## Journal of Marriage and Family
## 3
## Journal of Personality
## 1
## Journal of Sex & Marital Therapy
## 1
## Journal of Social and Personal Relationships
## 9
## Journal of Youth and Adolescence
## 1
## Marriage & Family Review
## 2
## Neuroimage
## 1
## Personality and Individual Differences
## 1
## Preventative Medicine
## 1
## Psychiatric Quarterly
## 3
## Psycho-Oncology
## 3
## Psychological Trauma: Theory, Research, Practice, and Policy
## 3
## Psychology & Health
## 1
## Psychology of Sexual Orientation and Gender Diversity
## 1
## Psychology of Violence
## 3
## Psychology, Health, and Medicine
## 1
## Psychotherapy
## 1
## Scandinavian Journal of Psychology
## 1
## Sexual and Relationship Therapy
## 2
## Sexuality Research and Social Policy
## 1
## Social Psychiatry and Psychiatric Epidemiology
## 1
## The Gerentologist
## 1
## The Gerontologist
## 1
## The Journal of Sex Research
## 4
## The Journal of Sexual Medicine
## 1
## The Open Psychology Journal
## 1
table(data$Sexorient_div_c)
##
## No Yes
## 75 24
prop.table(table(data$Sexorient_div_c))
##
## No Yes
## 0.7575758 0.2424242
table(data$Gender_div_c)
##
## No Yes
## 91 8
prop.table(table(data$Gender_div_c))
##
## No Yes
## 0.91919192 0.08080808
table(data$distinguish_c)
##
## Distinguishable Indistinguishable
## 77 22
prop.table(table(data$distinguish_c))
##
## Distinguishable Indistinguishable
## 0.7777778 0.2222222
table(data$dist_var_c)
##
## Child-bearing partner Experimental condition Gender
## 1 2 65
## Patient status Veteran status
## 8 2
prop.table(table(data$dist_var_c))
##
## Child-bearing partner Experimental condition Gender
## 0.01282051 0.02564103 0.83333333
## Patient status Veteran status
## 0.10256410 0.02564103
data <- data %>%
rowwise() %>%
mutate(Justification = mean(c(Justification_APEC, Justification_SHAB), na.rm = TRUE))%>%
ungroup()
summary(data$Justification)
## Min. 1st Qu. Median Mean 3rd Qu. Max. NAs
## 0.000 0.000 1.000 1.013 2.000 2.000 22
mean(data$Justification, na.rm=T)
## [1] 1.012987
table(data$Justification)
##
## 0 0.5 1 1.5 2
## 24 4 17 10 22
prop.table(table(data$Justification))
##
## 0 0.5 1 1.5 2
## 0.31168831 0.05194805 0.22077922 0.12987013 0.28571429
table(data$Pwr_c)
##
## No Yes
## 76 23
prop.table(table(data$Pwr_c))
##
## No Yes
## 0.7676768 0.2323232
table(data$Prereg_c)
##
## No Yes
## 93 6
prop.table(table(data$Prereg_c))
##
## No Yes
## 0.93939394 0.06060606
table(data$Prereg_disting_c)
##
## NA (no preregistration) No, not reported Yes, distinguishable
## 93 3 1
## Yes, indistinguishable
## 2
prop.table(table(data$Prereg_disting_c))
##
## NA (no preregistration) No, not reported Yes, distinguishable
## 0.93939394 0.03030303 0.01010101
## Yes, indistinguishable
## 0.02020202
table(data$Prereg_just_c)
##
## 0
## 3
prop.table(table(data$Prereg_just_c))
##
## 0
## 1
table(data$Gen_diff_c)
##
## No Yes
## 23 76
prop.table(table(data$Gen_diff_c))
##
## No Yes
## 0.2323232 0.7676768
table(data$Interpret_diff_c)
##
## No Yes
## 29 70
prop.table(table(data$Interpret_diff_c))
##
## No Yes
## 0.2929293 0.7070707