Investigating the genetic and environmental aetiologies of non-suicidal and suicidal self-harm: A twin study
Kai Lim
Introduction
This RMarkdown document aims to compile the R scripts used in the registered project: “Genetic and environmental aetiology of suicidal and non-suicidal self-harm”
Load the libraries, switch default optimiser to SLSQP, and print version of R and OpenMx used:
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be done before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse);require(knitr);require(kableExtra)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
session_info=sessionInfo()
session_info$R.version$version.string## [1] "R version 3.6.2 (2019-12-12)"paste(session_info$otherPkgs$OpenMx$Package,
session_info$otherPkgs$OpenMx$Version)## [1] "OpenMx 2.17.3"Load the data, apply exclusion criteria, and clean the data
self_harm_data=read.spss("/Users/kai/OneDrive - King's College London/PhD/TEDS_project/data/427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,x3zygos,sexzyg,u1cage1,u1cage2,sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
#code for binary variables NSSHr1/2, SSHr1/2 for Table 2
#NSSHr1/2
self_harm_data_c <- mutate(self_harm_data_c, NSSHr1 = ifelse(NSSH1==0|NSSH1==1|is.na(NSSH1),NSSH1,1))
self_harm_data_c <- mutate(self_harm_data_c, NSSHr2 = ifelse(NSSH2==0|NSSH2==1|is.na(NSSH2),NSSH2,1))
#SSHr1/2
self_harm_data_c <- mutate(self_harm_data_c, SSHr1 = ifelse(SSH1==0|SSH1==1|is.na(SSH1),SSH1,1))
self_harm_data_c <- mutate(self_harm_data_c, SSHr2 = ifelse(SSH2==0|SSH2==1|is.na(SSH2),SSH2,1))
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
self_harm_data_c$NSSHr1<-mxFactor(self_harm_data_c$NSSHr1, levels=c(0:1) )
self_harm_data_c$NSSHr2<-mxFactor(self_harm_data_c$NSSHr2, levels=c(0:1) )
self_harm_data_c$SSHr1<-mxFactor(self_harm_data_c$SSHr1, levels=c(0:1) )
self_harm_data_c$SSHr2<-mxFactor(self_harm_data_c$SSHr2, levels=c(0:1) )
#variables to be used
useVars <-c('NSSH1', 'SSH1', 'NSSH2', 'SSH2' , 'u1cage1', 'u1cage2', 'sex1','sex2')
# Select Data for Analysis
selfharmdata_subset<-subset(self_harm_data_c, !is.na(x3zygos)&!is.na(u1cage1|u1cage2) &!is.na(sex1&sex2), useVars)
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(u1cage1|u1cage2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(u1cage1|u1cage2) &!is.na(sex1&sex2), useVars)
mzData <- mutate(mzData, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
mzData <- mutate(mzData, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
dzData <- mutate(dzData, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
dzData <- mutate(dzData, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))Descriptive statistics
Table 2
Look at prevalence of NSSH and SSH in the full sample, males and females, and mean age. These information form the basis for constructing Table 2
# to reduce missing data, if one cotwin's age data is missing but their cotwin's age data is available, we used their cotwin's available age data as a proxy to their age.
self_harm_data_descriptive<-self_harm_data_c %>%
filter((!is.na(NSSH1)|!is.na(NSSH2)|!is.na(NSSH1)|!is.na(NSSH2)) &
!is.na(u1cage1|u1cage2) & !is.na(sex1&sex2) & !is.na(sexzyg))%>%
mutate(age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))%>%
mutate(age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))%>%
filter(!is.na(age1&age2) &!is.na(sex1&sex2))
# write function to create the table for the full sample, male and female samples:
table_1_fun<-function(X1,X2,X3){
total_NSSH=sum(table(X1)) #total for NSSH
table_NSSH=table(X1)
prop_NSSH=round(prop.table(table(X1))*100,1)
total_SSH=sum(table(X2)) #total for NSSH
table_SSH=table(X2)
prop_SSH=round(prop.table(table(X2))*100,1)
meanage=round(mean(X3,na.rm=T),1)
return(rbind(cbind(total_NSSH,table_NSSH,prop_NSSH),cbind(total_SSH,table_SSH,prop_SSH),meanage))
}
fullsample=table_1_fun(self_harm_data_descriptive$NSSH1,self_harm_data_descriptive$SSH1,self_harm_data_descriptive$u1cage1)
malesample=table_1_fun(self_harm_data_descriptive[self_harm_data_descriptive$sex1==1,]$NSSH1,self_harm_data_descriptive[self_harm_data_descriptive$sex1==1,]$SSH1,self_harm_data_descriptive[self_harm_data_descriptive$sex1==1,]$u1cage1)
femalesample=table_1_fun(self_harm_data_descriptive[self_harm_data_descriptive$sex1==0,]$NSSH1,self_harm_data_descriptive[self_harm_data_descriptive$sex1==0,]$SSH1,self_harm_data_descriptive[self_harm_data_descriptive$sex1==0,]$u1cage1)
final_table<-as.data.frame(cbind(fullsample,malesample,femalesample),row.names=c(rep("NSSH",5),rep("SSH",5),"mean age (years)"))
colnames(final_table)<-c("Total N","N in each group","%",
"Male sample total N","N in each group","%",
"Female sample total N","N in each group","%")
rownames(final_table)<-c("NSSH: No",
"NSSH: Yes, 1-2 times",
"NSSH: Yes, 3-5 times",
"NSSH: Yes, 6-10 times",
"NSSH: Yes, >10 times",
"SSH: No",
"SSH: Yes, 1-2 times",
"SSH: Yes, 3-5 times",
"SSH: Yes, 6-10 times",
"SSH: Yes, >10 times",
"Mean age (Years)")
kableExtra::kable(final_table,digits=c(rep(c(0,0,1),3)),align="c")%>%
kable_styling(font_size = 12)%>%
collapse_rows()| Total N | N in each group | % | Male sample total N | N in each group | % | Female sample total N | N in each group | % | |
|---|---|---|---|---|---|---|---|---|---|
| NSSH: No | 9063 | 7080 | 78.1 | 3407 | 2887 | 84.7 | 5656 | 4193 | 74.1 |
| NSSH: Yes, 1-2 times | 951 | 10.5 | 295 | 8.7 | 656 | 11.6 | |||
| NSSH: Yes, 3-5 times | 293 | 3.2 | 72 | 2.1 | 221 | 3.9 | |||
| NSSH: Yes, 6-10 times | 195 | 2.2 | 39 | 1.1 | 156 | 2.8 | |||
| NSSH: Yes, >10 times | 544 | 6.0 | 114 | 3.3 | 430 | 7.6 | |||
| SSH: No | 9061 | 8106 | 89.5 | 3143 | 92.3 | 5654 | 4963 | 87.8 | |
| SSH: Yes, 1-2 times | 640 | 7.1 | 180 | 5.3 | 460 | 8.1 | |||
| SSH: Yes, 3-5 times | 144 | 1.6 | 47 | 1.4 | 97 | 1.7 | |||
| SSH: Yes, 6-10 times | 60 | 0.7 | 11 | 0.3 | 49 | 0.9 | |||
| SSH: Yes, >10 times | 111 | 1.2 | 26 | 0.8 | 85 | 1.5 | |||
| Mean age (Years) | 22 | 22 | 22.3 | 22 | 22 | 22.3 | 22 | 22 | 22.2 |
Export the table to an Excel file to be further editted for Table 2 in manuscript. Note that it was named as Table 1 as sheetName, but it is actually represented as Table 2 in our final manuscript:
#xlsx::write.xlsx(final_table, "descriptive_stats.xlsx", sheetName = "Table_1_proportions")| Full.sample.N | (%) | Male.sample.N | (%) | Female.sample.N | (%) | |
|---|---|---|---|---|---|---|
| Either_or_both | 2057 | 22.7 | 542 | 15.9 | 1515 | 26.8 |
| Both | 881 | 9.7 | 242 | 7.1 | 639 | 11.3 |
| NSSH only | 1102 | 12.2 | 278 | 8.2 | 824 | 14.6 |
| SSH only | 74 | 0.8 | 22 | 0.6 | 52 | 0.9 |
We then run chi-square tests for sex differences in NSSH:
# chi-square test for sex differences
table_chi_sq_NSSH=table(self_harm_data_descriptive$sex1,self_harm_data_descriptive$NSSH1)
chisq.test(table_chi_sq_NSSH) #for NSSH##
## Pearson's Chi-squared test
##
## data: table_chi_sq_NSSH
## X-squared = 159.18, df = 4, p-value < 2.2e-16Chi-square test for sex differences in SSH:
table_chi_sq_SSH=table(self_harm_data_descriptive$sex1,self_harm_data_descriptive$SSH1)
chisq.test(table_chi_sq_SSH) # For SSH##
## Pearson's Chi-squared test
##
## data: table_chi_sq_SSH
## X-squared = 49.76, df = 4, p-value = 4.053e-10Table S5
The code below calculates the proportion of MZM, DZM, MZF, DZF, DZOS twins and incomplete twin pairs. It forms part of Table S5 in the Supplementary Material
knitr::opts_knit$set(root.dir = "/Users/kai/OneDrive - King's College London/PhD/TEDS_project/results" )
mzmData <- subset(self_harm_data_descriptive, sexzyg==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #MZM
dzmData <- subset(self_harm_data_descriptive, sexzyg==2 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #DZM
mzfData <- subset(self_harm_data_descriptive, sexzyg==3 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #MZF
dzfData <- subset(self_harm_data_descriptive, sexzyg==4 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #DZF
dzoData <- subset(self_harm_data_descriptive, sexzyg==5 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #DZO
#for NSSH
mzmcom=table(!is.na(mzmData$NSSH1)&!is.na(mzmData$NSSH2))[2]
dzmcom=table(!is.na(dzmData$NSSH1)&!is.na(dzmData$NSSH2))[2]
mzfcom=table(!is.na(mzfData$NSSH1)&!is.na(mzfData$NSSH2))[2]
dzfcom=table(!is.na(dzfData$NSSH1)&!is.na(dzfData$NSSH2))[2]
dzocom=table(!is.na(dzoData$NSSH1)&!is.na(dzoData$NSSH2))[2]
incom=sum(table(xor(!is.na(mzmData$NSSH1),!is.na(mzmData$NSSH2)))[2],
table(xor(!is.na(dzmData$NSSH1),!is.na(dzmData$NSSH2)))[2],
table(xor(!is.na(mzfData$NSSH1),!is.na(mzfData$NSSH2)))[2],
table(xor(!is.na(dzfData$NSSH1),!is.na(dzfData$NSSH2)))[2],
table(xor(!is.na(dzoData$NSSH1),!is.na(dzoData$NSSH2)))[2])
sumNSSH=sum(sum(mzmcom,dzmcom,mzfcom,dzfcom,dzocom)*2,incom)
NSSH=rbind(mzmcom,dzmcom,mzfcom,dzfcom,dzocom,incom,sumNSSH)
#for SSH
mzmcom=table(!is.na(mzmData$SSH1)&!is.na(mzmData$SSH2))[2]
dzmcom=table(!is.na(dzmData$SSH1)&!is.na(dzmData$SSH2))[2]
mzfcom=table(!is.na(mzfData$SSH1)&!is.na(mzfData$SSH2))[2]
dzfcom=table(!is.na(dzfData$SSH1)&!is.na(dzfData$SSH2))[2]
dzocom=table(!is.na(dzoData$SSH1)&!is.na(dzoData$SSH2))[2]
incom=sum(table(xor(!is.na(mzmData$SSH1),!is.na(mzmData$SSH2)))[2],
table(xor(!is.na(dzmData$SSH1),!is.na(dzmData$SSH2)))[2],
table(xor(!is.na(mzfData$SSH1),!is.na(mzfData$SSH2)))[2],
table(xor(!is.na(dzfData$SSH1),!is.na(dzfData$SSH2)))[2],
table(xor(!is.na(dzoData$SSH1),!is.na(dzoData$SSH2)))[2])
sumSSH=sum(sum(mzmcom,dzmcom,mzfcom,dzfcom,dzocom)*2,incom)
SSH=rbind(mzmcom,dzmcom,mzfcom,dzfcom,dzocom,incom,sumSSH)
table_twin_prop<-as.data.frame(cbind(NSSH,SSH), row.names = c("MZM (pairs)", "DZM (pairs)","MZF (pairs)","DZF (pairs)","DZOS (pairs)","Single twins", "Total number"))
colnames(table_twin_prop)<-c("NSSH","SSH")
knitr::kable(table_twin_prop, align="rcc")%>%
kable_styling(font_size = 12)| NSSH | SSH | |
|---|---|---|
| MZM (pairs) | 490 | 490 |
| DZM (pairs) | 395 | 394 |
| MZF (pairs) | 984 | 986 |
| DZF (pairs) | 791 | 792 |
| DZOS (pairs) | 1093 | 1094 |
| Single twins | 1557 | 1549 |
| Total number | 9063 | 9061 |
Save the results to the same excel file in sheet 2.
write.xlsx(table_twin_prop,"descriptive_stats.xlsx", sheetName = "Table_2_twins",append = T)Table S2
We used the code below to produce descriptive statistics for mental health measures collected at age 16
#redefine self_harm_data_c as this script initially saved as a different file.
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
#recoded cCANN, cSMOK and cALC as they are ordinal variables
#cCANN
self_harm_data_c <- mutate(self_harm_data_c, cCANN = ifelse(is.na(pcbhdrug151)&pcbhdrug121==0,pcbhdrug121,pcbhdrug151))
#cSMOK
self_harm_data_c <- mutate(self_harm_data_c, cSMOK = ifelse(is.na(pcbhdrug091)&pcbhdrug061==0,pcbhdrug061,pcbhdrug091))
#cALC
self_harm_data_c$pcbhdrug051<-self_harm_data_c$pcbhdrug051-1
self_harm_data_c$pcbhdrug052<-self_harm_data_c$pcbhdrug052-1
self_harm_data_c <- mutate(self_harm_data_c, cALC = ifelse(is.na(pcbhdrug051)&pcbhdrug011==0,pcbhdrug011,pcbhdrug051))
#rename some columns to ease the next steps:
self_harm_data_c <-self_harm_data_c%>%
rename(
pSDQ=ppbhsdqbeht1,
cSDQ=pcbhsdqbeht1,
pCONN=ppbhconnt1,
pEMOL=ppbhconnemlt1,
pHYPER=ppbhconnimpt1,
pINAT=ppbhconninat1,
pMFQ=ppbhmfqt1,
cMFQ=pcbhmfqt1,
pAUT=ppbhaqt1,
cAUT=pcbhaqt1,
cCAPS=pcbhcapst1,
cGRAND=pcbhgrndt1,
cPRND=pcbhprndt1,
pSANS=ppbhsanst1,
cANHE=pcbhanhdt1,
pANX=ppbhanxt1,
cANX=pcbhcasit1,
cTEPS=pcbhtepst1,
cEAT=pcbheddsm1,
cINSOM=pcbhinsomt1,
cSWAN=pcbhswanm1)
DesData <- subset(self_harm_data_c, !is.na(age1&age2) &!is.na(sex1&sex2)& (!is.na(NSSH1)|!is.na(SSH1)))
#
#select only one twin from each pair because of double entry method
measures<-c("pHYPER",'pCONN',"pEMOL",'pINAT','pSDQ',"cAUT","cSDQ","pAUT","cSWAN",
"cANX","pANX","pMFQ","cEAT","cINSOM","cMFQ",
"pSANS","cCAPS","cANHE","cPRND","cGRAND","cTEPS",
"cSMOK","cCANN","cALC")
des_table<-data.frame()
for (i in 1:length(measures))
{des<-describe(DesData[,measures[i]])
des_table[i,1]<-measures[i]
des_table[i,c(2:4)]<-c(des$n,des$mean,des$sd)
}
colnames(des_table)<-c("Measure","Sample size","Mean","SD")
des_table<-des_table%>%
add_column(Category=ifelse(des_table$Measure=="pSDQ"|
des_table$Measure=="cSDQ"|
des_table$Measure=="pAUT"|
des_table$Measure=="cAUT","Others",
ifelse(des_table$Measure=="pCONN"|
des_table$Measure=="pEMOL"|
des_table$Measure=="pINAT"|
des_table$Measure=="pHYPER"|
des_table$Measure=="cSWAN","Externalising problems",
ifelse(des_table$Measure=="pMFQ"|
des_table$Measure=="cMFQ"|
des_table$Measure=="pANX"|
des_table$Measure=="cANX"|
des_table$Measure=="cEAT"|
des_table$Measure=="cINSOM","Internalising problems",
ifelse(des_table$Measure=="cCAPS"|
des_table$Measure=="cGRAND"|
des_table$Measure=="cTEPS"|
des_table$Measure=="cANHE"|
des_table$Measure=="cPRND"|
des_table$Measure=="pSANS","Psychotic-like experiences",
ifelse(des_table$Measure=="cSMOK"|
des_table$Measure=="cALC"|
des_table$Measure=="cCANN","Substance abuse","No"))))))%>%
select(Category, Measure, `Sample size`, Mean, SD)%>%
arrange(Measure)%>%
arrange(Category)
des_table$Mean<-round(des_table$Mean,2)
CANN<-paste(round((1-prop.table(table(DesData$cCANN))[1])*100,2),"%")
SMOK<-paste(round((1-prop.table(table(DesData$cSMOK))[1])*100,2), "%")
ALC<-paste(round((1-prop.table(table(DesData$cALC))[1])*100,2), "%")
des_table$Mean[22:24]<-c(CANN,SMOK,ALC)
des_table$SD[22:24]<-NA
knitr::kable(des_table,digits=2)%>%
kable_styling(font_size = 12)%>%
collapse_rows()| Category | Measure | Sample size | Mean | SD |
|---|---|---|---|---|
| Externalising problems | cSWAN | 1474 | 4.81 | 0.82 |
| pCONN | 6658 | 5.93 | 6.65 | |
| pEMOL | 6661 | 1.17 | 1.72 | |
| pHYPER | 6656 | 2.31 | 3.15 | |
| pINAT | 6657 | 3.62 | 4.40 | |
| Internalising problems | cANX | 6666 | 8.2 | 5.91 |
| cEAT | 1465 | 3.24 | 1.92 | |
| cINSOM | 5175 | 3.8 | 4.12 | |
| cMFQ | 6665 | 3.74 | 4.51 | |
| pANX | 6666 | 3.59 | 4.17 | |
| pMFQ | 6663 | 0.93 | 2.21 | |
| Others | cAUT | 6659 | 12.12 | 5.78 |
| cSDQ | 6661 | 9.35 | 5.10 | |
| pAUT | 6665 | 23.75 | 10.76 | |
| pSDQ | 6669 | 3.46 | 2.99 | |
| Psychotic-like experiences | cANHE | 6657 | 1.25 | 1.30 |
| cCAPS | 6666 | 4.74 | 6.08 | |
| cGRAND | 6662 | 5.14 | 4.33 | |
| cPRND | 6663 | 12.26 | 10.65 | |
| cTEPS | 6667 | 33.89 | 7.77 | |
| pSANS | 6660 | 2.68 | 3.79 | |
| Substance abuse | cALC | 4451 | 8.34 % | NA |
| cCANN | 5026 | 20.03 % | NA | |
| cSMOK | 5007 | 35.34 % | NA |
We then exported the table into an Excel file for further editting.
xlsx::write.xlsx(des_table,"MH_measures.xlsx")Univariate model
Although in the manuscript we mainly presented the bivariate model, we also fitted two univariate models, one for NSSH and one for SSH.
The codes presented below were used to derive results in Note S1 and Table S3.
Univariate model for NSSH
Full script:
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>%
filter(!is.na(u1cslfh021)|!is.na(u1cslfh022))%>% #no missing data for self-harm
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032, x3zygos,sexzyg,u1cage1,u1cage2,sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric)
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
nv <- 1 # number of variables per twin
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
selVars <- c('NSSH1' , 'NSSH2')
useVars<- c('NSSH1' , 'NSSH2',"sex1","sex2",'u1cage1', 'u1cage2')
# Select Data for Analysis
#x3zygos 1 = MZ, not 1 = DZ twins
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(u1cage1|u1cage2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(u1cage1|u1cage2) &!is.na(sex1&sex2), useVars)
# series of comparisons were carried out to see the missing values. There is no missing value for excluding unknown sex
# - already excluded in exclude line in the first place.
# for age, the benefit of using co-twin's age as proxy is there - to retain sample size.
# mzData2 <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(u1cage1|u1cage2), useVars) #select only one twin from each pair because of double entry method
# dzData2 <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(u1cage1|u1cage2), useVars)
#
# mzData3 <- subset(self_harm_data_c, x3zygos==1 & random==1 &!is.na(u1cage1&u1cage2), useVars) #select only one twin from each pair because of double entry method
# dzData3 <- subset(self_harm_data_c, x3zygos!=1 & random==1 &!is.na(u1cage1&u1cage2), useVars)
#
# mzData4 <- subset(self_harm_data_c, x3zygos==1 & random==1 &!is.na(u1cage1&u1cage2)&!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
# dzData4 <- subset(self_harm_data_c, x3zygos!=1 & random==1 &!is.na(u1cage1&u1cage2)&!is.na(sex1&sex2), useVars)
#fill in missing ages using proxy, creating new age variable "age"
mzData <- mutate(mzData, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
mzData <- mutate(mzData, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
dzData <- mutate(dzData, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
dzData <- mutate(dzData, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
# 1) Specify Saturated Model (Tetrachoric correlations)
# Matrix & Algebra for expected means (SND), Thresholds and correlation
obs1 <-mxMatrix(type="Full", nrow=1, ncol=2, free=F,labels=c("data.age1","data.age2"), name="age" )
obs2 <-mxMatrix(type="Full", nrow=1, ncol=2, free=F,labels=c("data.sex1","data.sex2"), name="sex" )
MeanL <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="M" )
betaA <-mxMatrix( type="Full", nrow=nth, ncol=1, free=TRUE, values=.05,
labels=c("BaTH"), name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=1, free=TRUE, values=.05,
labels=c("BsTH"), name="BsexTH" )
Inc <-mxMatrix( type="Lower", nrow=nth, ncol=nth, free=FALSE, values=1, name="L" )
Tmz <-mxMatrix(type="Full", nrow=nth, ncol=ntv, free=TRUE, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05), lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1),
labels=c("Tmz11","imz11","imz21","imz31", "Tmz12","imz12","imz22","imz32"), name="ThMZ" )
ThreMZ <-mxAlgebra( expression= L %*% ThMZ+ BageTH%x%age + BsexTH%x%sex, name="expThreMZ" )
Tdz <-mxMatrix(type="Full", nrow=nth, ncol=ntv, free=TRUE, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05), lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1),
labels=c("Tdz11","idz11","idz21","idz31", "Tdz12","idz12","idz22","idz32"), name="ThDZ" )
ThreDZ <-mxAlgebra( expression= L %*% ThDZ+ BageTH%x%age + BsexTH%x%sex, name="expThreDZ" )
CorMZ <-mxMatrix(type="Stand", nrow=ntv, ncol=ntv, free=T, values=.6, lbound=-.999, ubound=.999, name="expCorMZ")
CorDZ <-mxMatrix(type="Stand", nrow=ntv, ncol=ntv, free=T, values=.3, lbound=-.999, ubound=.999, name="expCorDZ")
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="expCorMZ", means="M", dimnames=selVars, thresholds="expThreMZ" )
objDZ <- mxExpectationNormal( covariance="expCorDZ", means="M", dimnames=selVars, thresholds="expThreDZ" )
fitFunction <- mxFitFunctionML()
# Combine Groups
modelMZ <- mxModel( MeanL, obs1, obs2, betaA, betaS ,Inc, Tmz, ThreMZ, CorMZ, dataMZ, objMZ, fitFunction, name="MZ" )
modelDZ <- mxModel( MeanL, obs1, obs2, betaA, betaS ,Inc, Tdz, ThreDZ, CorDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
Conf <- mxCI (c ('MZ.expCorMZ[2,1]', 'DZ.expCorDZ[2,1]','MZ.BageTH[1,1]','MZ.BsexTH[1,1]') )
SatModel <- mxModel( "Sat", modelMZ, modelDZ, minus2ll, obj, Conf )
# 1) RUN Saturated Model (Tetrachoric correlations)
SatFit <- mxRun( SatModel,intervals=T)
(SatSum <- summary(SatFit))
SatFit$output
# Generate SatModel Output
round(SatFit@output$estimate,4)
SatFit$MZ$expCorMZ
SatFit$DZ$expCorDZ
mxEval(MZ.expThreMZ, SatFit)
mxEval(MZ.expCorMZ, SatFit)
mxEval(DZ.expThreDZ, SatFit)
mxEval(DZ.expCorDZ, SatFit)
# 2) Specify and Run Sub1Model: equating Thresholds across Twin 1 and Twin 2 within MZ group
# Note: omxSetParameters: function to modify the attributes of parameters in a model
# without having to re-specify the model
Sub1Model <- mxModel(SatModel, name="sub1")
Sub1Model <- omxSetParameters(Sub1Model, labels=c("Tmz11","imz11","imz21","imz31", "Tmz12","imz12","imz22","imz32"),
newlabels=c("Tmz11","imz11","imz21","imz31", "Tmz11","imz11","imz21","imz31"), free=T, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05),
lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1))
Sub1Fit <- mxRun( Sub1Model,intervals=TRUE)
(Sub1Sum <- summary(Sub1Fit))
mxCompare(SatFit, Sub1Fit)
# Generate Sub1Model Output
round(Sub1Fit@output$estimate,4)
Sub1Fit$MZ$expCorMZ
Sub1Fit$DZ$expCorDZ
mxEval(MZ.expThreMZ, Sub1Fit)
mxEval(MZ.expCorMZ, Sub1Fit)
mxEval(DZ.expThreDZ, Sub1Fit)
mxEval(DZ.expCorDZ, Sub1Fit)
# 3) Specify and Run Sub2Model: equating Thresholds across Twin 1 and Twin 2 within DZ group
Sub2Model <- mxModel(SatModel, name="sub2")
Sub2Model <- omxSetParameters(Sub2Model, labels=c("Tdz11","idz11","idz21","idz31", "Tdz12","idz12","idz22","idz32"),
newlabels=c("Tdz11","idz11","idz21","idz31", "Tdz11","idz11","idz21","idz31"), free=T, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05),
lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1))
Sub2Fit <- mxRun( Sub2Model, intervals=TRUE)
(Sub2Sum <- summary(Sub2Fit))
mxCompare(SatFit, Sub2Fit)
# Generate Sub2Model Output
round(Sub2Fit@output$estimate,4)
Sub2Fit$MZ$expCorMZ
Sub2Fit$DZ$expCorDZ
mxEval(MZ.expThreMZ, Sub2Fit)
mxEval(MZ.expCorMZ, Sub2Fit)
mxEval(DZ.expThreDZ, Sub2Fit)
mxEval(DZ.expCorDZ, Sub2Fit)
# 4) Specify and Run Sub3Model: equating Thresholds across Twin 1 and Twin 2 and zygosity groups
Sub3Model <- mxModel(Sub1Model, name="sub3")
Sub3Model <- omxSetParameters(Sub3Model, labels=c("Tdz11","idz11","idz21","idz31", "Tdz12","idz12","idz22","idz32"),
newlabels=c("Tmz11","imz11","imz21","imz31", "Tmz11","imz11","imz21","imz31"), free=T, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05),
lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1))
Sub3Fit <- mxRun(Sub3Model, intervals=TRUE)
(Sub3Sum <- summary(Sub3Fit))
# Generate Sub3Model Output
round(Sub3Fit@output$estimate,4)
Sub3Fit$MZ$expCorMZ
Sub3Fit$DZ$expCorDZ
mxEval(MZ.expThreMZ, Sub3Fit)
mxEval(MZ.expCorMZ, Sub3Fit)
mxEval(DZ.expThreDZ, Sub3Fit)
mxEval(DZ.expCorDZ, Sub3Fit)
# *********************************************************************
# Print Comparative Fit Statistics for Saturated and all sub Models
(SatNested.fit <- rbind(
mxCompare(SatFit, Sub1Fit),
mxCompare(SatFit, Sub2Fit)[2,],
mxCompare(SatFit, Sub3Fit)[2,] ) )
## Sub3Fit is a good enough fit! p>0.05
# 5) Specify ACE Model, with ONE overall set of Thresholds
# Note: There is a constraint on the total variances to be unity
#define definition variables
obs1 <-mxMatrix(type="Full", nrow=1, ncol=2, free=F,labels=c("data.age1","data.age2"), name="age" )
obs2 <-mxMatrix(type="Full", nrow=1, ncol=2, free=F,labels=c("data.sex1","data.sex2"), name="sex" )
# Matrices declared to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Full", nrow=1, ncol=1, free=TRUE, values=.6, label="a11", name="a" )
pathC <- mxMatrix( type="Full", nrow=1, ncol=1, free=TRUE, values=.6, label="c11", name="c" )
pathE <- mxMatrix( type="Full", nrow=1, ncol=1, free=TRUE, values=.6, label="e11", name="e" )
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
covP <- mxAlgebra( expression=A+C+E, name="V" )
# Matrix & Algebra for expected means vector and expected thresholds
meanL <- mxMatrix( type="Zero", nrow=1, ncol=ntv, name="M" )
Inc <- mxMatrix( type="Lower", nrow=nth, ncol=nth, free=FALSE, values=1, name="L" )
betaA <-mxMatrix( type="Full", nrow=nth, ncol=1, free=TRUE, values=.05,
labels=c("BaTH"), name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=1, free=TRUE, values=.05,
labels=c("BsTH"), name="BsexTH" )
Threshold <-mxMatrix(type="Full", nrow=nth, ncol=ntv, free=TRUE, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05),
lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1),
labels=c("T11","i11","i21","i31", "T11","i11","i21","i31"), name="Th" )
Thre <-mxAlgebra( expression= L %*% Th + BageTH%x%age + BsexTH%x%sex, name="expThre" )
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="expCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="expCovDZ" )
# Constraint on total variance of Ordinal variables (A+C+E=1)
matUnv <- mxMatrix( type="Unit", nrow=nv, ncol=1, name="Unv" )
varL <- mxConstraint( expression=diag2vec(V)==Unv, name="VarL" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="expCovMZ", means="M", dimnames=selVars, thresholds="expThre" )
objDZ <- mxExpectationNormal( covariance="expCovDZ", means="M", dimnames=selVars, thresholds="expThre" )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, matUnv )
modelMZ <- mxModel( pars, meanL, obs1, obs2, betaA, betaS ,Inc, Threshold, Thre, covMZ, dataMZ, objMZ, fitFunction, name="MZ" )
modelDZ <- mxModel( pars, meanL, obs1, obs2, betaA, betaS ,Inc, Threshold, Thre, covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll<- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
Conf <- mxCI (c ('A[1,1]', 'C[1,1]', 'E[1,1]','MZ.BageTH[1,1]','MZ.BsexTH[1,1]') )
AceModel <- mxModel( "ACE", pars, varL, modelMZ, modelDZ, minus2ll, obj, Conf)
# 5) RUN AceModel
AceFit <- mxRun(AceModel, intervals=TRUE)
(AceSum <- summary(AceFit,verbose=TRUE))
mxEval(MZ.expThre, AceFit)
round(AceFit@output$estimate,4)
round(c(AceFit$A$result,AceFit$C$result,AceFit$E$result),2)
comparison=mxCompare(SatFit, AceFit)
AceFit@intervals
AceSum$CIdetail
(AceSum$CI)
setwd("../results")
save.image(file="liab_threshold_NSSH_cov_25_Dec_2019.RData")Based on the script above, results for constrained correlation model for NSSH:
Sub3summ<-summary(Sub3Fit) # NSSH univariate concor model
Sub3summ$CI## lbound estimate ubound note
## MZ.expCorMZ[2,1] 0.475580026 0.54322254 0.60452431
## DZ.expCorDZ[2,1] 0.198675200 0.27187145 0.34239605
## MZ.BageTH[1,1] 0.002076626 0.03538576 0.06872407
## MZ.BsexTH[1,1] 0.334029326 0.39628913 0.45881734Results for ACE model for NSSH:
Acesumm<-summary(AceFit,verbose=TRUE) # NSSH univariate ACE model
Acesumm$CI## lbound estimate ubound note
## ACE.A[1,1] 0.349685156 0.5427077084 0.60024198
## ACE.C[1,1] NA 0.0005168836 0.15529702 !!!
## ACE.E[1,1] 0.399758588 0.4567755055 0.52442368
## MZ.BageTH[1,1] 0.002079556 0.0353858090 0.06872304
## MZ.BsexTH[1,1] 0.334032621 0.3962887941 0.45881746Acesumm$CIdetail[,1:3] #details for CI with !!## parameter side value
## 1 ACE.A[1,1] lower 0.3496851562
## 2 ACE.A[1,1] upper 0.6002419833
## 3 ACE.C[1,1] lower 0.0003233958
## 4 ACE.C[1,1] upper 0.1552970189
## 5 ACE.E[1,1] lower 0.3997585884
## 6 ACE.E[1,1] upper 0.5244236752
## 7 MZ.BageTH[1,1] lower 0.0020795561
## 8 MZ.BageTH[1,1] upper 0.0687230447
## 9 MZ.BsexTH[1,1] lower 0.3340326206
## 10 MZ.BsexTH[1,1] upper 0.4588174643Univariate model for SSH
Full script:
rm(list=ls())
require(OpenMx);require(psych);require(foreign);require(tidyverse)
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>%
filter(!is.na(u1cslfh021)|!is.na(u1cslfh022))%>% #no missing data for self-harm
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh041,u1cslfh042, x3zygos,sexzyg,u1cage1,u1cage2,sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric)
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021,useNA="always")
table(self_harm_data_c$u1cslfh022,useNA="always")
table(self_harm_data_c$u1cslfh041,useNA="always")
table(self_harm_data_c$u1cslfh042,useNA="always")
table(self_harm_data_c$SSH1,useNA="always")
table(self_harm_data_c$SSH2,useNA="always")
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
names (self_harm_data_c)
summary(self_harm_data_c)
describe(self_harm_data_c)
str(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
dim(self_harm_data_c)
nv <- 1 # number of variables per twin
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
selVars <- c('SSH1' , 'SSH2')
useVars<- c('SSH1' , 'SSH2',"sex1","sex2",'u1cage1', 'u1cage2')
table(self_harm_data_c$sex1,useNA='always')
# Select Data for Analysis
#x3zygos 1 = MZ, not 1 = DZ twins
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(u1cage1|u1cage2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(u1cage1|u1cage2), useVars)
table(mzData$SSH1)
dim(mzData)
dim(dzData)
head(mzData);head(dzData)
describe(mzData)
describe(dzData)
# get CT for Ordinal variable
table(mzData$SSH1, mzData$SSH2)
table(dzData$SSH1, dzData$SSH2)
#fill in missing ages using proxy, creating new age variable "age"
mzData <- mutate(mzData, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
mzData <- mutate(mzData, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
dzData <- mutate(dzData, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
dzData <- mutate(dzData, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
# 1) Specify Saturated Model (Tetrachoric correlations)
# Matrix & Algebra for the covariates, expected means (SND), Thresholds and correlation etc
#covariates as definition variables
obs1 <-mxMatrix(type="Full", nrow=1, ncol=2, free=F,labels=c("data.age1","data.age2"), name="age" )
obs2 <-mxMatrix(type="Full", nrow=1, ncol=2, free=F,labels=c("data.sex1","data.sex2"), name="sex" )
#mean
MeanL <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="M" )
#the covariates - age and sex
betaA <-mxMatrix( type="Full", nrow=nth, ncol=1, free=TRUE, values=.05,
labels=c("BaTH"), name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=1, free=TRUE, values=.05,
labels=c("BsTH"), name="BsexTH" )
# lower matrix
Inc <-mxMatrix( type="Lower", nrow=nth, ncol=nth, free=FALSE, values=1, name="L" )
#thresholds
Tmz <-mxMatrix(type="Full", nrow=nth, ncol=ntv, free=TRUE, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05), lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1),
labels=c("Tmz11","imz11","imz21","imz31", "Tmz12","imz12","imz22","imz32"), name="ThMZ" )
ThreMZ <-mxAlgebra( expression= L %*% ThMZ+ BageTH%x%age + BsexTH%x%sex, name="expThreMZ" )
Tdz <-mxMatrix(type="Full", nrow=nth, ncol=ntv, free=TRUE, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05), lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1),
labels=c("Tdz11","idz11","idz21","idz31", "Tdz12","idz12","idz22","idz32"), name="ThDZ" )
ThreDZ <-mxAlgebra( expression= L %*% ThDZ+ BageTH%x%age + BsexTH%x%sex, name="expThreDZ" )
#correlations
CorMZ <-mxMatrix(type="Stand", nrow=ntv, ncol=ntv, free=T, values=.6, lbound=-.999, ubound=.999, name="expCorMZ")
CorDZ <-mxMatrix(type="Stand", nrow=ntv, ncol=ntv, free=T, values=.3, lbound=-.999, ubound=.999, name="expCorDZ")
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="expCorMZ", means="M", dimnames=selVars, thresholds="expThreMZ" )
objDZ <- mxExpectationNormal( covariance="expCorDZ", means="M", dimnames=selVars, thresholds="expThreDZ" )
fitFunction <- mxFitFunctionML()
# Combine Groups
modelMZ <- mxModel( MeanL, obs1, obs2, betaA, betaS ,Inc, Tmz, ThreMZ, CorMZ, dataMZ, objMZ, fitFunction, name="MZ" )
modelDZ <- mxModel( MeanL, obs1, obs2, betaA, betaS ,Inc, Tdz, ThreDZ, CorDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
Conf <- mxCI (c ('MZ.expCorMZ[2,1]', 'DZ.expCorDZ[2,1]','MZ.BageTH[1,1]','MZ.BsexTH[1,1]') )
SatModel <- mxModel( "Sat", modelMZ, modelDZ, minus2ll, obj, Conf )
# 1) RUN Saturated Model (Tetrachoric correlations)
SatFit <- mxRun( SatModel,intervals=F)
(SatSum <- summary(SatFit))
SatFit$output
# Generate SatModel Output
round(SatFit@output$estimate,4)
SatFit$MZ$expCorMZ
SatFit$DZ$expCorDZ
mxEval(MZ.expThreMZ, SatFit)
mxEval(MZ.expCorMZ, SatFit)
mxEval(DZ.expThreDZ, SatFit)
mxEval(DZ.expCorDZ, SatFit)
# 2) Specify and Run Sub1Model: equating Thresholds across Twin 1 and Twin 2 within MZ group
# Note: omxSetParameters: function to modify the attributes of parameters in a model
# without having to re-specify the model
Sub1Model <- mxModel(SatModel, name="sub1")
Sub1Model <- omxSetParameters(Sub1Model, labels=c("Tmz11","imz11","imz21","imz31", "Tmz12","imz12","imz22","imz32"),
newlabels=c("Tmz11","imz11","imz21","imz31", "Tmz11","imz11","imz21","imz31"), free=T, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05),
lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1))
Sub1Fit <- mxRun( Sub1Model,intervals=TRUE)
(Sub1Sum <- summary(Sub1Fit))
mxCompare(SatFit, Sub1Fit)
# Generate Sub1Model Output
round(Sub1Fit@output$estimate,4)
Sub1Fit$MZ$expCorMZ
Sub1Fit$DZ$expCorDZ
mxEval(MZ.expThreMZ, Sub1Fit)
mxEval(MZ.expCorMZ, Sub1Fit)
mxEval(DZ.expThreDZ, Sub1Fit)
mxEval(DZ.expCorDZ, Sub1Fit)
# 3) Specify and Run Sub2Model: equating Thresholds across Twin 1 and Twin 2 within DZ group
Sub2Model <- mxModel(SatModel, name="sub2")
Sub2Model <- omxSetParameters(Sub2Model, labels=c("Tdz11","idz11","idz21","idz31", "Tdz12","idz12","idz22","idz32"),
newlabels=c("Tdz11","idz11","idz21","idz31", "Tdz11","idz11","idz21","idz31"), free=T, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05),
lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1))
Sub2Fit <- mxRun( Sub2Model, intervals=TRUE)
(Sub2Sum <- summary(Sub2Fit))
mxCompare(SatFit, Sub2Fit)
# Generate Sub2Model Output
round(Sub2Fit@output$estimate,4)
Sub2Fit$MZ$expCorMZ
Sub2Fit$DZ$expCorDZ
mxEval(MZ.expThreMZ, Sub2Fit)
mxEval(MZ.expCorMZ, Sub2Fit)
mxEval(DZ.expThreDZ, Sub2Fit)
mxEval(DZ.expCorDZ, Sub2Fit)
# 4) Specify and Run Sub3Model: equating Thresholds across Twin 1 and Twin 2 and zygosity groups
Sub3Model <- mxModel(Sub1Model, name="sub3")
Sub3Model <- omxSetParameters(Sub3Model, labels=c("Tdz11","idz11","idz21","idz31", "Tdz12","idz12","idz22","idz32"),
newlabels=c("Tmz11","imz11","imz21","imz31", "Tmz11","imz11","imz21","imz31"), free=T, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05),
lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1))
Sub3Fit <- mxRun(Sub3Model, intervals=TRUE)
(Sub3Sum <- summary(Sub3Fit, verbose=T))
# Generate Sub3Model Output
round(Sub3Fit@output$estimate,4)
Sub3Fit$MZ$expCorMZ
Sub3Fit$DZ$expCorDZ
mxEval(MZ.expThreMZ, Sub3Fit)
mxEval(MZ.expCorMZ, Sub3Fit)
mxEval(DZ.expThreDZ, Sub3Fit)
mxEval(DZ.expCorDZ, Sub3Fit)
# *********************************************************************
# Print Comparative Fit Statistics for Saturated and all sub Models
(SatNested.fit <- rbind(
mxCompare(SatFit, Sub1Fit),
mxCompare(SatFit, Sub2Fit)[2,],
mxCompare(SatFit, Sub3Fit)[2,] ) )
## Sub3Fit is a good enough fit! p>0.05
# 5) Specify ACE Model, with ONE overall set of Thresholds
# Note: There is a constraint on the total variances to be unity
#define definition variables
obs1 <-mxMatrix(type="Full", nrow=1, ncol=2, free=F,labels=c("data.age1","data.age2"), name="age" )
obs2 <-mxMatrix(type="Full", nrow=1, ncol=2, free=F,labels=c("data.sex1","data.sex2"), name="sex" )
# Matrices declared to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Full", nrow=1, ncol=1, free=TRUE, values=.6, label="a11", name="a" )
pathC <- mxMatrix( type="Full", nrow=1, ncol=1, free=TRUE, values=.6, label="c11", name="c" )
pathE <- mxMatrix( type="Full", nrow=1, ncol=1, free=TRUE, values=.6, label="e11", name="e" )
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
covP <- mxAlgebra( expression=A+C+E, name="V" )
# Matrix & Algebra for expected means vector and expected thresholds
meanL <- mxMatrix( type="Zero", nrow=1, ncol=ntv, name="M" )
Inc <- mxMatrix( type="Lower", nrow=nth, ncol=nth, free=FALSE, values=1, name="L" )
#covariates
betaA <-mxMatrix( type="Full", nrow=nth, ncol=1, free=TRUE, values=.05,
labels=c("BaTH"), name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=1, free=TRUE, values=.05,
labels=c("BsTH"), name="BsexTH" )
Threshold <-mxMatrix(type="Full", nrow=nth, ncol=ntv, free=TRUE, values=c(0.5,0.05,0.05,0.05,0.5,0.05,0.05,0.05),
lbound=c(-4,.001,.001,.001,-4,.001,.001,.001), ubound=c(4,1,1,1,4,1,1,1),
labels=c("T11","i11","i21","i31", "T11","i11","i21","i31"), name="Th" )
Thre <-mxAlgebra( expression= L %*% Th + BageTH%x%age + BsexTH%x%sex, name="expThre" )
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="expCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="expCovDZ" )
# Constraint on total variance of Ordinal variables (A+C+E=1)
matUnv <- mxMatrix( type="Unit", nrow=nv, ncol=1, name="Unv" )
varL <- mxConstraint( expression=diag2vec(V)==Unv, name="VarL" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="expCovMZ", means="M", dimnames=selVars, thresholds="expThre" )
objDZ <- mxExpectationNormal( covariance="expCovDZ", means="M", dimnames=selVars, thresholds="expThre" )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, matUnv )
modelMZ <- mxModel( pars, meanL, obs1, obs2, betaA, betaS ,Inc, Threshold, Thre, covMZ, dataMZ, objMZ, fitFunction, name="MZ" )
modelDZ <- mxModel( pars, meanL, obs1, obs2, betaA, betaS ,Inc, Threshold, Thre, covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll<- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
Conf <- mxCI (c ('A[1,1]', 'C[1,1]', 'E[1,1]','MZ.BageTH[1,1]','MZ.BsexTH[1,1]') )
AceModel <- mxModel( "ACE", pars, varL, modelMZ, modelDZ, minus2ll, obj, Conf)
# 5) RUN AceModel
AceFit <- mxRun(AceModel, intervals=T)
(AceSum <- summary(AceFit,verbose=TRUE))
round(AceFit@output$estimate,4)
round(c(AceFit$A$result,AceFit$C$result,AceFit$E$result),2)
comparison=mxCompare(SatFit, AceFit)
comparison2=mxCompare(SatFit,Sub3Fit)
AceFit@intervals
AceSum$CIdetail
(AceSum$CI)
setwd("../results")
save.image(file="liab_threshold_SSH_cov_25_Dec_2019.RData")Based on the script above,
Results for the constrained correlation model for SSH
Sub3summ<-summary(Sub3Fit) #SSH univariate concor model
Sub3summ$CI## lbound estimate ubound note
## MZ.expCorMZ[2,1] 0.38929238 0.49459145 0.58706209
## DZ.expCorDZ[2,1] 0.13310279 0.23830670 0.33914045
## MZ.BageTH[1,1] -0.01742713 0.02210298 0.06168909
## MZ.BsexTH[1,1] 0.18215500 0.25739695 0.33324275Results for ACE model for SSH
Acesumm<-summary(AceFit,verbose=TRUE) #SSH univariate ACE model
Acesumm$CI## lbound estimate ubound note
## ACE.A[1,1] 0.22349085 4.912699e-01 0.57709059
## ACE.C[1,1] NA 8.088777e-14 0.20764986 !!!
## ACE.E[1,1] 0.42290963 5.087301e-01 0.60309600
## MZ.BageTH[1,1] -0.01745582 2.209174e-02 0.06169605
## MZ.BsexTH[1,1] 0.18210316 2.573047e-01 0.33309804Acesumm$CIdetail[,1:3]## parameter side value
## 1 ACE.A[1,1] lower 2.234909e-01
## 2 ACE.A[1,1] upper 5.770906e-01
## 3 ACE.C[1,1] lower 5.628663e-05
## 4 ACE.C[1,1] upper 2.076499e-01
## 5 ACE.E[1,1] lower 4.229096e-01
## 6 ACE.E[1,1] upper 6.030960e-01
## 7 MZ.BageTH[1,1] lower -1.745582e-02
## 8 MZ.BageTH[1,1] upper 6.169605e-02
## 9 MZ.BsexTH[1,1] lower 1.821032e-01
## 10 MZ.BsexTH[1,1] upper 3.330980e-01Bivariate model
Bivariate constrained correlation model
Constraints applied whereby the within-twin correlations and the liability thresholds are the same across birth order and zygosity.
We used the constrained correlational model to derive the phenotypic correlation and cross-twin cross-trait correlation between NSSH and SSH.
Script for the bivariate constrained correlation model:
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,x3zygos,u1cage1,u1cage2,sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
prop.table(table(self_harm_data_c$sex1))
sum(table(self_harm_data_c$sex1, self_harm_data_c$u1cslfh021)[1,])/sum(table(self_harm_data_c$sex1, self_harm_data_c$u1cslfh021))
#proportion of females: 62.4%
vars <-c('NSSH','SSH')
selVars <-c('NSSH1', 'SSH1', 'NSSH2', 'SSH2' )
useVars <-c('NSSH1', 'SSH1', 'NSSH2', 'SSH2' , 'u1cage1', 'u1cage2', 'sex1','sex2')
# Select Data for Analysis
selfharmdata_subset<-subset(self_harm_data_c, !is.na(x3zygos)&!is.na(u1cage1|u1cage2) &!is.na(sex1&sex2), useVars)
dim(selfharmdata_subset)
sum(table(selfharmdata_subset$NSSH1)); sum(table(selfharmdata_subset$SSH2))
table(selfharmdata_subset$NSSH1,useNA="always")
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(u1cage1|u1cage2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(u1cage1|u1cage2) &!is.na(sex1&sex2), useVars)
mzData <- mutate(mzData, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
mzData <- mutate(mzData, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
dzData <- mutate(dzData, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
dzData <- mutate(dzData, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
describe(mzData)
describe(dzData)
# To get the CTs for NSSH
table(mzData$NSSH1, mzData$NSSH2)
table(dzData$NSSH1, dzData$NSSH2)
# To get the CTs for SSH
table(mzData$SSH1, mzData$SSH2)
table(dzData$SSH1, dzData$SSH2)
nv <- 2 # number of variables per twin
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
# 1) Fits a constrained Polychoric correlation model
# TH same across twins and across zyg groups
# Age effect is different acros variables, but same across thresholds within variables (if c>2)
# There is one overall rPH between var1-2 and the x-trait x-twin correlations are symmetric
# CREATE LABELS & START VALUES as objects(to ease specification)
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a twin individual (mz)
LabCorMZ <-c('r21','rMZ1','MZxtxt','MZxtxt','rMZ2','r21')
LabThDZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a twin individual (mz)
LabCorDZ <-c('r21','rDZ1','DZxtxt','DZxtxt','rDZ2','r21')
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
ThPat <-c(T,T,T,T)
StCorMZ <-c(.5, .4, .25, .25, .20, .5)
StCorDZ <-c(.5, .1, .15, .15, .10, .5)
StTH <-c(0.1,0.01,0.01,0.01)
#
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#
#
# Matrix & Algebra for expected means (SND), Thresholds, effect of Age on Th and correlations
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="M" )
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T, values=.2, labels=LabCovS, name="BsexTH" )
Tmz <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=ThPat, values=StTH, lbound=c(-4,-4), ubound=c(4,4),
labels=LabThMZ, name="ThMZ")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
ThresMZ <-mxAlgebra( expression= cbind(Low%*%ThMZ + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%ThMZ + BageTH%x%Age2 + BsexTH%x%Sex2),
name="expThresMZ")
CorMZ <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=StCorMZ, labels=LabCorMZ, lbound=-.99, ubound=.99,
name="expCorMZ")
Tdz <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=ThPat, values=StTH, lbound=c(-4,-4), ubound=c(4,4),
labels=LabThDZ, name="ThDZ")
ThresDZ <-mxAlgebra( expression= cbind(Low%*%ThDZ + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%ThDZ + BageTH%x%Age2 + BsexTH%x%Sex2),
name="expThresDZ")
CorDZ <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=StCorDZ, labels=LabCorDZ, lbound=-.99, ubound=.99,
name="expCorDZ")
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="expCorMZ", means="M", dimnames=selVars, thresholds="expThresMZ" )
objDZ <- mxExpectationNormal( covariance="expCorDZ", means="M", dimnames=selVars, thresholds="expThresDZ" )
fitFunction <- mxFitFunctionML()
# Combine Groups
modelMZ <- mxModel( obsAge1, obsAge2, obsSex1, obsSex2, Mean, betaA, betaS, Tmz, inc, ThresMZ, CorMZ, dataMZ, objMZ, fitFunction, name="MZ" )
modelDZ <- mxModel( obsAge1, obsAge2, obsSex1, obsSex2, Mean, betaA, betaS, Tdz, inc, ThresDZ, CorDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
Conf1 <- mxCI (c ('MZ.expCorMZ','DZ.expCorDZ') )
Conf2 <- mxCI(c('MZ.BageTH','MZ.BsexTH'))
SatModel <- mxModel( "Sat", modelMZ, modelDZ, minus2ll, obj, Conf1, Conf2 )
# 1) RUN Saturated Model
SatFit <- mxTryHardOrdinal(SatModel, intervals=T)
summary<-(SatSumm <- summary(SatFit,verbose=T));summaryResults of bivariate constrained correlation model. The cross-twin and cross-twin cross-trait correlations are presented in Table S1:
SatSumm <- summary(SatFit,verbose=T)
SatSumm$CI
## lbound estimate ubound note
## r21 0.857873936 0.87171340 0.88433833
## rMZ1 0.485710368 0.55170787 0.61165972
## MZxtxt 0.423093710 0.49186840 0.55460937
## rMZ2 0.414349785 0.50686245 0.59034596
## rDZ1 0.200112240 0.27359131 0.34402180
## DZxtxt 0.177558984 0.24900658 0.31808443
## rDZ2 0.120780350 0.21587485 0.31008366
## BageThNSSH 0.002802471 0.03601269 0.06919654
## BageThSSH -0.025919889 0.01191569 0.04041692
## BsexThNSSH NA 0.40102636 0.46336563 !!!
## BsexThSSH 0.195487426 0.26709746 0.33925738
# Generate SatModel Output
round(SatFit@output$estimate,4)
## BageThNSSH BageThSSH BsexThNSSH BsexThSSH Tmz_11 imz_11 imz_12
## 0.0360 0.0119 0.4010 0.2671 -0.1599 0.4480 0.1888
## imz_13 Tmz_21 imz_21 imz_22 imz_23 r21 rMZ1
## 0.1517 0.8986 0.5485 0.2471 0.1597 0.8717 0.5517
## MZxtxt rMZ2 rDZ1 DZxtxt rDZ2
## 0.4919 0.5069 0.2736 0.2490 0.2159Bivariate ACE model
We fitted the bivariate ACE model using Cholesky decomposition, which is then transformed into a correlated factors model.
Unconstrained bivariate ACE model
Script for the unconstrained bivariate ACE model, after running the constrained correlation model:
# 2) Specify ACE Model, with ONE overall set of Thresholds with Age and Sex effects on thresholds
# CREATE LABELS for Cholesky decomposition with a function
laLower <- function(la,nv) { paste(la,rev(nv+1-sequence(1:nv)),rep(1:nv,nv:1),sep="_") }
LabTh <-c('T_11','i_11','i_21','i_31','T_22','i_12','i_22','i_32')
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH', 'BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
ThPat <-c(T,T,T,T,T,T,T,T)
StTH <-c(0.02,0.44,0.19,0.15,1.00, 0.55, 0.25, 0.16)
# Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
# Matrix & Algebra for expected means (SND), Thresholds, effect of Age on Th and correlations
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="M" )
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T, values=c(0.03,0.03,0.03,0.03,0.008,0.008,0.008,0.008), labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T, values=c(0.40,0.40,0.40,0.40,0.30,0.30,0.30,0.30), labels=LabCovS, name="BsexTH" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=ThPat, values=StTH, labels=LabTh,
lbound=c(-4,-4,-4,-4), ubound=c(4,4,4,4), name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1, Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="expThres")
# Matrices declared to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(.7,.6,.1), label=laLower("a",nv), name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(.0001,.0001,.0001), label=laLower("c",nv), name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(.6,.5,.4), label=laLower("e",nv), name="e" )
# Matrices generated to hold A, C, and E components and total Variance
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
covP <- mxAlgebra( expression=A+C+E, name="V" )
# Algebra to compute standardized variance components
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[1,1], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[2,2], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[1,1], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[2,2], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[1,1], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[2,2], name="SSH_e")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Algebra to compute Rph-A, Rph-C & Rph-E between SSH and NSSH
rphace<- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE" )
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="expCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="expCovDZ" )
# Constraint on total variance of Ordinal variables (A+C+E=1)
mUnv <- mxMatrix( type="Unit", nrow=nv, ncol=1, name="Unv" )
varL <- mxConstraint( expression=diag2vec(V)==Unv, name="VarL" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="expCovMZ", means="M", dimnames=selVars, thresholds="expThres" )
objDZ <- mxExpectationNormal( covariance="expCovDZ", means="M", dimnames=selVars, thresholds="expThres" )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list(pathA, pathC, pathE,covA, covC, covE, covP,
StA, StC, StE, matI, rph, rA, rC, rE, rphace,
obsAge1, obsAge2, obsSex1, obsSex2, Mean, betaA, betaS, Tr, Thres,
inc, mUnv, varL
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2)
modelMZ <- mxModel( pars, covMZ, dataMZ, objMZ, fitFunction, name="MZ" ) #varL only for MZ twins
modelDZ <- mxModel( pars, covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
Conf1 <- mxCI (c ('MZ.h2[1,1]', 'MZ.h2[2,2]', 'MZ.c2[1,1]', 'MZ.c2[2,2]', 'MZ.e2[1,1]', 'MZ.e2[2,2]') )
Conf2 <- mxCI (c ('MZ.Rph[2,1]', 'MZ.Ra[2,1]', 'MZ.Rc[2,1]', 'MZ.Re[2,1]') )
Conf3 <- mxCI (c ('MZ.RphACE[1,1]', 'MZ.RphACE[1,2]', 'MZ.RphACE[1,3]') )
Conf4 <- mxCI (c('MZ.BageTH','MZ.BsexTH'))
AceModel <- mxModel( "ACE", modelMZ, modelDZ,minus2ll, obj, Conf1, Conf2, Conf3, Conf4)
# 4) RUN AceModel
AceFit <- mxTryHardOrdinal(AceModel, intervals=T)Results of the unconstrained bivariate model are represented in Figure 1
AceSumm <- summary(AceFit,verbose=TRUE) # summary of results
AceSumm$CI ## lbound estimate ubound note
## MZ.h2[1,1] 0.365911640 5.512456e-01 0.60728279
## MZ.h2[2,2] 0.298445577 4.953580e-01 0.57411890
## MZ.c2[1,1] NA 4.017441e-05 0.14934530 !!!
## MZ.c2[2,2] NA 4.766445e-05 0.15977685 !!!
## MZ.e2[1,1] 0.392682298 4.487142e-01 0.51405530
## MZ.e2[2,2] 0.425983863 5.045944e-01 0.59285937
## MZ.Rph[2,1] 0.857760255 8.715993e-01 0.88429987
## MZ.Ra[2,1] 0.888127959 9.415333e-01 1.00000000
## MZ.Rc[2,1] -1.000000000 9.945385e-01 NA !!!
## MZ.Re[2,1] 0.745281398 7.976567e-01 0.84315934
## MZ.RphACE[1,1] 0.316929614 4.920031e-01 0.55041981
## MZ.RphACE[1,2] -0.015008381 4.352048e-05 0.13782449
## MZ.RphACE[1,3] 0.322748848 3.795527e-01 0.44575515
## BageThNSSH -0.005381187 2.840035e-02 0.06165628
## BageThSSH -0.028848071 7.335219e-03 0.04549574
## BsexThNSSH 0.340127383 4.021614e-01 0.46445768
## BsexThSSH 0.195724135 2.672927e-01 0.33926390# for CI with "!!!", the CIs are in AceSumm$CIdetail
AceSumm$CIdetail[,1:3]## parameter side value
## 1 MZ.h2[1,1] lower 3.659116e-01
## 2 MZ.h2[1,1] upper 6.072828e-01
## 3 MZ.h2[2,2] lower 2.984456e-01
## 4 MZ.h2[2,2] upper 5.741189e-01
## 5 MZ.c2[1,1] lower 3.538302e-34
## 6 MZ.c2[1,1] upper 1.493453e-01
## 7 MZ.c2[2,2] lower 1.444403e-32
## 8 MZ.c2[2,2] upper 1.597769e-01
## 9 MZ.e2[1,1] lower 3.926823e-01
## 10 MZ.e2[1,1] upper 5.140553e-01
## 11 MZ.e2[2,2] lower 4.259839e-01
## 12 MZ.e2[2,2] upper 5.928594e-01
## 13 MZ.Rph[2,1] lower 8.577603e-01
## 14 MZ.Rph[2,1] upper 8.842999e-01
## 15 MZ.Ra[2,1] lower 8.881280e-01
## 16 MZ.Ra[2,1] upper 1.000000e+00
## 17 MZ.Rc[2,1] lower -1.000000e+00
## 18 MZ.Rc[2,1] upper 1.000000e+00
## 19 MZ.Re[2,1] lower 7.452814e-01
## 20 MZ.Re[2,1] upper 8.431593e-01
## 21 MZ.RphACE[1,1] lower 3.169296e-01
## 22 MZ.RphACE[1,1] upper 5.504198e-01
## 23 MZ.RphACE[1,2] lower -1.500838e-02
## 24 MZ.RphACE[1,2] upper 1.378245e-01
## 25 MZ.RphACE[1,3] lower 3.227488e-01
## 26 MZ.RphACE[1,3] upper 4.457552e-01
## 27 BageThNSSH lower -5.381187e-03
## 28 BageThNSSH upper 6.165628e-02
## 29 BageThSSH lower -2.884807e-02
## 30 BageThSSH upper 4.549574e-02
## 31 BsexThNSSH lower 3.401274e-01
## 32 BsexThNSSH upper 4.644577e-01
## 33 BsexThSSH lower 1.957241e-01
## 34 BsexThSSH upper 3.392639e-01mxEval(MZ.h2,AceFit) # Heritability## [,1] [,2]
## [1,] 0.5512456 0.5644831
## [2,] 0.5644831 0.4953580mxEval(DZ.h2,AceFit) # shared E## [,1] [,2]
## [1,] 0.5512456 0.5644831
## [2,] 0.5644831 0.4953580mxEval(MZ.c2,AceFit) # Non-shared E## [,1] [,2]
## [1,] 4.017441e-05 4.993175e-05
## [2,] 4.993175e-05 4.766445e-05mxEval(MZ.Ra,AceFit) # Genetic correlation## [,1] [,2]
## [1,] 1.0000000 0.9415333
## [2,] 0.9415333 1.0000000mxEval(MZ.RphACE,AceFit)[1]/sum(mxEval(MZ.RphACE,AceFit)) #proportion of phenotypic correlation explained by genetic factors## [1] 0.5644831mxEval(MZ.Re,AceFit) # Non-shared E correlation## [,1] [,2]
## [1,] 1.0000000 0.7976567
## [2,] 0.7976567 1.0000000mxEval(MZ.RphACE,AceFit)[3]/sum(mxEval(MZ.RphACE,AceFit)) #proportion of phenotypic correlation explained by non-shared E factors## [1] 0.435467Constrained bivariate ACE model
We constrained the a,c, and e paths of NSSH and SSH to be the same, and tested if this constrained model is significantly worse than the unconstrained model.
Script for constrained bivariate ACE model:
# 4) RUN constrained AceModel, constraining NSSH and SSH to have the same aetiology among the MZ twins.
Sub1Model <- mxModel(AceModel, name="sub1",
mxConstraint(MZ.NSSH_a==MZ.SSH_a, name="con1"),
mxConstraint(MZ.NSSH_c==MZ.SSH_c, name="con2"),
mxConstraint(MZ.NSSH_e==MZ.SSH_e, name="con3"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = T)
#save the output
setwd("../results")
save.image(file="Biv_LT_NSSH_SSH_ordinal_SLSQP_sat_ACE_constrained_with_comparisons_30_April_2020.RData")Results of the goodness of fit test is in Table S4:
mxCompare(AceFit,Sub1Fit) #is Sub1Fit a significantly worse fit? ## base comparison ep minus2LL df AIC diffLL diffdf p
## 1 ACE <NA> 21 18857.03 18109 -17360.97 NA NA NA
## 2 ACE sub1 21 18859.55 18112 -17364.45 2.521106 3 0.4714889Sex limitation model
We tested for quantitative sex differences in the aetiologies for NSSH and SSH Results of sex differences analyses are in Note S2, Table S4 and Table S6
Sex limitation model for NSSH
Constrained correlation across zygosity and sex model for NSSH
We firstly ran a constrained correlation model to obtain the cross-twin correlations for twins of different zygosity and sex (MZ males, MZ females, DZ males, DZ females and DZ opposite sex)
# MODEL 1: Constrained Correlation Model
# One threshold for males, one threshold for females (i.e. within sex, the threshold is equated across twin order and zygosity group)
# Matrix for expected Means/Threshold
# Define definition variables to hold the Covariates (Age on TH of categorical variables
Obs1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Def1")
Obs2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Def2")
# Matrix & Algebra for expected means (SND), Thresholds, effect of Age on Th
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="expM" )
Betam <-mxMatrix( type="Full", nrow=1, ncol=1, free=T, labels=c('Bm1'), values=0.02, name="BetaM" )
Betaf <-mxMatrix( type="Full", nrow=1, ncol=1, free=T, labels=c('Bf1'), values=0.01, name="BetaF" )
TrM <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T,
values=c(0.69,1.10,1.30,1.50), labels=c('THm1','THm2','THm3','THm4'),
lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4,4,4), name="Thm")
TrF <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T,
values=c(0.22,0.60,0.80,1.00), labels=c('THf1','THf2','THf3','THf4'),
lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4,4,4), name="Thf")
#Inc <-mxMatrix( type="Lower", nrow=nth, ncol=nth, free=FALSE, values=1, name="L" )
ThresM <-mxAlgebra( expression= cbind(Thm + (BetaM%x%(Def1)), Thm + (BetaM%x%(Def2))), name="expThresm")
ThresF <-mxAlgebra( expression= cbind(Thf + (BetaF%x%(Def1)), Thf + (BetaF%x%(Def2))), name="expThresf")
ThresMF <-mxAlgebra( expression= cbind(Thm + (BetaM%x%(Def1)), Thf + (BetaF%x%(Def2))), name="expThresmf")
# Matrices to store correlations
corMZM <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.6, labels=c("RMZM"), lbound=-.999, ubound=.999, name="expCovMZM")
corDZM <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.3, labels=c("RDZM"), lbound=-.999, ubound=.999, name="expCovDZM")
corMZF <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.5, labels=c("RMZF"), lbound=-.999, ubound=.999, name="expCovMZF")
corDZF <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.2, labels=c("RDZF"), lbound=-.999, ubound=.999, name="expCovDZF")
corDOS <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.7, labels=c("RDOS"), lbound=-.999, ubound=.999, name="expCovDOS")
# Data objects for Multiple Groups
dataMZM <- mxData( observed=mzmData, type="raw" )
dataDZM <- mxData( observed=dzmData, type="raw" )
dataMZF <- mxData( observed=mzfData, type="raw" )
dataDZF <- mxData( observed=dzfData, type="raw" )
dataDOS <- mxData( observed=dzoData, type="raw" )
# Objective objects for Multiple Groups
objmzm <- mxExpectationNormal( covariance="expCovMZM", means="expM", dimnames=selVars, thresholds="expThresm", threshnames=c("NSSH1","NSSH2") )
objdzm <- mxExpectationNormal( covariance="expCovDZM", means="expM", dimnames=selVars, thresholds="expThresm", threshnames=c("NSSH1","NSSH2") )
objmzf <- mxExpectationNormal( covariance="expCovMZF", means="expM", dimnames=selVars, thresholds="expThresf", threshnames=c("NSSH1","NSSH2") )
objdzf <- mxExpectationNormal( covariance="expCovDZF", means="expM", dimnames=selVars, thresholds="expThresf", threshnames=c("NSSH1","NSSH2") )
objdzo <- mxExpectationNormal( covariance="expCovDOS", means="expM", dimnames=selVars, thresholds="expThresmf", threshnames=c("NSSH1","NSSH2") )
fitFunction <- mxFitFunctionML()
# Combine Groups
parsm <- list( Obs1, Obs2, Mean, Betam, fitFunction)
parsf <- list( Obs1, Obs2, Mean, Betaf, fitFunction)
modelMZM <- mxModel(parsm, TrM, ThresM, corMZM, dataMZM, objmzm, name="MZM")
modelDZM <- mxModel(parsm, TrM, ThresM, corDZM, dataDZM, objdzm, name="DZM")
modelMZF <- mxModel(parsf, TrF, ThresF, corMZF, dataMZF, objmzf, name="MZF")
modelDZF <- mxModel(parsf, TrF, ThresF, corDZF, dataDZF, objdzf, name="DZF")
modelDOS <- mxModel(parsm, parsf, TrM, TrF, ThresMF, corDOS, dataDOS, objdzo, name="DOS")
minus2ll <- mxAlgebra(expression=MZM.objective + DZM.objective + MZF.objective + DZF.objective + DOS.objective, name="m2LL")
obj <- mxFitFunctionAlgebra("m2LL")
Conf1 <- mxCI (c ('MZM.expCovMZM[2,1]', 'MZF.expCovMZF[2,1]'))
Conf2 <- mxCI (c ('DZM.expCovDZM[2,1]', 'DZF.expCovDZF[2,1]'))
Conf3 <- mxCI (c ('DOS.expCovDOS[2,1]'))
corModel <- mxModel('cor', modelMZM, modelDZM, modelMZF, modelDZF, modelDOS, minus2ll, obj, Conf1, Conf2, Conf3)
# RUN cor Model
corFit <- mxRun(corModel, intervals=T)
corSumm <- summary(corFit)
corSumm$CI
#save the results to an Excel sheet
xlsx::write.xlsx(corSumm$CI, "descriptive_stats.xlsx", sheetName = "NSSH_cor", append = T)Results from the constrained correlation model (sex differences) for NSSH:
| Zygosity and sex | lbound | estimate | ubound |
|---|---|---|---|
| MZ male | 0.37 | 0.51 | 0.63 |
| MZ female | 0.48 | 0.56 | 0.63 |
| DZ male | 0.04 | 0.25 | 0.44 |
| DZ female | 0.24 | 0.35 | 0.45 |
| DZ opposite sex | 0.09 | 0.20 | 0.31 |
Heterogeneity model for sex in NSSH
In the heterogeneity model, males and females were allowed to have difference h2, c2 and e2 for NSSH.
Script for the heterogeneity model:
#
# MODEL 2: Quantitative sex limitation model (heterogeneity model)
# Same genetic and C factors account for (co)variances in males and females, but the magnitude of their effects is still allowed to differ across the sexes
# Male-female Ra fixed to 0.5 in DZOS group (Ra=0.5)
# Male-female Rc fixed to 1 in DZOS groups (Rc=1.0)
# Matrix for expected Means
# Define definition variables to hold the Covariates (Age on TH of categorical variables
Obs1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Def1")
Obs2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Def2")
# Matrix & Algebra for expected means (SND), Thresholds, effect of Age on Th
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="expM" )
Betam <-mxMatrix( type="Full", nrow=1, ncol=1, free=T, labels=c('Bm1'), values=0.0186, name="BetaM" )
Betaf <-mxMatrix( type="Full", nrow=1, ncol=1, free=T, labels=c('Bf1'), values=0.0375, name="BetaF" )
TrM <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T,
values=c(0.61,1.10,1.29,1.43), labels=c('THm1','THm2','THm3','THm4'),
lbound=c(-4,-4,-4,-4), ubound=c(4,4,4,4), name="Thm")
TrF <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T,
values=c(-0.19,0.23,0.42,0.59), labels=c('THf1','THf2','THf3','THf4'),
lbound=c(-4,-4,-4,-4), ubound=c(4,4,4,4), name="Thf")
ThresM <-mxAlgebra( expression= cbind(Thm + (BetaM%x%Def1), Thm + (BetaM%x%Def2)), name="expThresm")
ThresF <-mxAlgebra( expression= cbind(Thf + (BetaF%x%Def1), Thf + (BetaF%x%Def2)), name="expThresf")
ThresMF <-mxAlgebra( expression= cbind(Thm + (BetaM%x%Def1), Thf + (BetaF%x%Def2)), name="expThresmf")
# Matrices to store a, c and e Path Coefficients
pathAm <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.71), label=c("am11"), name="am")
pathCm <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.07), label=c("cm11"), name="cm")
pathEm <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.70), label=c("em11"), name="em")
pathAf <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.64), label=c("af11"), name="af")
pathCf <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.38), label=c("cf11"), name="cf")
pathEf <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.67), label=c("ef11"), name="ef")
rAmf <- mxMatrix( type="Full", nrow=nv, ncol=nv, free=F, values=.5, lbound=0, ubound=.5, name="Rao" ) # fixed to .5
rCmf <- mxMatrix( type="Full", nrow=nv, ncol=nv, free=F, values=1, lbound=0, ubound=1,name="Rco" ) # fixed to 1
# Matrices generated to hold A, and E computed Variance Components
covAm <- mxAlgebra( expression=am %*% t(am), name="Am")
covCm <- mxAlgebra( expression=cm %*% t(cm), name="Cm")
covEm <- mxAlgebra( expression=em %*% t(em), name="Em")
covAf <- mxAlgebra( expression=af %*% t(af), name="Af")
covCf <- mxAlgebra( expression=cf %*% t(cf), name="Cf")
covEf <- mxAlgebra( expression=ef %*% t(ef), name="Ef")
# Algebra to compute standardized variance components
covM <- mxAlgebra( expression=Am+Cm+Em, name="Vm")
covF <- mxAlgebra( expression=Af+Cf+Ef, name="Vf")
StAm <- mxAlgebra( expression=Am/Vm, name="hm2")
StCm <- mxAlgebra( expression=Cm/Vm, name="cm2")
StEm <- mxAlgebra( expression=Em/Vm, name="em2")
StAf <- mxAlgebra( expression=Af/Vf, name="hf2")
StCf <- mxAlgebra( expression=Cf/Vf, name="cf2")
StEf <- mxAlgebra( expression=Ef/Vf, name="ef2")
# Constraint on total variance of Ordinal variable (A+C+E=1)
varLM <- mxConstraint( expression=Vm[1,1]==1, name="VarLM" )
varLF <- mxConstraint( expression=Vf[1,1]==1, name="VarLF" )
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZM <- mxAlgebra( expression= rbind ( cbind(Am+Cm+Em, Am+Cm),
cbind(Am+Cm, Am+Cm+Em)) , name="expCovMZM")
covMZF <- mxAlgebra( expression= rbind ( cbind(Af+Cf+Ef, Af+Cf),
cbind(Af+Cf, Af+Cf+Ef)) , name="expCovMZF")
covDZM <- mxAlgebra( expression= rbind ( cbind(Am+Cm+Em, 0.5%x%Am+Cm),
cbind(0.5%x%Am+Cm, Am+Cm+Em)) , name="expCovDZM")
covDZF <- mxAlgebra( expression= rbind ( cbind(Af+Cf+Ef, 0.5%x%Af+Cf),
cbind(0.5%x%Af+Cf, Af+Cf+Ef)) , name="expCovDZF")
covDOS <- mxAlgebra( expression= rbind ( cbind(Am+Cm+Em, am%*%Rao%*%t(af) + cm%*%Rco%*%t(cf) ),
cbind(af%*%t(Rao)%*%t(am) + cf%*%t(Rco)%*%t(cm), Af+Cf+Ef) ) , name="expCovDOS")
# Data objects for Multiple Groups
dataMZM <- mxData( observed=mzmData, type="raw" )
dataDZM <- mxData( observed=dzmData, type="raw" )
dataMZF <- mxData( observed=mzfData, type="raw" )
dataDZF <- mxData( observed=dzfData, type="raw" )
dataDOS <- mxData( observed=dzoData, type="raw" )
# Objective objects for Multiple Groups
objmzm <- mxExpectationNormal( covariance="expCovMZM", means="expM", dimnames=selVars, thresholds="expThresm", threshnames=c("NSSH1","NSSH2") )
objdzm <- mxExpectationNormal( covariance="expCovDZM", means="expM", dimnames=selVars, thresholds="expThresm", threshnames=c("NSSH1","NSSH2") )
objmzf <- mxExpectationNormal( covariance="expCovMZF", means="expM", dimnames=selVars, thresholds="expThresf", threshnames=c("NSSH1","NSSH2") )
objdzf <- mxExpectationNormal( covariance="expCovDZF", means="expM", dimnames=selVars, thresholds="expThresf", threshnames=c("NSSH1","NSSH2") )
objdzo <- mxExpectationNormal( covariance="expCovDOS", means="expM", dimnames=selVars, thresholds="expThresmf", threshnames=c("NSSH1","NSSH2") )
fitFunction <- mxFitFunctionML()
# Combine Groups
parsm <- list( Obs1, Obs2, Mean, Betam, pathAm, pathCm, pathEm, covAm, covCm, covEm, covM, StAm, StCm, StEm, fitFunction )
parsf <- list( Obs1, Obs2, Mean, Betaf, pathAf, pathCf, pathEf, covAf, covCf, covEf, covF, StAf, StCf, StEf, fitFunction )
modelMZM <- mxModel(parsm, TrM, ThresM, covMZM, dataMZM, objmzm, varLM, name="MZM")
modelDZM <- mxModel(parsm, TrM, ThresM, covDZM, dataDZM, objdzm, name="DZM")
modelMZF <- mxModel(parsf, TrF, ThresF, covMZF, dataMZF, objmzf, varLF, name="MZF")
modelDZF <- mxModel(parsf, TrF, ThresF, covDZF, dataDZF, objdzf, name="DZF")
modelDOS <- mxModel(parsm, parsf, TrM, TrF, ThresMF,
rAmf, rCmf, covDOS, dataDOS, objdzo, name="DOS")
minus2ll <- mxAlgebra(expression=MZM.objective + DZM.objective + MZF.objective + DZF.objective + DOS.objective, name="m2LL")
obj <- mxFitFunctionAlgebra("m2LL")
ciM <- mxCI (c ('MZM.hm2', 'MZM.cm2', 'MZM.em2' ) ) # h2, c2, e2 males
ciF <- mxCI (c ('MZF.hf2', 'MZF.cf2', 'MZF.ef2' ) ) # h2, c2, e2 females
HetACEModel <-mxModel('HetACE', modelMZM, modelDZM, modelMZF, modelDZF, modelDOS, minus2ll, obj, ciM, ciF)
# RUN univariate ACE Model
HetACEFit <- mxTryHardOrdinal(HetACEModel, intervals=T)Results from the heterogeneity model for NSSH:
HetACESumm <- summary(HetACEFit, verbose=T)
HetACESumm$CI #show the CI## lbound estimate ubound note
## MZM.hm2[1,1] NA 0.500921211 0.6167271 !!!
## MZM.cm2[1,1] NA 0.005371819 0.3730496 !!!
## MZM.em2[1,1] 3.790635e-01 0.493706970 0.6260728
## MZF.hf2[1,1] 1.654440e-01 0.413755539 0.6126553
## MZF.cf2[1,1] 2.131622e-34 0.142030974 NA !!!
## MZF.ef2[1,1] 3.748761e-01 0.444213487 0.5225311HetACESumm$CIdetail[,1:3] # show the CI details## parameter side value
## 1 MZM.hm2[1,1] lower 3.861800e-05
## 2 MZM.hm2[1,1] upper 6.167271e-01
## 3 MZM.cm2[1,1] lower 1.779879e-30
## 4 MZM.cm2[1,1] upper 3.730496e-01
## 5 MZM.em2[1,1] lower 3.790635e-01
## 6 MZM.em2[1,1] upper 6.260728e-01
## 7 MZF.hf2[1,1] lower 1.654440e-01
## 8 MZF.hf2[1,1] upper 6.126553e-01
## 9 MZF.cf2[1,1] lower 2.131622e-34
## 10 MZF.cf2[1,1] upper 5.665264e-01
## 11 MZF.ef2[1,1] lower 3.748761e-01
## 12 MZF.ef2[1,1] upper 5.225311e-01Homogeneity model for sex in NSSH
Script for homogeneity model for sex in NSSH:
# MODEL: univ HOMOGENEITY MODEL
# NO Quantitative dif AND NO Qualitative sex Diff
# There is one set of A,C,E parameters and one set of A,C,E correlations across gender
# From the heterogeneity model (model 3), we simply use the same 'labeling' to equate male and female A, C and E paths
HomACEModel <- mxModel(HetACEFit, name="HomACE")
HomACEModel <-omxSetParameters(HomACEModel, labels=c("af11", "cf11", "ef11"), free=T, newlabels=c("am11", "cm11", "em11"), values=c(.7, .01, .4))
HomACEModel <- omxAssignFirstParameters(HomACEModel)
HomACEFit <- mxTryHardOrdinal(HomACEModel, intervals=T)Results for homogeneity model for sex in NSSH:
HomACESumm <- summary(HomACEFit,verbose=T)
HomACESumm$CI## lbound estimate ubound note
## MZM.hm2[1,1] 0.3505886 5.433484e-01 0.6003098
## MZM.cm2[1,1] NA 4.564371e-07 0.1544247 !!!
## MZM.em2[1,1] 0.3996902 4.566512e-01 0.5180843
## MZF.hf2[1,1] 0.3505886 5.433484e-01 0.6003098
## MZF.cf2[1,1] NA 4.564371e-07 0.1544247 !!!
## MZF.ef2[1,1] 0.3996902 4.566512e-01 0.5180843HomACESumm$CIdetail[,1:3]## parameter side value
## 1 MZM.hm2[1,1] lower 3.505886e-01
## 2 MZM.hm2[1,1] upper 6.003098e-01
## 3 MZM.cm2[1,1] lower 2.735922e-20
## 4 MZM.cm2[1,1] upper 1.544247e-01
## 5 MZM.em2[1,1] lower 3.996902e-01
## 6 MZM.em2[1,1] upper 5.180843e-01
## 7 MZF.hf2[1,1] lower 3.505886e-01
## 8 MZF.hf2[1,1] upper 6.003098e-01
## 9 MZF.cf2[1,1] lower 2.735922e-20
## 10 MZF.cf2[1,1] upper 1.544247e-01
## 11 MZF.ef2[1,1] lower 3.996902e-01
## 12 MZF.ef2[1,1] upper 5.180843e-01Is the homogeneity model a better fit than the heterogeneity model for NSSH?
mxCompare(HetACEFit, HomACEFit) ## base comparison ep minus2LL df AIC diffLL diffdf p
## 1 HetACE <NA> 16 13948.13 9049 -4149.867 NA NA NA
## 2 HetACE HomACE 13 13952.25 9052 -4151.751 4.115972 3 0.2492105# The answer is yesSex limitation model for SSH
Constrained correlation across zygosity and sex model for SSH
nv <- 1 # number of variables per twin
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
selVars <- c('SSH1' , 'SSH2')
useVars<- c('SSH1' , 'SSH2',"sex1","sex2",'age1', 'age2')
# Select Data for Analysis
#sexzyg 1 = MZ male, 2=DZ male, 3=MZ female, 4=DZ female, 5=DZOS
mzmData <- subset(self_harm_data_c, sexzyg==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #MZM
dzmData <- subset(self_harm_data_c, sexzyg==2 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #DZM
mzfData <- subset(self_harm_data_c, sexzyg==3 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #MZF
dzfData <- subset(self_harm_data_c, sexzyg==4 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #DZF
dzoData <- subset(self_harm_data_c, sexzyg==5 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #DZO
hetcor(mzmData$SSH1, mzmData$SSH2)$correlations #0.68
hetcor(dzoData$SSH1, dzoData$SSH2)$correlations #0.14
table(mzmData$sex1);table(mzmData$sex2) #males=1
table(dzmData$sex1);table(dzmData$sex2)
table(mzfData$sex1);table(mzfData$sex2) #females=0
table(dzfData$sex1);table(dzfData$sex2)
table(dzoData$sex1,useNA = "always");table(dzoData$sex2,useNA = "always") #total=1875
#recode twin 1 as males and twin 2 as females for dzoData:
dzoData$newSSH1=NA;dzoData$newSSH2=NA;dzoData$newsex1=NA;dzoData$newsex2=NA
table(dzoData$SSH1,useNA = "always");table(dzoData$SSH2,useNA = "always")
table(is.na(dzoData$SSH1));table(is.na(dzoData$SSH2))
table(dzoData$sex1,useNA = "always");table(dzoData$sex2,useNA = "always")
dzoData<-mutate(dzoData, newSSH1=ifelse(sex1==1,SSH1, ifelse(sex1==0,SSH2,999)))
dzoData<-mutate(dzoData, newSSH2=ifelse(sex2==0,SSH2, ifelse(sex2==1,SSH1,999)))
dzoData<-mutate(dzoData, newsex1=ifelse(sex1==1,sex1, ifelse(sex1==0,sex2,999))) #recode twin 1 as males
dzoData<-mutate(dzoData, newsex2=ifelse(sex2==0,sex2, ifelse(sex2==1,sex1,999))) #recode twin 2 as females
table(dzoData$newSSH1,dzoData$newsex1,useNA = "always")
table(dzoData$newSSH2,dzoData$newsex2,useNA = "always")
sum(table(dzoData$newSSH1,dzoData$newsex1))
sum(table(dzoData$newSSH2,dzoData$newsex2))
#minus one to get zero and to replace the values to SSH1/2
dzoData$newSSH1<-dzoData$newSSH1-1
dzoData$newSSH2<-dzoData$newSSH2-1
table(dzoData$newSSH1,dzoData$newsex1)
table(dzoData$newSSH2,dzoData$newsex2)
#check number
check<-subset(self_harm_data_c, sexzyg==5 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
table(check$SSH1,check$sex1)
#check correlation
hetcor(as.factor(dzoData$SSH1), as.factor(dzoData$SSH2)) #0.14
hetcor(as.factor(dzoData$newSSH1), as.factor(dzoData$newSSH2)) #0.16
dzoData$SSH1<-dzoData$newSSH1
dzoData$SSH2<-dzoData$newSSH2
dzoData$sex1<-dzoData$newsex1
dzoData$sex2<-dzoData$newsex2
table(dzoData$SSH1,dzoData$sex1)
table(dzoData$SSH2,dzoData$sex2)
#make them ordered factor again
dzoData$SSH1<-mxFactor(dzoData$SSH1, levels=c(0:4) )
dzoData$SSH2<-mxFactor(dzoData$SSH2, levels=c(0:4) )
psych::describe(mzmData)
psych::describe(dzmData)
psych::describe(mzfData)
psych::describe(dzfData)
psych::describe(dzoData)
# To get Contingency Tables per zygosity group (i.e. complete pairs only)
table(mzmData$SSH1, mzmData$SSH2)
table(dzmData$SSH1, dzmData$SSH2)
table(mzfData$SSH1, mzfData$SSH2)
table(dzfData$SSH1, dzfData$SSH2)
table(dzoData$SSH1, dzoData$SSH2)
hetcor(mzmData$SSH1, mzmData$SSH2)$correlations
hetcor(dzoData$SSH1, dzoData$SSH2)$correlations
# MODEL 1: Constrained Correlation Model
# One threshold for males, one threshold for females (i.e. within sex, the threshold is equated across twin order and zygosity group)
# Matrix for expected Means/Threshold
# Define definition variables to hold the Covariates (Age on TH of categorical variables
Obs1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Def1")
Obs2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Def2")
# Matrix & Algebra for expected means (SND), Thresholds, effect of Age on Th
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="expM" )
Betam <-mxMatrix( type="Full", nrow=1, ncol=1, free=T, labels=c('Bm1'), values=-0.004, name="BetaM" )
Betaf <-mxMatrix( type="Full", nrow=1, ncol=1, free=T, labels=c('Bf1'), values=0.036, name="BetaF" )
TrM <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T,
values=c(1.506,2.04,2.36,2.49), labels=c('THm1','THm2','THm3','THm4'),
lbound=-5, ubound=5, name="Thm")
TrF <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T,
values=c(0.35,0.93,1.17,1.36), labels=c('THf1','THf2','THf3','THf4'),
lbound=-5, ubound=5, name="Thf")
#Inc <-mxMatrix( type="Lower", nrow=nth, ncol=nth, free=FALSE, values=1, name="L" )
ThresM <-mxAlgebra( expression= cbind(Thm + (BetaM%x%(Def1)), Thm + (BetaM%x%(Def2))), name="expThresm")
ThresF <-mxAlgebra( expression= cbind(Thf + (BetaF%x%(Def1)), Thf + (BetaF%x%(Def2))), name="expThresf")
ThresMF <-mxAlgebra( expression= cbind(Thm + (BetaM%x%(Def1)), Thf + (BetaF%x%(Def2))), name="expThresmf")
# Matrices to store correlations
corMZM <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.70, labels=c("RMZM"), lbound=-.999, ubound=.999, name="expCovMZM")
corDZM <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.30, labels=c("RDZM"), lbound=-.999, ubound=.999, name="expCovDZM")
corMZF <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.42, labels=c("RMZF"), lbound=-.999, ubound=.999, name="expCovMZF")
corDZF <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.30, labels=c("RDZF"), lbound=-.999, ubound=.999, name="expCovDZF")
corDOS <-mxMatrix( type="Stand", nrow=ntv, ncol=ntv, free=T, values=.15, labels=c("RDOS"), lbound=-.999, ubound=.999, name="expCovDOS")
# Data objects for Multiple Groups
dataMZM <- mxData( observed=mzmData, type="raw" )
dataDZM <- mxData( observed=dzmData, type="raw" )
dataMZF <- mxData( observed=mzfData, type="raw" )
dataDZF <- mxData( observed=dzfData, type="raw" )
dataDOS <- mxData( observed=dzoData, type="raw" )
# Objective objects for Multiple Groups
objmzm <- mxExpectationNormal( covariance="expCovMZM", means="expM", dimnames=selVars, thresholds="expThresm", threshnames=c("SSH1","SSH2") )
objdzm <- mxExpectationNormal( covariance="expCovDZM", means="expM", dimnames=selVars, thresholds="expThresm", threshnames=c("SSH1","SSH2") )
objmzf <- mxExpectationNormal( covariance="expCovMZF", means="expM", dimnames=selVars, thresholds="expThresf", threshnames=c("SSH1","SSH2") )
objdzf <- mxExpectationNormal( covariance="expCovDZF", means="expM", dimnames=selVars, thresholds="expThresf", threshnames=c("SSH1","SSH2") )
objdzo <- mxExpectationNormal( covariance="expCovDOS", means="expM", dimnames=selVars, thresholds="expThresmf", threshnames=c("SSH1","SSH2") )
fitFunction <- mxFitFunctionML()
# Combine Groups
parsm <- list( Obs1, Obs2, Mean, Betam, fitFunction)
parsf <- list( Obs1, Obs2, Mean, Betaf, fitFunction)
modelMZM <- mxModel(parsm, TrM, ThresM, corMZM, dataMZM, objmzm, name="MZM")
modelDZM <- mxModel(parsm, TrM, ThresM, corDZM, dataDZM, objdzm, name="DZM")
modelMZF <- mxModel(parsf, TrF, ThresF, corMZF, dataMZF, objmzf, name="MZF")
modelDZF <- mxModel(parsf, TrF, ThresF, corDZF, dataDZF, objdzf, name="DZF")
modelDOS <- mxModel(parsm, parsf, TrM, TrF, ThresMF, corDOS, dataDOS, objdzo, name="DOS")
minus2ll <- mxAlgebra(expression=MZM.objective + DZM.objective + MZF.objective + DZF.objective + DOS.objective, name="m2LL")
obj <- mxFitFunctionAlgebra("m2LL")
Conf1 <- mxCI (c ('MZM.expCovMZM[2,1]', 'MZF.expCovMZF[2,1]'))
Conf2 <- mxCI (c ('DZM.expCovDZM[2,1]', 'DZF.expCovDZF[2,1]'))
Conf3 <- mxCI (c ('DOS.expCovDOS[2,1]'))
corModel <- mxModel('cor', modelMZM, modelDZM, modelMZF, modelDZF, modelDOS, minus2ll, obj, Conf1, Conf2, Conf3)
# RUN cor Model
corFit <- mxTryHardOrdinal(corModel, intervals=T,extraTries=20)
(corSumm <- summary(corFit))
xlsx::write.xlsx(corSumm$CI, "descriptive_stats.xlsx", sheetName = "SSH_cor", append = T)| Zygosity and sex | lbound | estimate | ubound |
|---|---|---|---|
| MZ male | 0.53 | 0.70 | 0.81 |
| MZ female | 0.28 | 0.42 | 0.53 |
| DZ male | 0.03 | 0.29 | 0.53 |
| DZ female | 0.13 | 0.28 | 0.42 |
| DZ opposite sex | 0.00 | 0.17 | 0.34 |
Heterogeneity model for sex in SSH
Script for heterogeneity model for sex in SSH:
# MODEL 2: Quantitative sex limitation model (heterogeneity model)
# Same genetic and C factors account for (co)variances in males and females, but the magnitude of their effects is still allowed to differ across the sexes
# Male-female Ra fixed to 0.5 in DZOS group (Ra=0.5)
# Male-female Rc fixed to 1 in DZOS groups (Rc=1.0)
# Matrix for expected Means
# Define definition variables to hold the Covariates (Age on TH of categorical variables
Obs1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Def1")
Obs2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Def2")
# Matrix & Algebra for expected means (SND), Thresholds, effect of Age on Th
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="expM" )
Betam <-mxMatrix( type="Full", nrow=1, ncol=1, free=T, labels=c('Bm1'), values=-0.0046, name="BetaM" )
Betaf <-mxMatrix( type="Full", nrow=1, ncol=1, free=T, labels=c('Bf1'), values=0.0364, name="BetaF" )
TrM <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T,
values=c(1.516,2.054,2.373,2.499), labels=c('THm1','THm2','THm3','THm4'),
lbound=-4, ubound=4, name="Thm")
TrF <-mxMatrix( type="Full", nrow=nth, ncol=nv, free=T,
values=c(0.351,0.928,1.170,2.356), labels=c('THf1','THf2','THf3','THf4'),
lbound=-4, ubound=4, name="Thf")
ThresM <-mxAlgebra( expression= cbind(Thm + (BetaM%x%Def1), Thm + (BetaM%x%Def2)), name="expThresm")
ThresF <-mxAlgebra( expression= cbind(Thf + (BetaF%x%Def1), Thf + (BetaF%x%Def2)), name="expThresf")
ThresMF <-mxAlgebra( expression= cbind(Thm + (BetaM%x%Def1), Thf + (BetaF%x%Def2)), name="expThresmf")
# Matrices to store a, c and e Path Coefficients
pathAm <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.825), label=c("am11"), name="am")
pathCm <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.087), label=c("cm11"), name="cm")
pathEm <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.558), label=c("em11"), name="em")
pathAf <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.508), label=c("af11"), name="af")
pathCf <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.394), label=c("cf11"), name="cf")
pathEf <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=T, values=c(.766), label=c("ef11"), name="ef")
rAmf <- mxMatrix( type="Full", nrow=nv, ncol=nv, free=F, values=.5, lbound=0, ubound=.5, name="Rao" ) # fixed to .5
rCmf <- mxMatrix( type="Full", nrow=nv, ncol=nv, free=F, values=1, lbound=0, ubound=1,name="Rco" ) # fixed to 1
# Matrices generated to hold A, and E computed Variance Components
covAm <- mxAlgebra( expression=am %*% t(am), name="Am")
covCm <- mxAlgebra( expression=cm %*% t(cm), name="Cm")
covEm <- mxAlgebra( expression=em %*% t(em), name="Em")
covAf <- mxAlgebra( expression=af %*% t(af), name="Af")
covCf <- mxAlgebra( expression=cf %*% t(cf), name="Cf")
covEf <- mxAlgebra( expression=ef %*% t(ef), name="Ef")
# Algebra to compute standardized variance components
covM <- mxAlgebra( expression=Am+Cm+Em, name="Vm")
covF <- mxAlgebra( expression=Af+Cf+Ef, name="Vf")
StAm <- mxAlgebra( expression=Am/Vm, name="hm2")
StCm <- mxAlgebra( expression=Cm/Vm, name="cm2")
StEm <- mxAlgebra( expression=Em/Vm, name="em2")
StAf <- mxAlgebra( expression=Af/Vf, name="hf2")
StCf <- mxAlgebra( expression=Cf/Vf, name="cf2")
StEf <- mxAlgebra( expression=Ef/Vf, name="ef2")
# Constraint on total variance of Ordinal variable (A+C+E=1)
varLM <- mxConstraint( expression=Vm[1,1]==1, name="VarLM" )
varLF <- mxConstraint( expression=Vf[1,1]==1, name="VarLF" )
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZM <- mxAlgebra( expression= rbind ( cbind(Am+Cm+Em, Am+Cm),
cbind(Am+Cm, Am+Cm+Em)) , name="expCovMZM")
covMZF <- mxAlgebra( expression= rbind ( cbind(Af+Cf+Ef, Af+Cf),
cbind(Af+Cf, Af+Cf+Ef)) , name="expCovMZF")
covDZM <- mxAlgebra( expression= rbind ( cbind(Am+Cm+Em, 0.5%x%Am+Cm),
cbind(0.5%x%Am+Cm, Am+Cm+Em)) , name="expCovDZM")
covDZF <- mxAlgebra( expression= rbind ( cbind(Af+Cf+Ef, 0.5%x%Af+Cf),
cbind(0.5%x%Af+Cf, Af+Cf+Ef)) , name="expCovDZF")
covDOS <- mxAlgebra( expression= rbind ( cbind(Am+Cm+Em, am%*%Rao%*%t(af) + cm%*%Rco%*%t(cf) ),
cbind(af%*%t(Rao)%*%t(am) + cf%*%t(Rco)%*%t(cm), Af+Cf+Ef) ) , name="expCovDOS")
# Data objects for Multiple Groups
dataMZM <- mxData( observed=mzmData, type="raw" )
dataDZM <- mxData( observed=dzmData, type="raw" )
dataMZF <- mxData( observed=mzfData, type="raw" )
dataDZF <- mxData( observed=dzfData, type="raw" )
dataDOS <- mxData( observed=dzoData, type="raw" )
# Objective objects for Multiple Groups
objmzm <- mxExpectationNormal( covariance="expCovMZM", means="expM", dimnames=selVars, thresholds="expThresm", threshnames=c("SSH1","SSH2") )
objdzm <- mxExpectationNormal( covariance="expCovDZM", means="expM", dimnames=selVars, thresholds="expThresm", threshnames=c("SSH1","SSH2") )
objmzf <- mxExpectationNormal( covariance="expCovMZF", means="expM", dimnames=selVars, thresholds="expThresf", threshnames=c("SSH1","SSH2") )
objdzf <- mxExpectationNormal( covariance="expCovDZF", means="expM", dimnames=selVars, thresholds="expThresf", threshnames=c("SSH1","SSH2") )
objdzo <- mxExpectationNormal( covariance="expCovDOS", means="expM", dimnames=selVars, thresholds="expThresmf", threshnames=c("SSH1","SSH2") )
fitFunction <- mxFitFunctionML()
# Combine Groups
parsm <- list( Obs1, Obs2, Mean, Betam, pathAm, pathCm, pathEm, covAm, covCm, covEm, covM, StAm, StCm, StEm, fitFunction )
parsf <- list( Obs1, Obs2, Mean, Betaf, pathAf, pathCf, pathEf, covAf, covCf, covEf, covF, StAf, StCf, StEf, fitFunction )
modelMZM <- mxModel(parsm, TrM, ThresM, covMZM, dataMZM, objmzm, varLM, name="MZM")
modelDZM <- mxModel(parsm, TrM, ThresM, covDZM, dataDZM, objdzm, name="DZM")
modelMZF <- mxModel(parsf, TrF, ThresF, covMZF, dataMZF, objmzf, varLF, name="MZF")
modelDZF <- mxModel(parsf, TrF, ThresF, covDZF, dataDZF, objdzf, name="DZF")
modelDOS <- mxModel(parsm, parsf, TrM, TrF, ThresMF,
rAmf, rCmf, covDOS, dataDOS, objdzo, name="DOS")
minus2ll <- mxAlgebra(expression=MZM.objective + DZM.objective + MZF.objective + DZF.objective + DOS.objective, name="m2LL")
obj <- mxFitFunctionAlgebra("m2LL")
ciM <- mxCI (c ('MZM.hm2', 'MZM.cm2', 'MZM.em2' ) ) # h2, c2, e2 males
ciF <- mxCI (c ('MZF.hf2', 'MZF.cf2', 'MZF.ef2' ) ) # h2, c2, e2 females
HetACEModel <-mxModel('HetACE', modelMZM, modelDZM, modelMZF, modelDZF, modelDOS, minus2ll, obj, ciM, ciF)
# RUN univariate ACE Model
HetACEFit <- mxTryHardOrdinal(HetACEModel, intervals=T)Results for heterogeneity model for sex in SSH:
HetACESumm <- summary(HetACEFit, verbose=T)
HetACESumm$CI## lbound estimate ubound note
## MZM.hm2[1,1] NA 0.500921211 0.6167271 !!!
## MZM.cm2[1,1] NA 0.005371819 0.3730496 !!!
## MZM.em2[1,1] 3.790635e-01 0.493706970 0.6260728
## MZF.hf2[1,1] 1.654440e-01 0.413755539 0.6126553
## MZF.cf2[1,1] 2.131622e-34 0.142030974 NA !!!
## MZF.ef2[1,1] 3.748761e-01 0.444213487 0.5225311HetACESumm$CIdetail[,1:3]## parameter side value
## 1 MZM.hm2[1,1] lower 3.861800e-05
## 2 MZM.hm2[1,1] upper 6.167271e-01
## 3 MZM.cm2[1,1] lower 1.779879e-30
## 4 MZM.cm2[1,1] upper 3.730496e-01
## 5 MZM.em2[1,1] lower 3.790635e-01
## 6 MZM.em2[1,1] upper 6.260728e-01
## 7 MZF.hf2[1,1] lower 1.654440e-01
## 8 MZF.hf2[1,1] upper 6.126553e-01
## 9 MZF.cf2[1,1] lower 2.131622e-34
## 10 MZF.cf2[1,1] upper 5.665264e-01
## 11 MZF.ef2[1,1] lower 3.748761e-01
## 12 MZF.ef2[1,1] upper 5.225311e-01Homogeneity model for sex in SSH
Script for homogeneity model for sex in SSH:
# MODEL 3: univ HOMOGENEITY MODEL
# NO Quantitative dif AND NO Qualitative sex Diff
# There is one set of A,C,E parameters and one set of A,C,E correlations across gender
# From the heterogeneity model (model 3), we simply use the same 'labeling' to equate male and female A, C and E paths
HomACEModel <- mxModel(HetACEFit, name="HomACE")
HomACEModel <-omxSetParameters(HomACEModel, labels=c("af11", "cf11", "ef11"), free=T, newlabels=c("am11", "cm11", "em11"), values=c(.50, .01, .49))
HomACEModel <- omxAssignFirstParameters(HomACEModel)
HomACEFit <- mxTryHardOrdinal(HomACEModel, intervals=T)Results for homogeneity model for sex in SSH:
HomACESumm <- summary(HomACEFit,verbose=T)
HomACESumm$CI## lbound estimate ubound note
## MZM.hm2[1,1] 0.2170751 4.906305e-01 0.5765491
## MZM.cm2[1,1] NA 6.271857e-10 0.2122188 !!!
## MZM.em2[1,1] 0.4234444 5.093695e-01 0.6038119
## MZF.hf2[1,1] 0.2170752 4.906305e-01 0.5765491
## MZF.cf2[1,1] NA 6.271857e-10 0.2122188 !!!
## MZF.ef2[1,1] 0.4234444 5.093695e-01 0.6038119HomACESumm$CIdetail[,1:3]## parameter side value
## 1 MZM.hm2[1,1] lower 2.170751e-01
## 2 MZM.hm2[1,1] upper 5.765491e-01
## 3 MZM.cm2[1,1] lower 1.281004e-25
## 4 MZM.cm2[1,1] upper 2.122188e-01
## 5 MZM.em2[1,1] lower 4.234444e-01
## 6 MZM.em2[1,1] upper 6.038119e-01
## 7 MZF.hf2[1,1] lower 2.170752e-01
## 8 MZF.hf2[1,1] upper 5.765491e-01
## 9 MZF.cf2[1,1] lower 1.281004e-25
## 10 MZF.cf2[1,1] upper 2.122188e-01
## 11 MZF.ef2[1,1] lower 4.234444e-01
## 12 MZF.ef2[1,1] upper 6.038119e-01Is the homogeneity model a good fit compared to the heterogeneity model for SSH?
mxCompare(HetACEFit, HomACEFit)## base comparison ep minus2LL df AIC diffLL diffdf p
## 1 HetACE <NA> 16 7829.442 9049 -10268.56 NA NA NA
## 2 HetACE HomACE 13 7837.305 9052 -10266.69 7.863871 3 0.04891047#The answer is yes, since the p-value is marginally significant, and is 0.05 if rounded off to 2 decimal places.Trivariate model
In total, we fit 24 trivariate models out of 19 mental health measures. The models were run and results were saved in RData format. Scripts used to run each model with a different mental health measure are as follow:
Others
cAUT
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhaqt1,pcbhaqt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cAUT variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescAUT1 <- residuals(lm(self_harm_data_c$pcbhaqt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescAUT2 <- residuals(lm(self_harm_data_c$pcbhaqt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhaqt1)
hist(self_harm_data_c$rescAUT1)
describe(self_harm_data_c$rescAUT1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescAUT1 <-sqrt(self_harm_data_c$rescAUT1+16)*2
self_harm_data_c$trans_rescAUT2 <-sqrt(self_harm_data_c$rescAUT2+16)*2
hist(self_harm_data_c$rescAUT1)
hist(self_harm_data_c$trans_rescAUT1)
describe(self_harm_data_c$trans_rescAUT1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescAUT1, self_harm_data_c$NSSH1)$correlations #0.20
hetcor(self_harm_data_c$pcbhaqt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.20
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cAUT','NSSH', 'SSH')
selVars <-c('trans_rescAUT1', 'NSSH1', 'SSH1', 'trans_rescAUT2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescAUT1', 'NSSH1', 'SSH1', 'trans_rescAUT2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cAUT-NSSH
rphace_cAUT_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cAUT_NSSH" )
rphace_cAUT_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cAUT_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcAUT<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cAUT")
raSSHcAUT<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cAUT")
#rC
rcNSSHcAUT<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cAUT")
rcSSHcAUT<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cAUT")
#rE
reNSSHcAUT<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cAUT")
reSSHcAUT<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cAUT")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cAUT_NSSH,rphace_cAUT_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcAUT,raSSHcAUT,rcNSSHcAUT,rcSSHcAUT,reNSSHcAUT,reSSHcAUT)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cAUT_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cAUT_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cAUT_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cAUT_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cAUT_NSSH, AceFit1),
mxEval(ACE.RphACE_cAUT_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cAUT==MZ.rA_SSH_cAUT, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cAUT==MZ.rC_SSH_cAUT, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cAUT==MZ.rE_SSH_cAUT, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cAUT_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
xlsx::write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cAUT", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cAUT", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cAUT", append=TRUE)pAUT
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,ppbhaqt1,ppbhaqt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform pAUT variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$respAUT1 <- residuals(lm(self_harm_data_c$ppbhaqt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$respAUT2 <- residuals(lm(self_harm_data_c$ppbhaqt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$ppbhaqt1)
hist(self_harm_data_c$respAUT1)
describe(self_harm_data_c$respAUT1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_respAUT1 <-sqrt(self_harm_data_c$respAUT1+36)*1.5
self_harm_data_c$trans_respAUT2 <-sqrt(self_harm_data_c$respAUT2+36)*1.5
hist(self_harm_data_c$respAUT1)
hist(self_harm_data_c$trans_respAUT1)
describe(self_harm_data_c$trans_respAUT1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_respAUT1, self_harm_data_c$NSSH1)$correlations #0.08
hetcor(self_harm_data_c$ppbhaqt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.05
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('pAUT','NSSH', 'SSH')
selVars <-c('trans_respAUT1', 'NSSH1', 'SSH1', 'trans_respAUT2', 'NSSH2', 'SSH2')
useVars <-c('trans_respAUT1', 'NSSH1', 'SSH1', 'trans_respAUT2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_respAUT1', 'NSSH1', 'SSH1', 'trans_respAUT2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_respAUT1', 'NSSH1', 'SSH1', 'trans_respAUT2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_respAUT1', 'NSSH1', 'SSH1', 'trans_respAUT2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between pAUT-NSSH
rphace_pAUT_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_pAUT_NSSH" )
rphace_pAUT_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_pAUT_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHpAUT<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_pAUT")
raSSHpAUT<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_pAUT")
#rC
rcNSSHpAUT<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_pAUT")
rcSSHpAUT<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_pAUT")
#rE
reNSSHpAUT<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_pAUT")
reSSHpAUT<-mxAlgebra(expression=Re[3,1], name="rE_SSH_pAUT")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_pAUT_NSSH,rphace_pAUT_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHpAUT,raSSHpAUT,rcNSSHpAUT,rcSSHpAUT,reNSSHpAUT,reSSHpAUT)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# ------------------------------------------------------------------------------
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_pAUT_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_pAUT_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_pAUT_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_pAUT_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_pAUT_NSSH, AceFit1),
mxEval(ACE.RphACE_pAUT_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_pAUT==MZ.rA_SSH_pAUT, name="rA_con"),
mxConstraint(MZ.rC_NSSH_pAUT==MZ.rC_SSH_pAUT, name="rC_con"),
mxConstraint(MZ.rE_NSSH_pAUT==MZ.rE_SSH_pAUT, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
# COMPARE MODELS: Print Comparative Fit Statistics
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_pAUT_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="pAUT", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="pAUT", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="pAUT", append=TRUE)cSDQ
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhsdqbeht1,pcbhsdqbeht2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cSDQ variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescSDQ1 <- residuals(lm(self_harm_data_c$pcbhsdqbeht1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescSDQ2 <- residuals(lm(self_harm_data_c$pcbhsdqbeht2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$rescSDQ1)
hist(self_harm_data_c$rescSDQ2)
describe(self_harm_data_c$rescSDQ1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescSDQ1 <-sqrt(self_harm_data_c$rescSDQ1+12)*2
self_harm_data_c$trans_rescSDQ2 <-sqrt(self_harm_data_c$rescSDQ2+12)*2
hist(self_harm_data_c$rescSDQ1)
hist(self_harm_data_c$trans_rescSDQ1)
describe(self_harm_data_c$trans_rescSDQ1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescSDQ1, self_harm_data_c$NSSH1)$correlations #0.36
hetcor(self_harm_data_c$pcbhsdqbeht1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.36
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cSDQ','NSSH', 'SSH')
selVars <-c('trans_rescSDQ1', 'NSSH1', 'SSH1', 'trans_rescSDQ2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescSDQ1', 'NSSH1', 'SSH1', 'trans_rescSDQ2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescSDQ1', 'NSSH1', 'SSH1', 'trans_rescSDQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescSDQ1', 'NSSH1', 'SSH1', 'trans_rescSDQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescSDQ1', 'NSSH1', 'SSH1', 'trans_rescSDQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.26,0.45,0.19,0.15,0.79,0.55,0.25,0.16)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(1.02,0.31,0.33,0.61,0.52,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.25,0.22,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(1.04,0.14,0.16,0.67,0.56,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.02, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.40, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,-4), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cSDQ-NSSH
rphace_cSDQ_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cSDQ_NSSH" )
rphace_cSDQ_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cSDQ_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcSDQ<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cSDQ")
raSSHcSDQ<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cSDQ")
#rC
rcNSSHcSDQ<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cSDQ")
rcSSHcSDQ<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cSDQ")
#rE
reNSSHcSDQ<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cSDQ")
reSSHcSDQ<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cSDQ")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cSDQ_NSSH,rphace_cSDQ_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcSDQ,raSSHcSDQ,rcNSSHcSDQ,rcSSHcSDQ,reNSSHcSDQ,reSSHcSDQ)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cSDQ_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cSDQ_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cSDQ_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cSDQ_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cSDQ_NSSH, AceFit1),
mxEval(ACE.RphACE_cSDQ_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cSDQ==MZ.rA_SSH_cSDQ, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cSDQ==MZ.rC_SSH_cSDQ, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cSDQ==MZ.rE_SSH_cSDQ, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cSDQ_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cSDQ", append=TRUE)
# # Add a second data set in a new worksheet
# write.xlsx(mtcars, file="myworkbook.xlsx", sheetName="MTCARS",
# append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cSDQ", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cSDQ", append=TRUE)pSDQ
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,ppbhsdqbeht1,ppbhsdqbeht2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform SDQ variable
#******************************************************
#**Regressing out age & sex from anxiety (pgadtot)**#
self_harm_data_c$respSDQ1 <- residuals(lm(self_harm_data_c$ppbhsdqbeht1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$respSDQ2 <- residuals(lm(self_harm_data_c$ppbhsdqbeht2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$respSDQ1)
hist(self_harm_data_c$respSDQ2)
describe(self_harm_data_c$respSDQ1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_respSDQ1 <-log(self_harm_data_c$respSDQ1+6)*3
self_harm_data_c$trans_respSDQ2 <-log(self_harm_data_c$respSDQ2+6)*3
hist(self_harm_data_c$respSDQ1)
hist(self_harm_data_c$trans_respSDQ1)
describe(self_harm_data_c$trans_respSDQ1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_respSDQ1, self_harm_data_c$NSSH1)$correlations #0.16
hetcor(self_harm_data_c$ppbhsdqbeht1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.1202
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('pSDQ','NSSH', 'SSH')
selVars <-c('trans_respSDQ1', 'NSSH1', 'SSH1', 'trans_respSDQ2', 'NSSH2', 'SSH2')
useVars <-c('trans_respSDQ1', 'NSSH1', 'SSH1', 'trans_respSDQ2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_respSDQ1', 'NSSH1', 'SSH1', 'trans_respSDQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_respSDQ1', 'NSSH1', 'SSH1', 'trans_respSDQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_respSDQ1', 'NSSH1', 'SSH1', 'trans_respSDQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.2,0.45,0.19,0.15,0.76,0.55,0.25,0.16)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(1.30,0.15,0.18,0.72,0.64,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.02,0.01,0.01,0.001,.001), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.66,0.03,0.06,.67,0.57,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,-4), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between pSDQ-NSSH
rphace_pSDQ_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_pSDQ_NSSH" )
rphace_pSDQ_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_pSDQ_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHpSDQ<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_pSDQ")
raSSHpSDQ<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_pSDQ")
#rC
rcNSSHpSDQ<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_pSDQ")
rcSSHpSDQ<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_pSDQ")
#rE
reNSSHpSDQ<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_pSDQ")
reSSHpSDQ<-mxAlgebra(expression=Re[3,1], name="rE_SSH_pSDQ")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_pSDQ_NSSH,rphace_pSDQ_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHpSDQ,raSSHpSDQ,rcNSSHpSDQ,rcSSHpSDQ,reNSSHpSDQ,reSSHpSDQ)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #note that I asked for CI for Conf2 only
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #note that I asked for CI for Conf2 only
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #note that I asked for CI for Conf2 only
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #note that I asked for CI for Conf2 only
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #note that I asked for CI for Conf2 only
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #note that I asked for CI for Conf2 only
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #note that I asked for CI for Conf2 only
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_pSDQ_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_pSDQ_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_pSDQ_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_pSDQ_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_pSDQ_NSSH, AceFit1),
mxEval(ACE.RphACE_pSDQ_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_pSDQ==MZ.rA_SSH_pSDQ, name="rA_con"),
mxConstraint(MZ.rC_NSSH_pSDQ==MZ.rC_SSH_pSDQ, name="rC_con"),
mxConstraint(MZ.rE_NSSH_pSDQ==MZ.rE_SSH_pSDQ, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_pSDQ_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="pSDQ", append=TRUE)
# # Add a second data set in a new worksheet
# write.xlsx(mtcars, file="myworkbook.xlsx", sheetName="MTCARS",
# append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="pSDQ", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="pSDQ", append=TRUE)Internalising problems
cMFQ
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhmfqt1,pcbhmfqt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cMFQ variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescMFQ1 <- residuals(lm(self_harm_data_c$pcbhmfqt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescMFQ2 <- residuals(lm(self_harm_data_c$pcbhmfqt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhmfqt1)
hist(self_harm_data_c$rescMFQ1)
describe(self_harm_data_c$rescMFQ1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescMFQ1 <-log(self_harm_data_c$rescMFQ1+4.96)*1.5
self_harm_data_c$trans_rescMFQ2 <-log(self_harm_data_c$rescMFQ2+4.96)*1.5
hist(self_harm_data_c$rescMFQ1)
hist(self_harm_data_c$trans_rescMFQ1)
describe(self_harm_data_c$trans_rescMFQ1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescMFQ1, self_harm_data_c$NSSH1)$correlations #0.36
hetcor(self_harm_data_c$pcbhmfqt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.36
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cMFQ','NSSH', 'SSH')
selVars <-c('trans_rescMFQ1', 'NSSH1', 'SSH1', 'trans_rescMFQ2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescMFQ1', 'NSSH1', 'SSH1', 'trans_rescMFQ2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescMFQ1', 'NSSH1', 'SSH1', 'trans_rescMFQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescMFQ1', 'NSSH1', 'SSH1', 'trans_rescMFQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescMFQ1', 'NSSH1', 'SSH1', 'trans_rescMFQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.13,0.45,0.19,0.15,0.89,0.55,0.25,0.16)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.70,0.36,0.45,0.60,0.46,0.17), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.20,0.14,0.05,0.08,0.001), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.13,0.13,0.67,0.55,0.82), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,-4), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cMFQ-NSSH
rphace_cMFQ_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cMFQ_NSSH" )
rphace_cMFQ_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cMFQ_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcMFQ<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cMFQ")
raSSHcMFQ<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cMFQ")
#rC
rcNSSHcMFQ<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cMFQ")
rcSSHcMFQ<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cMFQ")
#rE
reNSSHcMFQ<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cMFQ")
reSSHcMFQ<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cMFQ")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cMFQ_NSSH,rphace_cMFQ_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcMFQ,raSSHcMFQ,rcNSSHcMFQ,rcSSHcMFQ,reNSSHcMFQ,reSSHcMFQ)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cMFQ_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cMFQ_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cMFQ_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cMFQ_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cMFQ_NSSH, AceFit1),
mxEval(ACE.RphACE_cMFQ_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cMFQ==MZ.rA_SSH_cMFQ, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cMFQ==MZ.rC_SSH_cMFQ, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cMFQ==MZ.rE_SSH_cMFQ, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cMFQ_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cMFQ", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cMFQ", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cMFQ", append=TRUE)pMFQ
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse);require(bestNormalize)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,ppbhmfqt1,ppbhmfqt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform pMFQ variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$respMFQ1 <- residuals(lm(self_harm_data_c$ppbhmfqt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$respMFQ2 <- residuals(lm(self_harm_data_c$ppbhmfqt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$ppbhmfqt1)
hist(self_harm_data_c$respMFQ1)
describe(self_harm_data_c$respMFQ1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_respMFQ1 <-log(self_harm_data_c$respMFQ1+1.29)*2
self_harm_data_c$trans_respMFQ2 <-log(self_harm_data_c$respMFQ2+1.29)*2
hist(self_harm_data_c$respMFQ1)
hist(self_harm_data_c$trans_respMFQ1)
describe(self_harm_data_c$trans_respMFQ1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_respMFQ1, self_harm_data_c$NSSH1)$correlations #0.16
hetcor(self_harm_data_c$ppbhmfqt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.20
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('pMFQ','NSSH', 'SSH')
selVars <-c('trans_respMFQ1', 'NSSH1', 'SSH1', 'trans_respMFQ2', 'NSSH2', 'SSH2')
useVars <-c('trans_respMFQ1', 'NSSH1', 'SSH1', 'trans_respMFQ2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_respMFQ1', 'NSSH1', 'SSH1', 'trans_respMFQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_respMFQ1', 'NSSH1', 'SSH1', 'trans_respMFQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_respMFQ1', 'NSSH1', 'SSH1', 'trans_respMFQ2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.44,0.45,0.19,0.15,0.70,0.55,0.26,0.16)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.45,0.19,0.20,0.68,0.58,0.05), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.32,0.18,0.01,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.59,0.81,0.79,0.67,0.57,0.45), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.04, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.30, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between pMFQ-NSSH
rphace_pMFQ_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_pMFQ_NSSH" )
rphace_pMFQ_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_pMFQ_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHpMFQ<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_pMFQ")
raSSHpMFQ<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_pMFQ")
#rC
rcNSSHpMFQ<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_pMFQ")
rcSSHpMFQ<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_pMFQ")
#rE
reNSSHpMFQ<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_pMFQ")
reSSHpMFQ<-mxAlgebra(expression=Re[3,1], name="rE_SSH_pMFQ")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_pMFQ_NSSH,rphace_pMFQ_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHpMFQ,raSSHpMFQ,rcNSSHpMFQ,rcSSHpMFQ,reNSSHpMFQ,reSSHpMFQ)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, varL1, varL2, fitFunction, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 57172.68
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T)
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T)
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T)
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T)
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T)
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T)
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_pMFQ_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_pMFQ_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_pMFQ_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_pMFQ_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_pMFQ_NSSH, AceFit1),
mxEval(ACE.RphACE_pMFQ_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_pMFQ==MZ.rA_SSH_pMFQ, name="rA_con"),
mxConstraint(MZ.rC_NSSH_pMFQ==MZ.rC_SSH_pMFQ, name="rC_con"),
mxConstraint(MZ.rE_NSSH_pMFQ==MZ.rE_SSH_pMFQ, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_pMFQ_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="pMFQ", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="pMFQ", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="pMFQ", append=TRUE)cANX
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhcasit1,pcbhcasit2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cANX variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescANX1 <- residuals(lm(self_harm_data_c$pcbhcasit1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescANX2 <- residuals(lm(self_harm_data_c$pcbhcasit2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhcasit1)
hist(self_harm_data_c$rescANX1)
describe(self_harm_data_c$rescANX1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescANX1 <-sqrt(self_harm_data_c$rescANX1+9.44)*1.5
self_harm_data_c$trans_rescANX2 <-sqrt(self_harm_data_c$rescANX2+9.44)*1.5
hist(self_harm_data_c$rescANX1)
hist(self_harm_data_c$trans_rescANX1)
describe(self_harm_data_c$trans_rescANX1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescANX1, self_harm_data_c$NSSH1)$correlations #0.23
hetcor(self_harm_data_c$rescANX1, self_harm_data_c$NSSH1)$correlations #0.22
hetcor(self_harm_data_c$pcbhcasit1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.25
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cANX','NSSH', 'SSH')
selVars <-c('trans_rescANX1', 'NSSH1', 'SSH1', 'trans_rescANX2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescANX1', 'NSSH1', 'SSH1', 'trans_rescANX2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescANX1', 'NSSH1', 'SSH1', 'trans_rescANX2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescANX1', 'NSSH1', 'SSH1', 'trans_rescANX2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescANX1', 'NSSH1', 'SSH1', 'trans_rescANX2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cANX-NSSH
rphace_cANX_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cANX_NSSH" )
rphace_cANX_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cANX_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcANX<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cANX")
raSSHcANX<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cANX")
#rC
rcNSSHcANX<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cANX")
rcSSHcANX<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cANX")
#rE
reNSSHcANX<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cANX")
reSSHcANX<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cANX")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cANX_NSSH,rphace_cANX_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcANX,raSSHcANX,rcNSSHcANX,rcSSHcANX,reNSSHcANX,reSSHcANX)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# ------------------------------------------------------------------------------
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cANX_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cANX_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cANX_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cANX_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cANX_NSSH, AceFit1),
mxEval(ACE.RphACE_cANX_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cANX==MZ.rA_SSH_cANX, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cANX==MZ.rC_SSH_cANX, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cANX==MZ.rE_SSH_cANX, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cANX_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cANX", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cANX", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cANX", append=TRUE)pANX
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,ppbhanxt1,ppbhanxt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform pANX variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$respANX1 <- residuals(lm(self_harm_data_c$ppbhanxt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$respANX2 <- residuals(lm(self_harm_data_c$ppbhanxt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$ppbhanxt1)
hist(self_harm_data_c$respANX1)
describe(self_harm_data_c$respANX1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_respANX1 <-((self_harm_data_c$respANX1)^(1/3))*2.5
self_harm_data_c$trans_respANX2 <-((self_harm_data_c$respANX2)^(1/3))*2.5
hist(self_harm_data_c$respANX1)
hist(self_harm_data_c$trans_respANX1)
describe(self_harm_data_c$trans_respANX1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_respANX1, self_harm_data_c$NSSH1)$correlations #0.13
hetcor(self_harm_data_c$respANX1, self_harm_data_c$NSSH1)$correlations #0.15
hetcor(self_harm_data_c$ppbhanxt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.17
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('pANX','NSSH', 'SSH')
selVars <-c('trans_respANX1', 'NSSH1', 'SSH1', 'trans_respANX2', 'NSSH2', 'SSH2')
useVars <-c('trans_respANX1', 'NSSH1', 'SSH1', 'trans_respANX2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_respANX1', 'NSSH1', 'SSH1', 'trans_respANX2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_respANX1', 'NSSH1', 'SSH1', 'trans_respANX2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_respANX1', 'NSSH1', 'SSH1', 'trans_respANX2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between pANX-NSSH
rphace_pANX_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_pANX_NSSH" )
rphace_pANX_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_pANX_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHpANX<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_pANX")
raSSHpANX<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_pANX")
#rC
rcNSSHpANX<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_pANX")
rcSSHpANX<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_pANX")
#rE
reNSSHpANX<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_pANX")
reSSHpANX<-mxAlgebra(expression=Re[3,1], name="rE_SSH_pANX")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_pANX_NSSH,rphace_pANX_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHpANX,raSSHpANX,rcNSSHpANX,rcSSHpANX,reNSSHpANX,reSSHpANX)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_pANX_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_pANX_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_pANX_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_pANX_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_pANX_NSSH, AceFit1),
mxEval(ACE.RphACE_pANX_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_pANX==MZ.rA_SSH_pANX, name="rA_con"),
mxConstraint(MZ.rC_NSSH_pANX==MZ.rC_SSH_pANX, name="rC_con"),
mxConstraint(MZ.rE_NSSH_pANX==MZ.rE_SSH_pANX, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_pANX_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="pANX", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="pANX", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="pANX", append=TRUE)cINSOM
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhinsomt1,pcbhinsomt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cINSOM variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescINSOM1 <- residuals(lm(self_harm_data_c$pcbhinsomt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescINSOM2 <- residuals(lm(self_harm_data_c$pcbhinsomt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhinsomt1)
hist(self_harm_data_c$rescINSOM1)
describe(self_harm_data_c$rescINSOM1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescINSOM1 <-log(self_harm_data_c$rescINSOM1+5.5)*1.5
self_harm_data_c$trans_rescINSOM2 <-log(self_harm_data_c$rescINSOM2+5.5)*1.5
hist(self_harm_data_c$rescINSOM1)
hist(self_harm_data_c$trans_rescINSOM1)
boxplot(self_harm_data_c$trans_rescINSOM1) #there is one outlier?
boxplot(self_harm_data_c$rescINSOM1)
describe(self_harm_data_c$trans_rescINSOM1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescINSOM1, self_harm_data_c$NSSH1)$correlations #0.23
hetcor(self_harm_data_c$rescINSOM1, self_harm_data_c$NSSH1)$correlations #0.22
hetcor(self_harm_data_c$pcbhinsomt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.25
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cINSOM','NSSH', 'SSH')
selVars <-c('trans_rescINSOM1', 'NSSH1', 'SSH1', 'trans_rescINSOM2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescINSOM1', 'NSSH1', 'SSH1', 'trans_rescINSOM2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescINSOM1', 'NSSH1', 'SSH1', 'trans_rescINSOM2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescINSOM1', 'NSSH1', 'SSH1', 'trans_rescINSOM2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescINSOM1', 'NSSH1', 'SSH1', 'trans_rescINSOM2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cINSOM-NSSH
rphace_cINSOM_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cINSOM_NSSH" )
rphace_cINSOM_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cINSOM_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcINSOM<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cINSOM")
raSSHcINSOM<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cINSOM")
#rC
rcNSSHcINSOM<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cINSOM")
rcSSHcINSOM<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cINSOM")
#rE
reNSSHcINSOM<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cINSOM")
reSSHcINSOM<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cINSOM")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cINSOM_NSSH,rphace_cINSOM_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcINSOM,raSSHcINSOM,rcNSSHcINSOM,rcSSHcINSOM,reNSSHcINSOM,reSSHcINSOM)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cINSOM_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cINSOM_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cINSOM_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cINSOM_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cINSOM_NSSH, AceFit1),
mxEval(ACE.RphACE_cINSOM_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cINSOM==MZ.rA_SSH_cINSOM, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cINSOM==MZ.rC_SSH_cINSOM, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cINSOM==MZ.rE_SSH_cINSOM, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cINSOM_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cINSOM", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cINSOM", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cINSOM", append=TRUE)cEAT
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbheddsm1,pcbheddsm2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cEAT variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescEAT1 <- residuals(lm(self_harm_data_c$pcbheddsm1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescEAT2 <- residuals(lm(self_harm_data_c$pcbheddsm2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbheddsm1)
hist(self_harm_data_c$rescEAT1)
describe(self_harm_data_c$rescEAT1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescEAT1 <-(self_harm_data_c$rescEAT1)
self_harm_data_c$trans_rescEAT2 <-(self_harm_data_c$rescEAT2)
hist(self_harm_data_c$rescEAT1)
hist(self_harm_data_c$trans_rescEAT1)
describe(self_harm_data_c$trans_rescEAT1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescEAT1, self_harm_data_c$NSSH1)$correlations #0.23
hetcor(self_harm_data_c$rescEAT1, self_harm_data_c$NSSH1)$correlations #0.22
hetcor(self_harm_data_c$pcbheddsm1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.25
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cEAT','NSSH', 'SSH')
selVars <-c('trans_rescEAT1', 'NSSH1', 'SSH1', 'trans_rescEAT2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescEAT1', 'NSSH1', 'SSH1', 'trans_rescEAT2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescEAT1', 'NSSH1', 'SSH1', 'trans_rescEAT2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescEAT1', 'NSSH1', 'SSH1', 'trans_rescEAT2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescEAT1', 'NSSH1', 'SSH1', 'trans_rescEAT2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cEAT-NSSH
rphace_cEAT_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cEAT_NSSH" )
rphace_cEAT_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cEAT_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcEAT<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cEAT")
raSSHcEAT<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cEAT")
#rC
rcNSSHcEAT<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cEAT")
rcSSHcEAT<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cEAT")
#rE
reNSSHcEAT<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cEAT")
reSSHcEAT<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cEAT")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cEAT_NSSH,rphace_cEAT_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcEAT,raSSHcEAT,rcNSSHcEAT,rcSSHcEAT,reNSSHcEAT,reSSHcEAT)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cEAT_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cEAT_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cEAT_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cEAT_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cEAT_NSSH, AceFit1),
mxEval(ACE.RphACE_cEAT_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cEAT==MZ.rA_SSH_cEAT, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cEAT==MZ.rC_SSH_cEAT, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cEAT==MZ.rE_SSH_cEAT, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cEAT_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cEAT", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cEAT", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cEAT", append=TRUE)Externalising problems
cSWAN
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhswanm1,pcbhswanm2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cSWAN variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescSWAN1 <- residuals(lm(self_harm_data_c$pcbhswanm1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescSWAN2 <- residuals(lm(self_harm_data_c$pcbhswanm2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhswanm1)
hist(self_harm_data_c$rescSWAN1)
describe(self_harm_data_c$rescSWAN1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescSWAN1 <-(self_harm_data_c$rescSWAN1)
self_harm_data_c$trans_rescSWAN2 <-(self_harm_data_c$rescSWAN2)
hist(self_harm_data_c$rescSWAN1)
hist(self_harm_data_c$trans_rescSWAN1)
describe(self_harm_data_c$trans_rescSWAN1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescSWAN1, self_harm_data_c$NSSH1)$correlations #0.23
hetcor(self_harm_data_c$rescSWAN1, self_harm_data_c$NSSH1)$correlations #0.22
hetcor(self_harm_data_c$pcbhswanm1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.25
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cSWAN','NSSH', 'SSH')
selVars <-c('trans_rescSWAN1', 'NSSH1', 'SSH1', 'trans_rescSWAN2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescSWAN1', 'NSSH1', 'SSH1', 'trans_rescSWAN2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescSWAN1', 'NSSH1', 'SSH1', 'trans_rescSWAN2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescSWAN1', 'NSSH1', 'SSH1', 'trans_rescSWAN2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescSWAN1', 'NSSH1', 'SSH1', 'trans_rescSWAN2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cSWAN-NSSH
rphace_cSWAN_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cSWAN_NSSH" )
rphace_cSWAN_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cSWAN_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcSWAN<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cSWAN")
raSSHcSWAN<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cSWAN")
#rC
rcNSSHcSWAN<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cSWAN")
rcSSHcSWAN<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cSWAN")
#rE
reNSSHcSWAN<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cSWAN")
reSSHcSWAN<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cSWAN")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cSWAN_NSSH,rphace_cSWAN_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcSWAN,raSSHcSWAN,rcNSSHcSWAN,rcSSHcSWAN,reNSSHcSWAN,reSSHcSWAN)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cSWAN_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cSWAN_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cSWAN_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cSWAN_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cSWAN_NSSH, AceFit1),
mxEval(ACE.RphACE_cSWAN_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cSWAN==MZ.rA_SSH_cSWAN, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cSWAN==MZ.rC_SSH_cSWAN, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cSWAN==MZ.rE_SSH_cSWAN, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cSWAN_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cSWAN", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cSWAN", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cSWAN", append=TRUE)pCONN
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,ppbhconnt1,ppbhconnt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform pCONN variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$respCONN1 <- residuals(lm(self_harm_data_c$ppbhconnt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$respCONN2 <- residuals(lm(self_harm_data_c$ppbhconnt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$ppbhconnt1)
hist(self_harm_data_c$respCONN1)
describe(self_harm_data_c$respCONN1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_respCONN1 <-log(self_harm_data_c$respCONN1+10.5)*2
self_harm_data_c$trans_respCONN2 <-log(self_harm_data_c$respCONN2+10.5)*2
hist(self_harm_data_c$respCONN1)
hist(self_harm_data_c$trans_respCONN1)
describe(self_harm_data_c$trans_respCONN1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_respCONN1, self_harm_data_c$NSSH1)$correlations #0.13
hetcor(self_harm_data_c$ppbhconnt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.07
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('pCONN','NSSH', 'SSH')
selVars <-c('trans_respCONN1', 'NSSH1', 'SSH1', 'trans_respCONN2', 'NSSH2', 'SSH2')
useVars <-c('trans_respCONN1', 'NSSH1', 'SSH1', 'trans_respCONN2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_respCONN1', 'NSSH1', 'SSH1', 'trans_respCONN2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_respCONN1', 'NSSH1', 'SSH1', 'trans_respCONN2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_respCONN1', 'NSSH1', 'SSH1', 'trans_respCONN2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.27,0.45,0.19,0.15,0.75,0.55,0.25,0.16)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(1.05,0.07,0.10,0.72,0.64,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.43,0.09,0.14,0.001,0.001,0.001), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.48,0.03,0.03,0.57,0.57,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between pCONN-NSSH
rphace_pCONN_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_pCONN_NSSH" )
rphace_pCONN_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_pCONN_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHpCONN<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_pCONN")
raSSHpCONN<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_pCONN")
#rC
rcNSSHpCONN<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_pCONN")
rcSSHpCONN<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_pCONN")
#rE
reNSSHpCONN<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_pCONN")
reSSHpCONN<-mxAlgebra(expression=Re[3,1], name="rE_SSH_pCONN")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_pCONN_NSSH,rphace_pCONN_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHpCONN,raSSHpCONN,rcNSSHpCONN,rcSSHpCONN,reNSSHpCONN,reSSHpCONN)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# ------------------------------------------------------------------------------
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_pCONN_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_pCONN_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_pCONN_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_pCONN_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_pCONN_NSSH, AceFit1),
mxEval(ACE.RphACE_pCONN_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_pCONN==MZ.rA_SSH_pCONN, name="rA_con"),
mxConstraint(MZ.rC_NSSH_pCONN==MZ.rC_SSH_pCONN, name="rC_con"),
mxConstraint(MZ.rE_NSSH_pCONN==MZ.rE_SSH_pCONN, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_pCONN_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="pCONN", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="pCONN", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="pCONN", append=TRUE)pINAT
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,ppbhconninat1,ppbhconninat2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform pINAT variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$respINAT1 <- residuals(lm(self_harm_data_c$ppbhconninat1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$respINAT2 <- residuals(lm(self_harm_data_c$ppbhconninat2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$ppbhconninat1)
hist(self_harm_data_c$respINAT1)
describe(self_harm_data_c$respINAT1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_respINAT1 <-log(self_harm_data_c$respINAT1+6.9)*2
self_harm_data_c$trans_respINAT2 <-log(self_harm_data_c$respINAT2+6.9)*2
hist(self_harm_data_c$respINAT1)
hist(self_harm_data_c$trans_respINAT1)
describe(self_harm_data_c$trans_respINAT1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_respINAT1, self_harm_data_c$NSSH1)$correlations #0.15
hetcor(self_harm_data_c$ppbhconninat1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.08
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('pINAT','NSSH', 'SSH')
selVars <-c('trans_respINAT1', 'NSSH1', 'SSH1', 'trans_respINAT2', 'NSSH2', 'SSH2')
useVars <-c('trans_respINAT1', 'NSSH1', 'SSH1', 'trans_respINAT2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_respINAT1', 'NSSH1', 'SSH1', 'trans_respINAT2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_respINAT1', 'NSSH1', 'SSH1', 'trans_respINAT2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_respINAT1', 'NSSH1', 'SSH1', 'trans_respINAT2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.2,0.45,0.19,0.15,0.77,0.54,0.25,0.16)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(1.14,0.12,0.14,0.72,0.63,0.22), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.03,0.13,0.11,0.02,0.02,.001), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.37,0.03,0.13,0.67,0.56,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,-4), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between pINAT-NSSH
rphace_pINAT_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_pINAT_NSSH" )
rphace_pINAT_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_pINAT_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHpINAT<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_pINAT")
raSSHpINAT<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_pINAT")
#rC
rcNSSHpINAT<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_pINAT")
rcSSHpINAT<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_pINAT")
#rE
reNSSHpINAT<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_pINAT")
reSSHpINAT<-mxAlgebra(expression=Re[3,1], name="rE_SSH_pINAT")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_pINAT_NSSH,rphace_pINAT_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHpINAT,raSSHpINAT,rcNSSHpINAT,rcSSHpINAT,reNSSHpINAT,reSSHpINAT)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_pINAT_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_pINAT_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_pINAT_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_pINAT_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_pINAT_NSSH, AceFit1),
mxEval(ACE.RphACE_pINAT_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_pINAT==MZ.rA_SSH_pINAT, name="rA_con"),
mxConstraint(MZ.rC_NSSH_pINAT==MZ.rC_SSH_pINAT, name="rC_con"),
mxConstraint(MZ.rE_NSSH_pINAT==MZ.rE_SSH_pINAT, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_pINAT_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="pINAT", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="pINAT", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="pINAT", append=TRUE)pHYPER
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,ppbhconnimpt1,ppbhconnimpt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform pHYPER variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$respHYPER1 <- residuals(lm(self_harm_data_c$ppbhconnimpt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$respHYPER2 <- residuals(lm(self_harm_data_c$ppbhconnimpt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$ppbhconnimpt1)
hist(self_harm_data_c$respHYPER1)
describe(self_harm_data_c$respHYPER1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_respHYPER1 <-log(self_harm_data_c$respHYPER1+3.49)*1.5
self_harm_data_c$trans_respHYPER2 <-log(self_harm_data_c$respHYPER2+3.49)*1.5
hist(self_harm_data_c$respHYPER1)
hist(self_harm_data_c$trans_respHYPER1)
describe(self_harm_data_c$trans_respHYPER1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_respHYPER1, self_harm_data_c$NSSH1)$correlations #0.07
hetcor(self_harm_data_c$ppbhconnimpt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.04
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('pHYPER','NSSH', 'SSH')
selVars <-c('trans_respHYPER1', 'NSSH1', 'SSH1', 'trans_respHYPER2', 'NSSH2', 'SSH2')
useVars <-c('trans_respHYPER1', 'NSSH1', 'SSH1', 'trans_respHYPER2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_respHYPER1', 'NSSH1', 'SSH1', 'trans_respHYPER2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_respHYPER1', 'NSSH1', 'SSH1', 'trans_respHYPER2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_respHYPER1', 'NSSH1', 'SSH1', 'trans_respHYPER2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.2,0.45,0.19,0.15,0.56,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(1.30,0.05,0.04,0.72,0.62,0.43), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.09,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.03,0.01,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,-4), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between pHYPER-NSSH
rphace_pHYPER_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_pHYPER_NSSH" )
rphace_pHYPER_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_pHYPER_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHpHYPER<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_pHYPER")
raSSHpHYPER<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_pHYPER")
#rC
rcNSSHpHYPER<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_pHYPER")
rcSSHpHYPER<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_pHYPER")
#rE
reNSSHpHYPER<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_pHYPER")
reSSHpHYPER<-mxAlgebra(expression=Re[3,1], name="rE_SSH_pHYPER")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_pHYPER_NSSH,rphace_pHYPER_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHpHYPER,raSSHpHYPER,rcNSSHpHYPER,rcSSHpHYPER,reNSSHpHYPER,reSSHpHYPER)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_pHYPER_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_pHYPER_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_pHYPER_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_pHYPER_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_pHYPER_NSSH, AceFit1),
mxEval(ACE.RphACE_pHYPER_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_pHYPER==MZ.rA_SSH_pHYPER, name="rA_con"),
mxConstraint(MZ.rC_NSSH_pHYPER==MZ.rC_SSH_pHYPER, name="rC_con"),
mxConstraint(MZ.rE_NSSH_pHYPER==MZ.rE_SSH_pHYPER, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_pHYPER_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="pHYPER", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="pHYPER", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="pHYPER", append=TRUE)pEMOLv2
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,ppbhconnemlt1,ppbhconnemlt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform pEMOLv2 variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$respEMOLv21 <- residuals(lm(self_harm_data_c$ppbhconnemlt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$respEMOLv22 <- residuals(lm(self_harm_data_c$ppbhconnemlt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$ppbhconnemlt1)
hist(self_harm_data_c$respEMOLv21)
describe(self_harm_data_c$respEMOLv21)
# #transform the data to get a normal distribution
self_harm_data_c$trans_respEMOLv21 <-log(self_harm_data_c$respEMOLv21+1.71)
self_harm_data_c$trans_respEMOLv22 <-log(self_harm_data_c$respEMOLv22+1.71)
hist(self_harm_data_c$respEMOLv21)
hist(self_harm_data_c$trans_respEMOLv21)
describe(self_harm_data_c$trans_respEMOLv21)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_respEMOLv21, self_harm_data_c$NSSH1)$correlations #0.15
hetcor(self_harm_data_c$ppbhconnemlt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.16
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('pEMOLv2','NSSH', 'SSH')
selVars <-c('trans_respEMOLv21', 'NSSH1', 'SSH1', 'trans_respEMOLv22', 'NSSH2', 'SSH2')
useVars <-c('trans_respEMOLv21', 'NSSH1', 'SSH1', 'trans_respEMOLv22', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_respEMOLv21', 'NSSH1', 'SSH1', 'trans_respEMOLv22', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_respEMOLv21', 'NSSH1', 'SSH1', 'trans_respEMOLv22', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_respEMOLv21', 'NSSH1', 'SSH1', 'trans_respEMOLv22', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.47,0.45,0.19,0.15,0.56,0.56,0.25,0.16)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.06,0.34,0.02,0.23,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.80,0.20,0.14,0.001,0.001,0.001), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.14,0.03,0.06,0.55,0.07,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,-4), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between pEMOLv2-NSSH
rphace_pEMOLv2_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_pEMOLv2_NSSH" )
rphace_pEMOLv2_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_pEMOLv2_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHpEMOLv2<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_pEMOLv2")
raSSHpEMOLv2<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_pEMOLv2")
#rC
rcNSSHpEMOLv2<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_pEMOLv2")
rcSSHpEMOLv2<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_pEMOLv2")
#rE
reNSSHpEMOLv2<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_pEMOLv2")
reSSHpEMOLv2<-mxAlgebra(expression=Re[3,1], name="rE_SSH_pEMOLv2")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_pEMOLv2_NSSH,rphace_pEMOLv2_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHpEMOLv2,raSSHpEMOLv2,rcNSSHpEMOLv2,rcSSHpEMOLv2,reNSSHpEMOLv2,reSSHpEMOLv2)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_pEMOLv2_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_pEMOLv2_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_pEMOLv2_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_pEMOLv2_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_pEMOLv2_NSSH, AceFit1),
mxEval(ACE.RphACE_pEMOLv2_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_pEMOLv2==MZ.rA_SSH_pEMOLv2, name="rA_con"),
mxConstraint(MZ.rC_NSSH_pEMOLv2==MZ.rC_SSH_pEMOLv2, name="rC_con"),
mxConstraint(MZ.rE_NSSH_pEMOLv2==MZ.rE_SSH_pEMOLv2, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_pEMOLv2_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="pEMOLv2", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="pEMOLv2", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="pEMOLv2", append=TRUE)Psychotic-like experiences
cPRND
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhprndt1,pcbhprndt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cPRND variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescPRND1 <- residuals(lm(self_harm_data_c$pcbhprndt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescPRND2 <- residuals(lm(self_harm_data_c$pcbhprndt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhprndt1)
hist(self_harm_data_c$rescPRND1)
describe(self_harm_data_c$rescPRND1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescPRND1 <-((self_harm_data_c$rescPRND1+12.69)^(1/3))*2
self_harm_data_c$trans_rescPRND2 <-((self_harm_data_c$rescPRND2+12.69)^(1/3))*2
hist(self_harm_data_c$rescPRND1)
hist(self_harm_data_c$trans_rescPRND1)
describe(self_harm_data_c$trans_rescPRND1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescPRND1, self_harm_data_c$NSSH1)$correlations #0.31
hetcor(self_harm_data_c$pcbhprndt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.29
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cPRND','NSSH', 'SSH')
selVars <-c('trans_rescPRND1', 'NSSH1', 'SSH1', 'trans_rescPRND2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescPRND1', 'NSSH1', 'SSH1', 'trans_rescPRND2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescPRND1', 'NSSH1', 'SSH1', 'trans_rescPRND2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescPRND1', 'NSSH1', 'SSH1', 'trans_rescPRND2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescPRND1', 'NSSH1', 'SSH1', 'trans_rescPRND2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cPRND-NSSH
rphace_cPRND_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cPRND_NSSH" )
rphace_cPRND_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cPRND_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcPRND<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cPRND")
raSSHcPRND<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cPRND")
#rC
rcNSSHcPRND<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cPRND")
rcSSHcPRND<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cPRND")
#rE
reNSSHcPRND<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cPRND")
reSSHcPRND<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cPRND")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cPRND_NSSH,rphace_cPRND_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcPRND,raSSHcPRND,rcNSSHcPRND,rcSSHcPRND,reNSSHcPRND,reSSHcPRND)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cPRND_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cPRND_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cPRND_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cPRND_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cPRND_NSSH, AceFit1),
mxEval(ACE.RphACE_cPRND_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cPRND==MZ.rA_SSH_cPRND, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cPRND==MZ.rC_SSH_cPRND, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cPRND==MZ.rE_SSH_cPRND, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cPRND_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cPRND", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cPRND", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cPRND", append=TRUE)cCAPS
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhcapst1,pcbhcapst2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cCAPS variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescCAPS1 <- residuals(lm(self_harm_data_c$pcbhcapst1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescCAPS2 <- residuals(lm(self_harm_data_c$pcbhcapst2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhcapst1)
hist(self_harm_data_c$rescCAPS1)
describe(self_harm_data_c$rescCAPS1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescCAPS1 <-log(self_harm_data_c$rescCAPS1+5.5)
self_harm_data_c$trans_rescCAPS2 <-log(self_harm_data_c$rescCAPS2+5.5)
hist(self_harm_data_c$rescCAPS1)
hist(self_harm_data_c$trans_rescCAPS1)
describe(self_harm_data_c$trans_rescCAPS1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescCAPS1, self_harm_data_c$NSSH1)$correlations #0.21
hetcor(self_harm_data_c$pcbhcapst1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.23
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cCAPS','NSSH', 'SSH')
selVars <-c('trans_rescCAPS1', 'NSSH1', 'SSH1', 'trans_rescCAPS2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescCAPS1', 'NSSH1', 'SSH1', 'trans_rescCAPS2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescCAPS1', 'NSSH1', 'SSH1', 'trans_rescCAPS2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescCAPS1', 'NSSH1', 'SSH1', 'trans_rescCAPS2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescCAPS1', 'NSSH1', 'SSH1', 'trans_rescCAPS2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cCAPS-NSSH
rphace_cCAPS_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cCAPS_NSSH" )
rphace_cCAPS_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cCAPS_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcCAPS<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cCAPS")
raSSHcCAPS<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cCAPS")
#rC
rcNSSHcCAPS<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cCAPS")
rcSSHcCAPS<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cCAPS")
#rE
reNSSHcCAPS<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cCAPS")
reSSHcCAPS<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cCAPS")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cCAPS_NSSH,rphace_cCAPS_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcCAPS,raSSHcCAPS,rcNSSHcCAPS,rcSSHcCAPS,reNSSHcCAPS,reSSHcCAPS)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cCAPS_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cCAPS_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cCAPS_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cCAPS_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cCAPS_NSSH, AceFit1),
mxEval(ACE.RphACE_cCAPS_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cCAPS==MZ.rA_SSH_cCAPS, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cCAPS==MZ.rC_SSH_cCAPS, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cCAPS==MZ.rE_SSH_cCAPS, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cCAPS_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cCAPS", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cCAPS", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cCAPS", append=TRUE)cANHE
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhanhdt1,pcbhanhdt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cANHE variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescANHE1 <- residuals(lm(self_harm_data_c$pcbhanhdt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescANHE2 <- residuals(lm(self_harm_data_c$pcbhanhdt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhanhdt1)
hist(self_harm_data_c$rescANHE1)
describe(self_harm_data_c$rescANHE1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescANHE1 <-(self_harm_data_c$rescANHE1+1.68)^(1/3)
self_harm_data_c$trans_rescANHE2 <-(self_harm_data_c$rescANHE2+1.68)^(1/3)
hist(self_harm_data_c$rescANHE1)
hist(self_harm_data_c$trans_rescANHE1)
describe(self_harm_data_c$trans_rescANHE1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescANHE1, self_harm_data_c$NSSH1)$correlations #0.18
hetcor(self_harm_data_c$pcbhanhdt1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.17
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cANHE','NSSH', 'SSH')
selVars <-c('trans_rescANHE1', 'NSSH1', 'SSH1', 'trans_rescANHE2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescANHE1', 'NSSH1', 'SSH1', 'trans_rescANHE2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescANHE1', 'NSSH1', 'SSH1', 'trans_rescANHE2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescANHE1', 'NSSH1', 'SSH1', 'trans_rescANHE2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescANHE1', 'NSSH1', 'SSH1', 'trans_rescANHE2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cANHE-NSSH
rphace_cANHE_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cANHE_NSSH" )
rphace_cANHE_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cANHE_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcANHE<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cANHE")
raSSHcANHE<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cANHE")
#rC
rcNSSHcANHE<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cANHE")
rcSSHcANHE<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cANHE")
#rE
reNSSHcANHE<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cANHE")
reSSHcANHE<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cANHE")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cANHE_NSSH,rphace_cANHE_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcANHE,raSSHcANHE,rcNSSHcANHE,rcSSHcANHE,reNSSHcANHE,reSSHcANHE)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cANHE_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cANHE_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cANHE_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cANHE_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cANHE_NSSH, AceFit1),
mxEval(ACE.RphACE_cANHE_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cANHE==MZ.rA_SSH_cANHE, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cANHE==MZ.rC_SSH_cANHE, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cANHE==MZ.rE_SSH_cANHE, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
# COMPARE MODELS: Print Comparative Fit Statistics
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cANHE_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cANHE", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cANHE", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cANHE", append=TRUE)pSANS
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,ppbhsanst1,ppbhsanst2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform pSANS variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$respSANS1 <- residuals(lm(self_harm_data_c$ppbhsanst1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$respSANS2 <- residuals(lm(self_harm_data_c$ppbhsanst2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$ppbhsanst1)
hist(self_harm_data_c$respSANS1)
describe(self_harm_data_c$respSANS1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_respSANS1 <-log(self_harm_data_c$respSANS1+3.75)*2
self_harm_data_c$trans_respSANS2 <-log(self_harm_data_c$respSANS2+3.75)*2
hist(self_harm_data_c$respSANS1)
hist(self_harm_data_c$trans_respSANS1)
describe(self_harm_data_c$trans_respSANS1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_respSANS1, self_harm_data_c$NSSH1)$correlations #0.16
hetcor(self_harm_data_c$ppbhsanst1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.12
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('pSANS','NSSH', 'SSH')
selVars <-c('trans_respSANS1', 'NSSH1', 'SSH1', 'trans_respSANS2', 'NSSH2', 'SSH2')
useVars <-c('trans_respSANS1', 'NSSH1', 'SSH1', 'trans_respSANS2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_respSANS1', 'NSSH1', 'SSH1', 'trans_respSANS2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_respSANS1', 'NSSH1', 'SSH1', 'trans_respSANS2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_respSANS1', 'NSSH1', 'SSH1', 'trans_respSANS2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between pSANS-NSSH
rphace_pSANS_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_pSANS_NSSH" )
rphace_pSANS_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_pSANS_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHpSANS<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_pSANS")
raSSHpSANS<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_pSANS")
#rC
rcNSSHpSANS<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_pSANS")
rcSSHpSANS<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_pSANS")
#rE
reNSSHpSANS<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_pSANS")
reSSHpSANS<-mxAlgebra(expression=Re[3,1], name="rE_SSH_pSANS")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_pSANS_NSSH,rphace_pSANS_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHpSANS,raSSHpSANS,rcNSSHpSANS,rcSSHpSANS,reNSSHpSANS,reSSHpSANS)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_pSANS_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_pSANS_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_pSANS_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_pSANS_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_pSANS_NSSH, AceFit1),
mxEval(ACE.RphACE_pSANS_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_pSANS==MZ.rA_SSH_pSANS, name="rA_con"),
mxConstraint(MZ.rC_NSSH_pSANS==MZ.rC_SSH_pSANS, name="rC_con"),
mxConstraint(MZ.rE_NSSH_pSANS==MZ.rE_SSH_pSANS, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
# COMPARE MODELS: Print Comparative Fit Statistics
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_pSANS_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="pSANS", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="pSANS", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="pSANS", append=TRUE)cGRAND
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhgrndt1,pcbhgrndt2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cGRAND variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescGRAND1 <- residuals(lm(self_harm_data_c$pcbhgrndt1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescGRAND2 <- residuals(lm(self_harm_data_c$pcbhgrndt2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhgrndt1)
hist(self_harm_data_c$rescGRAND1)
describe(self_harm_data_c$rescGRAND1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescGRAND1 <-sqrt(self_harm_data_c$rescGRAND1+6.24)*2
self_harm_data_c$trans_rescGRAND2 <-sqrt(self_harm_data_c$rescGRAND2+6.24)*2
hist(self_harm_data_c$rescGRAND1)
hist(self_harm_data_c$trans_rescGRAND1)
describe(self_harm_data_c$trans_rescGRAND1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescGRAND1, self_harm_data_c$NSSH1)$correlations #-0.04
hetcor(self_harm_data_c$pcbhgrndt1, self_harm_data_c$NSSH1)$correlations #without covariates, -0.06
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cGRAND','NSSH', 'SSH')
selVars <-c('trans_rescGRAND1', 'NSSH1', 'SSH1', 'trans_rescGRAND2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescGRAND1', 'NSSH1', 'SSH1', 'trans_rescGRAND2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescGRAND1', 'NSSH1', 'SSH1', 'trans_rescGRAND2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescGRAND1', 'NSSH1', 'SSH1', 'trans_rescGRAND2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescGRAND1', 'NSSH1', 'SSH1', 'trans_rescGRAND2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cGRAND-NSSH
rphace_cGRAND_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cGRAND_NSSH" )
rphace_cGRAND_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cGRAND_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcGRAND<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cGRAND")
raSSHcGRAND<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cGRAND")
#rC
rcNSSHcGRAND<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cGRAND")
rcSSHcGRAND<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cGRAND")
#rE
reNSSHcGRAND<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cGRAND")
reSSHcGRAND<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cGRAND")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cGRAND_NSSH,rphace_cGRAND_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcGRAND,raSSHcGRAND,rcNSSHcGRAND,rcSSHcGRAND,reNSSHcGRAND,reSSHcGRAND)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cGRAND_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cGRAND_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cGRAND_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cGRAND_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cGRAND_NSSH, AceFit1),
mxEval(ACE.RphACE_cGRAND_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cGRAND==MZ.rA_SSH_cGRAND, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cGRAND==MZ.rC_SSH_cGRAND, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cGRAND==MZ.rE_SSH_cGRAND, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cGRAND_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cGRAND", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cGRAND", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cGRAND", append=TRUE)cTEPS
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
str(self_harm_data);class(self_harm_data)
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhtepst1,pcbhtepst2,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age1 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age2 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
str(self_harm_data_c)
#******************************************************
# Regress out age, sex and transform cTEPS variable
#******************************************************
#**Regressing out age & sex **#
self_harm_data_c$rescTEPS1 <- residuals(lm(self_harm_data_c$pcbhtepst1 ~ self_harm_data_c$age_161 + self_harm_data_c$sex1, na.action="na.exclude"))
self_harm_data_c$rescTEPS2 <- residuals(lm(self_harm_data_c$pcbhtepst2 ~ self_harm_data_c$age_162 + self_harm_data_c$sex2, na.action="na.exclude"))
hist(self_harm_data_c$pcbhtepst1)
hist(self_harm_data_c$rescTEPS1)
describe(self_harm_data_c$rescTEPS1)
# #transform the data to get a normal distribution
self_harm_data_c$trans_rescTEPS1 <-(self_harm_data_c$rescTEPS1)
self_harm_data_c$trans_rescTEPS2 <-(self_harm_data_c$rescTEPS2)
hist(self_harm_data_c$rescTEPS1)
hist(self_harm_data_c$trans_rescTEPS1)
describe(self_harm_data_c$trans_rescTEPS1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$trans_rescTEPS1, self_harm_data_c$NSSH1)$correlations #0.23
hetcor(self_harm_data_c$rescTEPS1, self_harm_data_c$NSSH1)$correlations #0.22
hetcor(self_harm_data_c$pcbhtepst1, self_harm_data_c$NSSH1)$correlations #without covariates, 0.25
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cTEPS','NSSH', 'SSH')
selVars <-c('trans_rescTEPS1', 'NSSH1', 'SSH1', 'trans_rescTEPS2', 'NSSH2', 'SSH2')
useVars <-c('trans_rescTEPS1', 'NSSH1', 'SSH1', 'trans_rescTEPS2', 'NSSH2', 'SSH2', 'age1', 'age2', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age1&age2) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-2 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
### Create starting values for covariance matrix
SHData_for_stv<-self_harm_data_c%>%
select('trans_rescTEPS1', 'NSSH1', 'SSH1', 'trans_rescTEPS2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(SHData_for_stv)
mzData_for_stv<-mzData%>%
select('trans_rescTEPS1', 'NSSH1', 'SSH1', 'trans_rescTEPS2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(mzData_for_stv)
dzData_for_stv<-dzData%>%
select('trans_rescTEPS1', 'NSSH1', 'SSH1', 'trans_rescTEPS2', 'NSSH2', 'SSH2')%>%
mutate_if(is.factor, as.numeric)
str(dzData_for_stv)
jiggle <-rnorm(nlower, mean = 0, sd = .1)
MZmean <-colMeans(mzData_for_stv,na.rm=TRUE)
DZmean <-colMeans(dzData_for_stv,na.rm=TRUE)
StMZmean<- c(mean(MZmean[c(1,4)]),0,0,mean(MZmean[c(1,4)]),0,0)
StDZmean<- c(mean(DZmean[c(1,4)]),0,0,mean(DZmean[c(1,4)]),0,0)
Stsd <-mean(sapply(mzData_for_stv[,c(1,4)],sd, na.rm=TRUE))
StWithinperson <-vechs(cor(SHData_for_stv[,1:3],use="pairwise"))
StBetweenMZ <-vech(cor(mzData_for_stv[,1:3],mzData_for_stv[,4:6],use="pairwise"))
StBetweenDZ <-vech(cor(dzData_for_stv[,1:3],dzData_for_stv[,4:6],use="pairwise"))
str(self_harm_data_c)
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
StTH <-c(-0.32,0.45,0.19,0.15,0.70,0.54,0.24,0.15)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','Tmz_21','imz_21','imz_22','imz_23') # THs for var 1 and 2 for a twin individual (mz)
LabCovA <-c('BageThNSSH', 'BageThNSSH','BageThNSSH', 'BageThNSSH', 'BageThSSH', 'BageThSSH','BageThSSH', 'BageThSSH')
LabCovS <-c('BsexThNSSH', 'BsexThNSSH','BsexThNSSH', 'BsexThNSSH', 'BsexThSSH', 'BsexThSSH','BsexThSSH', 'BsexThSSH')
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.64,0.25,0.14,0.72,0.62,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.30,0.15,0.19,0.01,0.01,0.01), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.84,0.03,0.12,0.67,0.50,0.42), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age1"), name="Age1")
obsAge2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age2"), name="Age2")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
betaA <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovA, name="BageTH" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=.2, labels=LabCovS, name="BsexTH" )
#mean and thresholds
Mean <-mxMatrix( "Full", 1, ntv, free=c(T,F,F,T,F,F), values=StMZmean, labels=c("m1", NA,NA, "m1", NA,NA), name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=T, values=StTH, lbound=c(-4,0.001,0.001,0.001), ubound=c(4,4),
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH%x%Age1 + BsexTH%x%Sex1,
Low%*%Th + BageTH%x%Age2 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[2,2]==1, name="L1" )
varL2 <- mxConstraint( expression=V[3,3]==1, name="L2" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cTEPS-NSSH
rphace_cTEPS_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cTEPS_NSSH" )
rphace_cTEPS_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cTEPS_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcTEPS<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cTEPS")
raSSHcTEPS<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cTEPS")
#rC
rcNSSHcTEPS<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cTEPS")
rcSSHcTEPS<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cTEPS")
#rE
reNSSHcTEPS<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cTEPS")
reSSHcTEPS<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cTEPS")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('NSSH1','SSH1','NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cTEPS_NSSH,rphace_cTEPS_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcTEPS,raSSHcTEPS,rcNSSHcTEPS,rcSSHcTEPS,reNSSHcTEPS,reSSHcTEPS)
modelMZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, name="MZ" )
modelDZ <- mxModel( pars, obsAge1, obsAge2, obsSex1, obsSex2 ,Mean, Tr, inc, Thres, betaA, betaS,
covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1) #
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2) #
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3) #
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4) #
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5) #
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6) #
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7) #
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #best fit -2lnL should be 40393.31
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T) #best fit -2lnL should be 40393.31
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T) #best fit -2lnL should be 40393.31
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T) #best fit -2lnL should be 40393.31
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T) #best fit -2lnL should be 40393.31
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T) #best fit -2lnL should be 40393.31
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T) #best fit -2lnL should be 40393.31
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cTEPS_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cTEPS_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cTEPS_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cTEPS_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cTEPS_NSSH, AceFit1),
mxEval(ACE.RphACE_cTEPS_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cTEPS==MZ.rA_SSH_cTEPS, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cTEPS==MZ.rC_SSH_cTEPS, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cTEPS==MZ.rE_SSH_cTEPS, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cTEPS_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cTEPS", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cTEPS", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cTEPS", append=TRUE)Substance abuse
cSMOK
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse);require(polycor)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
hetcor(self_harm_data$pcbhdrug121, self_harm_data$u1cslfh021)$correlations #0.12
hetcor(self_harm_data$pcbhdrug131, self_harm_data$u1cslfh021)$correlations #0.19
hetcor(self_harm_data$pcbhdrug151, self_harm_data$u1cslfh021)$correlations #0.18
table(self_harm_data$pcbhdrug131);table(self_harm_data$pcbhdrug151)
str(self_harm_data);class(self_harm_data)
plot(self_harm_data$pcbhdrug151) #how many times using cannabis - more normally distributed and makes more sense
#using this variable, but need to recode from "no" in previous question
plot(self_harm_data$pcbhdrug131) #how often using cannabis
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhdrug061, pcbhdrug062, pcbhdrug091,pcbhdrug092,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age_211 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age_212 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
hist(self_harm_data_c$u1cage1)
hist(self_harm_data_c$age_211)
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
hist(self_harm_data_c$pcbhage1)
hist(self_harm_data_c$age_161)
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$pcbhdrug121)
table(self_harm_data_c$pcbhdrug151)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
#bring zeros from never used cannabis into number of times using cannabis
self_harm_data_c <- mutate(self_harm_data_c, cSMOK1 = ifelse(is.na(pcbhdrug091)&pcbhdrug061==0,pcbhdrug061,pcbhdrug091))
self_harm_data_c <- mutate(self_harm_data_c, cSMOK2 = ifelse(is.na(pcbhdrug092)&pcbhdrug062==0,pcbhdrug062,pcbhdrug092))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
table(self_harm_data_c$pcbhdrug061)
table(self_harm_data_c$pcbhdrug062)
table(self_harm_data_c$pcbhdrug091)
table(self_harm_data_c$pcbhdrug092)
table(self_harm_data_c$cSMOK1)
table(self_harm_data_c$cSMOK2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
self_harm_data_c$cSMOK1<-mxFactor(self_harm_data_c$cSMOK1, levels=c(0:5) )
self_harm_data_c$cSMOK2<-mxFactor(self_harm_data_c$cSMOK2, levels=c(0:5) )
str(self_harm_data_c)
#check phenotypic correlation
hetcor(self_harm_data_c$cSMOK1, self_harm_data_c$NSSH1)$correlations #0.24
hetcor(self_harm_data_c$cSMOK1, self_harm_data_c$SSH1)$correlations # 0.26
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cSMOK','NSSH', 'SSH')
selVars <-c('cSMOK1', 'NSSH1', 'SSH1', 'cSMOK2', 'NSSH2', 'SSH2')
useVars <-c('cSMOK1', 'NSSH1', 'SSH1', 'cSMOK2', 'NSSH2', 'SSH2', 'age_161', 'age_162','age_211', 'age_212', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age_211&age_212) &!is.na(age_161&age_162) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age_211&age_212) &!is.na(age_161&age_162) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-3 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 5 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
# 2) Specify ACE Model
# To create Labels for Lower Triangular Matrices
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','imz_14',
'Tmz_21','imz_21','imz_22','imz_23','imz_24',
'Tmz_31','imz_31','imz_32','imz_33','imz_34') # THs for var 1 and 2 for a twin individual (mz)
LabCovA21 <-c(rep('BageThNULL21',5),rep('BageThNSSH21',4),'BageThNULL21',rep('BageThSSH21',4),'BageThNULL21')
LabCovA16 <-c(rep('BageThDRUG16',5),rep('BageThNULL16',5),rep('BageThNULL16',5))
LabCovS <-c(rep('BsexThDRUG',5),rep('BsexThNSSH',4),'BsexThNULL',rep('BsexThSSH',4),'BsexThNULL')
StTH <-c(6.17,0.52,0.27,0.27,0.27,
-0.20,0.45,0.19,0.15,0,
0.88,0.55,0.25,0.16, 0)
ThPatSH <-c(rep(T,5),rep(T,4),F,rep(T,4),F)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(1.0,0.19,0.23,0.68,0.58,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.74,0.18,0.19,0.002,0.002,0.005), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(4.43,0.09,0.08,0.67,0.56,0.43), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge211 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_211"), name="Age211")
obsAge212 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_212"), name="Age212")
obsAge161 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_161"), name="Age161")
obsAge162 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_162"), name="Age162")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
value_sex<-c(rep(0.2,5),rep(0.2,4),0,rep(0.2,4),0)
free_sex <-c(rep(T,5),rep(T,4),F,rep(T,4),F)
value_age16<-c(rep(0.2,5),rep(0,5),rep(0,5))
free_age16 <-c(rep(T,5),rep(F,5),rep(F,5))
value_age21<-c(rep(0,5),rep(0.2,4),0,rep(0.2,4),0)
free_age21 <-c(rep(F,5),rep(T,4),F,rep(T,4),F)
betaA21 <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_age21, values=value_age21, labels=LabCovA21, name="BageTH21" )
betaA16 <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_age16, values=value_age16, labels=LabCovA16, name="BageTH16" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_sex, values=value_sex, labels=LabCovS, name="BsexTH" )
#mean and thresholds, no mean if all variables are ordinals
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=ThPatSH, values=StTH, lbound=-4, ubound=100,
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH21%x%Age211+ BageTH16%x%Age161 + BsexTH%x%Sex1,
Low%*%Th + BageTH21%x%Age212+ BageTH16%x%Age162 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[1,1]==1, name="L1" )
varL2 <- mxConstraint( expression=V[2,2]==1, name="L2" )
varL3 <- mxConstraint( expression=V[3,3]==1, name="L3" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cSMOK-NSSH
rphace_cSMOK_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cSMOK_NSSH" )
rphace_cSMOK_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cSMOK_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcSMOK<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cSMOK")
raSSHcSMOK<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cSMOK")
#rC
rcNSSHcSMOK<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cSMOK")
rcSSHcSMOK<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cSMOK")
#rE
reNSSHcSMOK<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cSMOK")
reSSHcSMOK<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cSMOK")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('cSMOK1', 'NSSH1', 'SSH1', 'cSMOK2', 'NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('cSMOK1', 'NSSH1', 'SSH1', 'cSMOK2', 'NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cSMOK_NSSH,rphace_cSMOK_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcSMOK,raSSHcSMOK,rcNSSHcSMOK,rcSSHcSMOK,reNSSHcSMOK,reSSHcSMOK)
modelMZ <- mxModel( pars, obsAge211, obsAge212,obsAge161,obsAge162, obsSex1, obsSex2 , Mean, Tr, inc, Thres,
betaA21,betaA16, betaS, covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, varL3, name="MZ" )
modelDZ <- mxModel( pars, obsAge211, obsAge212,obsAge161,obsAge162, obsSex1, obsSex2 , Mean, Tr, inc, Thres,
betaA21,betaA16, betaS, covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1)
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2)
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3)
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4)
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5)
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6)
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7)
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #fit = 25519.628
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T)
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T)
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T)
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T)
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T)
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T)
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cSMOK_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cSMOK_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cSMOK_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cSMOK_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cSMOK_NSSH, AceFit1),
mxEval(ACE.RphACE_cSMOK_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cSMOK==MZ.rA_SSH_cSMOK, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cSMOK==MZ.rC_SSH_cSMOK, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cSMOK==MZ.rE_SSH_cSMOK, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cSMOK_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cSMOK", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cSMOK", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cSMOK", append=TRUE)cCANN
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse);require(polycor)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
hetcor(self_harm_data$pcbhdrug121, self_harm_data$u1cslfh021)$correlations #0.12
hetcor(self_harm_data$pcbhdrug131, self_harm_data$u1cslfh021)$correlations #0.19
hetcor(self_harm_data$pcbhdrug151, self_harm_data$u1cslfh021)$correlations #0.18
table(self_harm_data$pcbhdrug131);table(self_harm_data$pcbhdrug151)
str(self_harm_data);class(self_harm_data)
plot(self_harm_data$pcbhdrug151) #how many times using cannabis - more normally distributed and makes more sense
#using this variable, but need to recode from "no" in previous question
plot(self_harm_data$pcbhdrug131) #how often using cannabis
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhdrug121, pcbhdrug122, pcbhdrug151,pcbhdrug152,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age_211 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age_212 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$pcbhdrug121)
table(self_harm_data_c$pcbhdrug151)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
#bring zeros from never used cannabis into number of times using cannabis
self_harm_data_c <- mutate(self_harm_data_c, cCANN1 = ifelse(is.na(pcbhdrug151)&pcbhdrug121==0,pcbhdrug121,pcbhdrug151))
self_harm_data_c <- mutate(self_harm_data_c, cCANN2 = ifelse(is.na(pcbhdrug152)&pcbhdrug122==0,pcbhdrug122,pcbhdrug152))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
table(self_harm_data_c$pcbhdrug121)
table(self_harm_data_c$pcbhdrug122)
table(self_harm_data_c$pcbhdrug151)
table(self_harm_data_c$pcbhdrug152)
table(self_harm_data_c$cCANN1)
table(self_harm_data_c$cCANN2)
plot(self_harm_data_c$cCANN1)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
self_harm_data_c$cCANN1<-mxFactor(self_harm_data_c$cCANN1, levels=c(0:5) )
self_harm_data_c$cCANN2<-mxFactor(self_harm_data_c$cCANN2, levels=c(0:5) )
str(self_harm_data_c)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$cCANN1, self_harm_data_c$NSSH1)$correlations #0.23
hetcor(self_harm_data_c$cCANN1, self_harm_data_c$SSH1)$correlations #without covariates, 0.22
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
nv <- 3 # number of variables per twin
nvo <-3 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 5 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <-
vars <-c('cCANN','NSSH', 'SSH')
selVars <-c('cCANN1', 'NSSH1', 'SSH1', 'cCANN2', 'NSSH2', 'SSH2')
useVars <-c('cCANN1', 'NSSH1', 'SSH1', 'cCANN2', 'NSSH2', 'SSH2', 'age_211', 'age_212','age_161','age_162', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age_211&age_212) &!is.na(age_161&age_162) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age_211&age_212) &!is.na(age_161&age_162) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nth-1 #number of max increments
ncovariates <- 2 #number of covariates
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13','imz_14',
'Tmz_21','imz_21','imz_22','imz_23','imz_24',
'Tmz_31','imz_31','imz_32','imz_33','imz_34') # THs for var 1 and 2 for a twin individual (mz)
#LabCorMZ <-c('r21','rMZ1','MZxtxt','MZxtxt','rMZ2','r21')
LabThDZ <-c('Tmz_11','imz_11','imz_12','imz_13','imz_14',
'Tmz_21','imz_21','imz_22','imz_23','imz_24',
'Tmz_31','imz_31','imz_32','imz_33','imz_34') # THs for var 1 and 2 for a twin individual (mz)
#LabCorDZ <-c('r21','rDZ1','DZxtxt','DZxtxt','rDZ2','r21')
LabCovA21 <-c(rep('BageThNULL21',5),rep('BageThNSSH21',4),'BageThNULL21',rep('BageThSSH21',4),'BageThNULL21')
LabCovA16 <-c(rep('BageThDRUG16',5),rep('BageThNULL16',5),rep('BageThNULL16',5))
LabCovS <-c(rep('BsexThDRUG',5),rep('BsexThNSSH',4),'BsexThNULL',rep('BsexThSSH',4),'BsexThNULL')
StTH <-c(6.17,0.52,0.27,0.27,0.27,
-0.20,0.45,0.19,0.15,0,
0.88,0.55,0.25,0.16, 0)
ThPatSH <-c(rep(T,5),rep(T,4),F,rep(T,4),F)
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(1.0,0.19,0.23,0.68,0.58,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.74,0.18,0.19,0.002,0.002,0.005), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(4.43,0.09,0.08,0.67,0.56,0.43), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge211 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_211"), name="Age211")
obsAge212 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_212"), name="Age212")
obsAge161 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_161"), name="Age161")
obsAge162 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_162"), name="Age162")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
value_sex<-c(rep(0.2,5),rep(0.2,4),0,rep(0.2,4),0)
free_sex <-c(rep(T,5),rep(T,4),F,rep(T,4),F)
value_age16<-c(rep(0.2,5),rep(0,5),rep(0,5))
free_age16 <-c(rep(T,5),rep(F,5),rep(F,5))
value_age21<-c(rep(0,5),rep(0.2,4),0,rep(0.2,4),0)
free_age21 <-c(rep(F,5),rep(T,4),F,rep(T,4),F)
betaA21 <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_age21, values=value_age21, labels=LabCovA21, name="BageTH21" )
betaA16 <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_age16, values=value_age16, labels=LabCovA16, name="BageTH16" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_sex, values=value_sex, labels=LabCovS, name="BsexTH" )
#mean and thresholds, no mean if all variables are ordinals
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=ThPatSH, values=StTH, lbound=-4, ubound=100,
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH21%x%Age211+ BageTH16%x%Age161 + BsexTH%x%Sex1,
Low%*%Th + BageTH21%x%Age212+ BageTH16%x%Age162 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[1,1]==1, name="L1" )
varL2 <- mxConstraint( expression=V[2,2]==1, name="L2" )
varL3 <- mxConstraint( expression=V[3,3]==1, name="L3" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cCANN-NSSH
rphace_cCANN_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cCANN_NSSH" )
rphace_cCANN_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cCANN_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcCANN<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cCANN")
raSSHcCANN<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cCANN")
#rC
rcNSSHcCANN<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cCANN")
rcSSHcCANN<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cCANN")
#rE
reNSSHcCANN<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cCANN")
reSSHcCANN<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cCANN")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('cCANN1', 'NSSH1', 'SSH1', 'cCANN2', 'NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('cCANN1', 'NSSH1', 'SSH1', 'cCANN2', 'NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cCANN_NSSH,rphace_cCANN_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcCANN,raSSHcCANN,rcNSSHcCANN,rcSSHcCANN,reNSSHcCANN,reSSHcCANN)
modelMZ <- mxModel( pars, obsAge211, obsAge212,obsAge161,obsAge162, obsSex1, obsSex2 , Mean, Tr, inc, Thres,
betaA21,betaA16, betaS, covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, varL3, name="MZ" )
modelDZ <- mxModel( pars, obsAge211, obsAge212,obsAge161,obsAge162, obsSex1, obsSex2 , Mean, Tr, inc, Thres,
betaA21,betaA16, betaS, covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]')
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1)
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2)
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3)
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4)
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5)
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6)
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7)
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T) #fit = 25519.628
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T)
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T)
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T)
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T)
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T)
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T)
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit1)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit1)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cCANN_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cCANN_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cCANN_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cCANN_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cCANN_NSSH, AceFit1),
mxEval(ACE.RphACE_cCANN_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cCANN==MZ.rA_SSH_cCANN, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cCANN==MZ.rC_SSH_cCANN, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cCANN==MZ.rE_SSH_cCANN, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cCANN_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cCANN", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cCANN", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cCANN", append=TRUE)cALC
rm(list=ls())
Sys.setenv(OMP_NUM_THREADS=parallel::detectCores()) #this has to be before loading the library OpenMx
require(OpenMx);require(psych);require(foreign);require(tidyverse);require(polycor)
mxOption(NULL, "Default optimizer", "SLSQP") # SLSQP is a better optimizer for ordinal data
self_harm_data=read.spss("427 Kai Lim self harm 250919.sav",verbose=T,to.data.frame = T)
hetcor(self_harm_data$pcbhdrug121, self_harm_data$u1cslfh021)$correlations #0.12
hetcor(self_harm_data$pcbhdrug131, self_harm_data$u1cslfh021)$correlations #0.19
hetcor(self_harm_data$pcbhdrug151, self_harm_data$u1cslfh021)$correlations #0.18
table(self_harm_data$pcbhdrug131);table(self_harm_data$pcbhdrug151)
str(self_harm_data);class(self_harm_data)
plot(self_harm_data$pcbhdrug151) #how many times using cannabis - more normally distributed and makes more sense
#using this variable, but need to recode from "no" in previous question
plot(self_harm_data$pcbhdrug131) #how often using cannabis
self_harm_data_c<-self_harm_data %>%
filter(exclude1==0 & exclude2 ==0)%>% #exclude those with medical conditions etc
select(randomfamid,randomtwinid,u1cslfh021,u1cslfh022,u1cslfh031,u1cslfh032,u1cslfh041,u1cslfh042,pcbhdrug011, pcbhdrug012, pcbhdrug051,pcbhdrug052,x3zygos,u1cage1,u1cage2,pcbhage1,pcbhage2, sex1,sex2, random)%>%
mutate_if(is.factor, as.numeric) #import as numeric values for all columns
#fill in co-twin's age as proxy
self_harm_data_c <- mutate(self_harm_data_c, age_211 = ifelse(is.na(u1cage1),u1cage2 , u1cage1))
self_harm_data_c <- mutate(self_harm_data_c, age_212 = ifelse(is.na(u1cage2),u1cage1 , u1cage2))
hist(self_harm_data_c$u1cage1)
hist(self_harm_data_c$age_211)
self_harm_data_c <- mutate(self_harm_data_c, age_161 = ifelse(is.na(pcbhage1),pcbhage2 , pcbhage1))
self_harm_data_c <- mutate(self_harm_data_c, age_162 = ifelse(is.na(pcbhage2),pcbhage1 , pcbhage2))
hist(self_harm_data_c$pcbhage1)
hist(self_harm_data_c$age_161)
#recode so that no="0"
self_harm_data_c$u1cslfh021=self_harm_data_c$u1cslfh021-1
self_harm_data_c$u1cslfh022=self_harm_data_c$u1cslfh022-1
self_harm_data_c$u1cslfh031=self_harm_data_c$u1cslfh031-1
self_harm_data_c$u1cslfh032=self_harm_data_c$u1cslfh032-1
self_harm_data_c$u1cslfh041=self_harm_data_c$u1cslfh041-1
self_harm_data_c$u1cslfh042=self_harm_data_c$u1cslfh042-1
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$pcbhdrug011)
table(self_harm_data_c$pcbhdrug051)
#bring zeros from SH question into NSSH and SSH.
self_harm_data_c <- mutate(self_harm_data_c, NSSH1 = ifelse(is.na(u1cslfh031)&u1cslfh021==0,u1cslfh021,u1cslfh031))
self_harm_data_c <- mutate(self_harm_data_c, NSSH2 = ifelse(is.na(u1cslfh032)&u1cslfh022==0,u1cslfh022,u1cslfh032))
self_harm_data_c <- mutate(self_harm_data_c, SSH1 = ifelse(is.na(u1cslfh041)&u1cslfh021==0,u1cslfh021,u1cslfh041))
self_harm_data_c <- mutate(self_harm_data_c, SSH2 = ifelse(is.na(u1cslfh042)&u1cslfh022==0,u1cslfh022,u1cslfh042))
#bring zeros from never used cannabis into number of times using cannabis
#recode so that no="0"
self_harm_data_c$pcbhdrug051<-self_harm_data_c$pcbhdrug051-1
self_harm_data_c$pcbhdrug052<-self_harm_data_c$pcbhdrug052-1
table(self_harm_data_c$pcbhdrug052);table(self_harm_data_c$pcbhdrug051)
self_harm_data_c <- mutate(self_harm_data_c, cALC1 = ifelse(is.na(pcbhdrug051)&pcbhdrug011==0,pcbhdrug011,pcbhdrug051))
self_harm_data_c <- mutate(self_harm_data_c, cALC2 = ifelse(is.na(pcbhdrug052)&pcbhdrug012==0,pcbhdrug012,pcbhdrug052))
table(self_harm_data_c$u1cslfh021)
table(self_harm_data_c$u1cslfh022)
table(self_harm_data_c$u1cslfh031)
table(self_harm_data_c$u1cslfh032)
table(self_harm_data_c$NSSH1)
table(self_harm_data_c$NSSH2)
table(self_harm_data_c$u1cslfh041)
table(self_harm_data_c$u1cslfh042)
table(self_harm_data_c$SSH1)
table(self_harm_data_c$SSH2)
table(self_harm_data_c$pcbhdrug011)
table(self_harm_data_c$pcbhdrug012)
table(self_harm_data_c$pcbhdrug051)
table(self_harm_data_c$pcbhdrug052)
table(self_harm_data_c$cALC1)
table(self_harm_data_c$cALC2)
head(self_harm_data_c)
dim(self_harm_data);dim(self_harm_data_c)
#Make the integer variables ordered factors
self_harm_data_c$NSSH1<-mxFactor(self_harm_data_c$NSSH1, levels=c(0:4) )
self_harm_data_c$NSSH2<-mxFactor(self_harm_data_c$NSSH2, levels=c(0:4) )
self_harm_data_c$SSH1<-mxFactor(self_harm_data_c$SSH1, levels=c(0:4) )
self_harm_data_c$SSH2<-mxFactor(self_harm_data_c$SSH2, levels=c(0:4) )
self_harm_data_c$cALC1<-mxFactor(self_harm_data_c$cALC1, levels=c(0:4) )
self_harm_data_c$cALC2<-mxFactor(self_harm_data_c$cALC2, levels=c(0:4) )
str(self_harm_data_c)
plot(self_harm_data_c$cALC1)
plot(self_harm_data_c$NSSH1)
library(polycor) #check phenotypic correlation
hetcor(self_harm_data_c$pcbhdrug011, self_harm_data_c$NSSH1)$correlations #0.05
hetcor(self_harm_data_c$pcbhdrug011, self_harm_data_c$SSH1)$correlations #0.02
hetcor(self_harm_data_c$cALC1, self_harm_data_c$NSSH1)$correlations #0.12
hetcor(self_harm_data_c$cALC1, self_harm_data_c$SSH1)$correlations #without covariates, 0.14
hetcor(self_harm_data_c$SSH1, self_harm_data_c$NSSH1)$correlations # 0.87, same as in other less complex models.
vars <-c('cALC','NSSH', 'SSH')
selVars <-c('cALC1', 'NSSH1', 'SSH1', 'cALC2', 'NSSH2', 'SSH2')
useVars <-c('cALC1', 'NSSH1', 'SSH1', 'cALC2', 'NSSH2', 'SSH2', 'age_161', 'age_162','age_211', 'age_212', 'sex1','sex2')
# Select Data for Analysis
mzData <- subset(self_harm_data_c, x3zygos==1 & random==1 & !is.na(age_211&age_212) &!is.na(age_161&age_162) &!is.na(sex1&sex2), useVars) #select only one twin from each pair because of double entry method
dzData <- subset(self_harm_data_c, x3zygos!=1 & random==1 & !is.na(age_211&age_212) &!is.na(age_161&age_162) &!is.na(sex1&sex2), useVars)
describe(mzData)
describe(dzData)
nv <- 3 # number of variables per twin
nvo <-3 #number of ordinal variables per twin
nvc <-nv-nvo #number of continuous variables per twin
poso <- nvc+1 #position where ordinal variables start
ntv <- nv*2 # number of variables per pair
nth <- 4 # number of max thresholds
nlower <- ntv*(ntv+1)/2 # number of free elements in a lower matrix ntv*ntv
ncor <-(nv*(nv+1)/2)-nv # number of free elements in a correlation matrix nv*nv
ninc <- nth-1 #number of max increments
ncovariates <- 2 #number of covariates
# 1) Fits a constrained Polychoric correlation model to answer reviewer's comments
# TH same across twins and across zyg groups
# Age effect is different acros variables, but same across thresholds within variables (if c>2)
# There is one overall rPH between var1-2 and the x-trait x-twin correlations are symmetric
#
# CREATE LABELS & START VALUES as objects(to ease specification)
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13',
'Tmz_21','imz_21','imz_22','imz_23',
'Tmz_31','imz_31','imz_32','imz_33') # THs for var 1 and 2 for a twin individual (mz)
#LabCorMZ <-c('r21','rMZ1','MZxtxt','MZxtxt','rMZ2','r21')
LabThDZ <-c('Tmz_11','imz_11','imz_12','imz_13','imz_14',
'Tmz_21','imz_21','imz_22','imz_23','imz_24',
'Tmz_31','imz_31','imz_32','imz_33','imz_34') # THs for var 1 and 2 for a twin individual (mz)
#LabCorDZ <-c('r21','rDZ1','DZxtxt','DZxtxt','rDZ2','r21')
LabCovA21 <-c(rep('BageThNULL21',4),rep('BageThNSSH21',4),rep('BageThSSH21',4))
LabCovA16 <-c(rep('BageThDRUG16',4),rep('BageThNULL16',4),rep('BageThNULL16',4))
LabCovS <-c(rep('BsexThDRUG',4),rep('BsexThNSSH',4),rep('BsexThSSH',4))
# Create Lables for a Correlation Matrix
rphLabs <- paste("r",1:ncor,sep="")
# Create Labels for Lower Triangular Matrices
MZbLabs <- paste("mz", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
DZbLabs <- paste("dz", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
(PatSD <- c( rep(T,nvc), rep(F, nvo)))
ThPatSH <-c(rep(T,4),rep(T,4),rep(T,4))
#StCorMZ <-c(.2, .4, .25, .25, .20, .2)
#StCorDZ <-c(.2, .1, .10, .10, .02, .2)
StTH <-c(6.17,0.52,0.27,0.27,
-0.20,0.45,0.19,0.15,
0.88,0.55,0.25,0.16)
#
# # Define definition variables to hold the Covariates
#
obsAge211 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_211"), name="Age211")
obsAge212 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_212"), name="Age212")
obsAge161 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_161"), name="Age161")
obsAge162 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_162"), name="Age162")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
# Matrix & Algebra for expected means (SND), Thresholds, effect of Age on Th and correlations
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="M" )
#effect of age and sex on ordinal variable
value_sex<-c(rep(0.2,4),rep(0.2,4),rep(0.2,4))
free_sex <-c(rep(T,4),rep(T,4),rep(T,4))
value_age16<-c(rep(0.2,4),rep(0,4),rep(0,4))
free_age16 <-c(rep(T,4),rep(F,4),rep(F,4))
value_age21<-c(rep(0,4),rep(0.2,4),rep(0.2,4))
free_age21 <-c(rep(F,4),rep(T,4),rep(T,4))
betaA21 <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_age21, values=value_age21, labels=LabCovA21, name="BageTH21" )
betaA16 <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_age16, values=value_age16, labels=LabCovA16, name="BageTH16" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_sex, values=value_sex, labels=LabCovS, name="BsexTH" )
#thresholds
Tmz <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=ThPatSH, values=StTH, lbound=-4, ubound=10,
labels=LabThMZ, name="ThMZ")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
ThresMZ <-mxAlgebra( expression= cbind(Low%*%ThMZ + BageTH21%x%Age211+ BageTH16%x%Age161 + BsexTH%x%Sex1,
Low%*%ThMZ + BageTH21%x%Age212+ BageTH16%x%Age162 + BsexTH%x%Sex2),
name="expThresMZ")
Tdz <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=ThPatSH, values=StTH, lbound=-4, ubound=10,
labels=LabThMZ, name="ThDZ")
ThresDZ <-mxAlgebra( expression= cbind(Low%*%ThDZ + BageTH21%x%Age211+ BageTH16%x%Age161 + BsexTH%x%Sex1,
Low%*%ThDZ + BageTH21%x%Age212+ BageTH16%x%Age162 + BsexTH%x%Sex2),
name="expThresDZ")
# # elements for the correlations
#SD
SD <-mxMatrix( type="Diag", nrow=ntv, ncol=ntv, free=c(PatSD,PatSD),
values=c(1,1,1,1,1,1), name="sd")
Rph <-mxMatrix("Stand", nv, nv, free = TRUE, values = StWithinperson, labels=rphLabs, name="within")
MZb <-mxMatrix("Symm", nv, nv, free = TRUE, values = StBetweenMZ, labels=MZbLabs, name="BetweenMZ")
DZb <-mxMatrix("Symm", nv, nv, free = TRUE, values = StBetweenDZ, labels=DZbLabs, name="BetweenDZ")
CorMZ <-mxAlgebra(rbind(cbind(within,BetweenMZ), cbind(BetweenMZ, within)), name="expCorMZ")
CorDZ <-mxAlgebra(rbind(cbind(within,BetweenDZ), cbind(BetweenDZ, within)), name="expCorDZ")
# Matrices for the Covariance model
CovMZ <-mxAlgebra( expression=sd %*% expCorMZ %*% t(sd), name="ExpCovMZ" )
CovDZ <-mxAlgebra( expression=sd %*% expCorDZ %*% t(sd), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="M", dimnames=selVars, thresholds="expThresMZ")
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="M", dimnames=selVars, thresholds="expThresDZ")
fitFunction <- mxFitFunctionML()
# Combine Groups
modelMZ <- mxModel( obsAge211, obsAge212, obsAge161,obsAge162,
obsSex1, obsSex2, Mean, betaA21,betaA16, betaS,
Tmz, inc, ThresMZ, SD, Rph, MZb, CovMZ, CorMZ, dataMZ, objMZ, fitFunction, name="MZ" )
modelDZ <- mxModel( obsAge211, obsAge212, obsAge161,obsAge162,
obsSex1, obsSex2, Mean, betaA21,betaA16, betaS,
Tdz, inc, ThresDZ, SD, Rph, DZb, CovDZ, CorDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
Conf1 <- mxCI (c ('MZ.expCorMZ','DZ.expCorDZ') )
Conf2 <- mxCI(c('MZ.BageTH21','MZ.BsexTH'))
SatModel <- mxModel( "Sat", modelMZ, modelDZ, minus2ll, obj, Conf1, Conf2 )
# 1) RUN concor Model
SatFit <- mxTryHardOrdinal(SatModel, intervals=T)
(SatSumm <- summary(SatFit,verbose=T))
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cALC_SLSQP_Cor_26_Nov_2020.RData")
# 2) Specify ACE Model, with ONE overall set of Means, ONE overall Threshold on IQ liability
# To create Labels for Lower Triangular Matrices
LabThMZ <-c('Tmz_11','imz_11','imz_12','imz_13',
'Tmz_21','imz_21','imz_22','imz_23',
'Tmz_31','imz_31','imz_32','imz_33') # THs for var 1 and 2 for a twin individual (mz)
#LabCorMZ <-c('r21','rMZ1','MZxtxt','MZxtxt','rMZ2','r21')
LabThDZ <-c('Tmz_11','imz_11','imz_12','imz_13',
'Tmz_21','imz_21','imz_22','imz_23',
'Tmz_31','imz_31','imz_32','imz_33') # THs for var 1 and 2 for a twin individual (mz)
#LabCorDZ <-c('r21','rDZ1','DZxtxt','DZxtxt','rDZ2','r21')
LabCovA21 <-c(rep('BageThNULL21',4),rep('BageThNSSH21',4),rep('BageThSSH21',4))
LabCovA16 <-c(rep('BageThDRUG16',4),rep('BageThNULL16',4),rep('BageThNULL16',4))
LabCovS <-c(rep('BsexThDRUG',4),rep('BsexThNSSH',4),rep('BsexThSSH',4))
StTH <-c(6.17,0.52,0.27,0.27,
-0.20,0.45,0.19,0.15,
0.88,0.55,0.25,0.16)
ThPatSH <-c(rep(T,4),rep(T,4),rep(T,4))
aLabs <- paste("a", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
cLabs <- paste("c", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
eLabs <- paste("e", do.call(c, sapply(seq(1, nv), function(x){ paste(x:nv, x,sep="") })), sep="")
# Matrices to store a, c, and e Path Coefficients
pathA <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(1.0,0.19,0.23,0.68,0.58,0.23), labels=aLabs, name="a" )
pathC <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(0.74,0.18,0.19,0.002,0.002,0.005), labels=cLabs, name="c" )
pathE <- mxMatrix( type="Lower", nrow=nv, ncol=nv, free=TRUE, values=c(4.43,0.09,0.08,0.67,0.56,0.43), labels=eLabs, name="e" )
# # Define definition variables to hold the Covariates
obsAge211 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_211"), name="Age211")
obsAge212 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_212"), name="Age212")
obsAge161 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_161"), name="Age161")
obsAge162 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.age_162"), name="Age162")
obsSex1 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex1"), name="Sex1")
obsSex2 <- mxMatrix( type="Full", nrow=1, ncol=1, free=F, labels=c("data.sex2"), name="Sex2")
#effect of age and sex on ordinal variable
value_sex<-c(rep(0.2,4),rep(0.2,4),rep(0.2,4))
free_sex <-c(rep(T,4),rep(T,4),rep(T,4))
value_age16<-c(rep(0.2,4),rep(0,4),rep(0,4))
free_age16 <-c(rep(T,4),rep(F,4),rep(F,4))
value_age21<-c(rep(0,4),rep(0.2,4),rep(0.2,4))
free_age21 <-c(rep(F,4),rep(T,4),rep(T,4))
betaA21 <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_age21, values=value_age21, labels=LabCovA21, name="BageTH21" )
betaA16 <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_age16, values=value_age16, labels=LabCovA16, name="BageTH16" )
betaS <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=free_sex, values=value_sex, labels=LabCovS, name="BsexTH" )
#mean and thresholds, no mean if all variables are ordinals
Mean <-mxMatrix( type="Zero", nrow=1, ncol=ntv, name="ExpMean" )
Tr <-mxMatrix( type="Full", nrow=nth, ncol=nvo, free=ThPatSH, values=StTH, lbound=-4, ubound=100,
labels=LabThMZ, name="Th")
inc <-mxMatrix( type="Lower",nrow=nth, ncol=nth, free=F, values=1, name="Low")
Thres <-mxAlgebra( expression= cbind(Low%*%Th + BageTH21%x%Age211+ BageTH16%x%Age161 + BsexTH%x%Sex1,
Low%*%Th + BageTH21%x%Age212+ BageTH16%x%Age162 + BsexTH%x%Sex2),
name="ExpThres")
# Matrices generated to hold A, C, and E computed Variance Components
covA <- mxAlgebra( expression=a %*% t(a), name="A" )
covC <- mxAlgebra( expression=c %*% t(c), name="C" )
covE <- mxAlgebra( expression=e %*% t(e), name="E" )
# Algebra to compute standardized variance components
covP <- mxAlgebra( expression=A+C+E, name="V" )
StA <- mxAlgebra( expression=A/V, name="h2")
StC <- mxAlgebra( expression=C/V, name="c2")
StE <- mxAlgebra( expression=E/V, name="e2")
# Algebra to compute Phenotypic, A, C & E correlations
matI <- mxMatrix( type="Iden", nrow=nv, ncol=nv, name="I")
rph <- mxAlgebra( expression= solve(sqrt(I*V)) %*% V %*% solve(sqrt(I*V)), name="Rph")
rA <- mxAlgebra( expression= solve(sqrt(I*A)) %*% A %*% solve(sqrt(I*A)), name="Ra" )
rC <- mxAlgebra( expression= solve(sqrt(I*C)) %*% C %*% solve(sqrt(I*C)), name="Rc" )
rE <- mxAlgebra( expression= solve(sqrt(I*E)) %*% E %*% solve(sqrt(I*E)), name="Re" )
# Constraint on total variance of Ordinal variable (A+C+E=1)
varL1 <- mxConstraint( expression=V[1,1]==1, name="L1" )
varL2 <- mxConstraint( expression=V[2,2]==1, name="L2" )
varL3 <- mxConstraint( expression=V[3,3]==1, name="L3" )
# Algebra to compute Rph-A, Rph-C & Rph-E between cALC-NSSH
rphace_cALC_NSSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[2,1]*sqrt(h2[2,2])),
(sqrt(c2[1,1])*Rc[2,1]*sqrt(c2[2,2])),
(sqrt(e2[1,1])*Re[2,1]*sqrt(e2[2,2])) ), name="RphACE_cALC_NSSH" )
rphace_cALC_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[1,1])*Ra[3,1]*sqrt(h2[3,3])),
(sqrt(c2[1,1])*Rc[3,1]*sqrt(c2[3,3])),
(sqrt(e2[1,1])*Re[3,1]*sqrt(e2[3,3])) ), name="RphACE_cALC_SSH" )
rphace_NSSH_SSH <- mxAlgebra( expression= cbind ( (sqrt(h2[2,2])*Ra[3,2]*sqrt(h2[3,3])),
(sqrt(c2[2,2])*Rc[3,2]*sqrt(c2[3,3])),
(sqrt(e2[2,2])*Re[3,2]*sqrt(e2[3,3])) ), name="RphACE_NSSH_SSH" )
# Algebra's needed for picking out elements from Cov models (used later for equality constraints)
sqrt_path_a<-mxAlgebra(expression=sqrt(h2), name="path_a")
NSSH_h2 <-mxAlgebra( expression= path_a[2,2], name="NSSH_a")
SSH_h2 <-mxAlgebra( expression= path_a[3,3], name="SSH_a")
sqrt_path_c<-mxAlgebra(expression=sqrt(c2), name="path_c")
NSSH_c2 <-mxAlgebra( expression= path_c[2,2], name="NSSH_c")
SSH_c2 <-mxAlgebra( expression= path_c[3,3], name="SSH_c")
sqrt_path_e<-mxAlgebra(expression=sqrt(e2), name="path_e")
NSSH_e2 <-mxAlgebra( expression= path_e[2,2], name="NSSH_e")
SSH_e2 <-mxAlgebra( expression= path_e[3,3], name="SSH_e")
#rA
raNSSHcALC<-mxAlgebra(expression=Ra[2,1], name="rA_NSSH_cALC")
raSSHcALC<-mxAlgebra(expression=Ra[3,1], name="rA_SSH_cALC")
#rC
rcNSSHcALC<-mxAlgebra(expression=Rc[2,1], name="rC_NSSH_cALC")
rcSSHcALC<-mxAlgebra(expression=Rc[3,1], name="rC_SSH_cALC")
#rE
reNSSHcALC<-mxAlgebra(expression=Re[2,1], name="rE_NSSH_cALC")
reSSHcALC<-mxAlgebra(expression=Re[3,1], name="rE_SSH_cALC")
# Algebra for expected Variance/Covariance Matrices in MZ & DZ twins
covMZ <- mxAlgebra( expression= rbind( cbind(A+C+E , A+C),
cbind(A+C , A+C+E)), name="ExpCovMZ" )
covDZ <- mxAlgebra( expression= rbind( cbind(A+C+E , 0.5%x%A+C),
cbind(0.5%x%A+C , A+C+E)), name="ExpCovDZ" )
# Data objects for Multiple Groups
dataMZ <- mxData( observed=mzData, type="raw" )
dataDZ <- mxData( observed=dzData, type="raw" )
# Objective objects for Multiple Groups
objMZ <- mxExpectationNormal( covariance="ExpCovMZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('cALC1', 'NSSH1', 'SSH1', 'cALC2', 'NSSH2', 'SSH2') )
objDZ <- mxExpectationNormal( covariance="ExpCovDZ", means="ExpMean", dimnames=selVars, thresholds="ExpThres", threshnames=c('cALC1', 'NSSH1', 'SSH1', 'cALC2', 'NSSH2', 'SSH2') )
fitFunction <- mxFitFunctionML()
# Combine Groups
pars <- list( pathA, pathC, pathE, covA, covC, covE, covP, StA, StC, StE, matI, rph, rA, rC, rE,
rphace_cALC_NSSH,rphace_cALC_SSH,rphace_NSSH_SSH,
sqrt_path_a, NSSH_h2, SSH_h2,
sqrt_path_c, NSSH_c2, SSH_c2,
sqrt_path_e, NSSH_e2, SSH_e2,
raNSSHcALC,raSSHcALC,rcNSSHcALC,rcSSHcALC,reNSSHcALC,reSSHcALC)
modelMZ <- mxModel( pars, obsAge211, obsAge212,obsAge161,obsAge162, obsSex1, obsSex2 , Mean, Tr, inc, Thres,
betaA21,betaA16, betaS, covMZ, dataMZ, objMZ, fitFunction, varL1, varL2, varL3, name="MZ" )
modelDZ <- mxModel( pars, obsAge211, obsAge212,obsAge161,obsAge162, obsSex1, obsSex2 , Mean, Tr, inc, Thres,
betaA21,betaA16, betaS, covDZ, dataDZ, objDZ, fitFunction, name="DZ" )
minus2ll <- mxAlgebra( expression=MZ.objective + DZ.objective, name="m2LL" )
obj <- mxFitFunctionAlgebra( "m2LL" )
#confidence intervals
Conf1 <- mxCI (c('Rph[2,1]','Rph[3,1]'))
Conf2 <- mxCI ('Ra[2,1]') #
Conf3 <- mxCI ('Ra[3,1]')
Conf4 <- mxCI ('Rc[2,1]')
Conf5 <- mxCI ('Rc[3,1]')
Conf6 <- mxCI ('Re[2,1]')
Conf7 <- mxCI ('Re[3,1]')
AceModel1 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf1)
AceModel2 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf2)
AceModel3 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf3)
AceModel4 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf4)
AceModel5 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf5)
AceModel6 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf6)
AceModel7 <- mxModel( "ACE", pars, modelMZ, modelDZ, minus2ll, obj, Conf7)
# 3) RUN AceModel
AceFit1 <- mxTryHardOrdinal(AceModel1, intervals=T)
AceFit2 <- mxTryHardOrdinal(AceModel2, intervals=T)
AceFit3 <- mxTryHardOrdinal(AceModel3, intervals=T)
AceFit4 <- mxTryHardOrdinal(AceModel4, intervals=T)
AceFit5 <- mxTryHardOrdinal(AceModel5, intervals=T)
AceFit6 <- mxTryHardOrdinal(AceModel6, intervals=T)
AceFit7 <- mxTryHardOrdinal(AceModel7, intervals=T)
(AceSum1 <- summary(AceFit1,verbose=T))
(AceSum2 <- summary(AceFit2,verbose=T))
(AceSum3 <- summary(AceFit3,verbose=T))
(AceSum4 <- summary(AceFit4,verbose=T))
(AceSum5 <- summary(AceFit5,verbose=T))
(AceSum6 <- summary(AceFit6,verbose=T))
(AceSum7 <- summary(AceFit7,verbose=T))
#get the estimates and CIs
CI1 <- AceSum1$CI
CI2 <- AceSum2$CI
CI3 <- AceSum3$CI
CI4 <- AceSum4$CI
CI5 <- AceSum5$CI
CI6 <- AceSum6$CI
CI7 <- AceSum7$CI
tot_CI<-rbind(CI1,CI2,CI3,CI4,CI5,CI6,CI7)
#evaluate the contents
mxEval(MZ.ExpCovMZ, AceFit1)
mxEval(DZ.ExpCovDZ, AceFit3)
mxEval(ACE.RphACE_cALC_SSH, AceFit7)
mxEval(ACE.h2, AceFit1)
mxEval(ACE.c2, AceFit1)
mxEval(ACE.e2, AceFit1)
mxEval(ACE.Ra, AceFit5)
mxEval(ACE.Rc, AceFit1)
mxEval(ACE.Re, AceFit1)
mxEval(ACE.Rph, AceFit1)
mxEval(ACE.RphACE_cALC_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1]*100
mxEval(ACE.RphACE_cALC_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1]*100
mxEval(ACE.V,AceFit1)
mxEval(ACE.RphACE_cALC_SSH, AceFit6)
#get the proportion explained by A,C and E in the phenotypic correlation
proportion<-as.data.frame(rbind((mxEval(ACE.RphACE_cALC_NSSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[2,1])*100,
(mxEval(ACE.RphACE_cALC_SSH, AceFit1)/mxEval(ACE.Rph, AceFit1)[3,1])*100,
mxEval(ACE.RphACE_cALC_NSSH, AceFit1),
mxEval(ACE.RphACE_cALC_SSH, AceFit1)),
row.names=c("NSSH%","SSH%", "NSSH","SSH"))
colnames(proportion)<-c("A","C","E")
proportion
#constrain the model
Sub1Model <- mxModel(AceModel1, name="sub1",
mxConstraint(MZ.rA_NSSH_cALC==MZ.rA_SSH_cALC, name="rA_con"),
mxConstraint(MZ.rC_NSSH_cALC==MZ.rC_SSH_cALC, name="rC_con"),
mxConstraint(MZ.rE_NSSH_cALC==MZ.rE_SSH_cALC, name="rE_con"))
Sub1Fit <- mxTryHardOrdinal(Sub1Model, intervals = F)
(Sub1Sum <- summary(Sub1Fit))
mxEval(MZ.NSSH_a,Sub1Fit);mxEval(MZ.SSH_a,Sub1Fit)
mxEval(MZ.NSSH_c,Sub1Fit);mxEval(MZ.SSH_c,Sub1Fit)
mxEval(MZ.NSSH_e,Sub1Fit);mxEval(MZ.SSH_e,Sub1Fit)
mxEval(MZ.path_a,Sub1Fit);mxEval(MZ.path_c,Sub1Fit);mxEval(MZ.path_e,Sub1Fit)
mxEval(MZ.Ra,Sub1Fit);mxEval(MZ.Rc,Sub1Fit);mxEval(MZ.Re,Sub1Fit)
mxEval(MZ.h2,Sub1Fit)
### compare with ACE model
comparison <- mxCompare(AceFit1,Sub1Fit)
library(xlsx)
## 6) save the results
setwd("../results")
save.image(file="Tri_LT_NSSH_SSH_cALC_SLSQP_ACE_04_June_2020.RData")
# save the estimates and their confidence intervals
write.xlsx(tot_CI, file="trivariate_estimates_with_CI_04_June_2020.xlsx",
sheetName="cALC", append=TRUE)
# save the proportions
write.xlsx(proportion, file="trivariate_proportion_04_June_2020.xlsx",
sheetName="cALC", append=TRUE)
# save the results of the chi-square test
write.xlsx(comparison, file="trivariate_constrained_results_04_June_2020.xlsx",
sheetName="cALC", append=TRUE)Table S7: Phenotypic correlations in trivariate models
Code to compile phenotypic correlations between each measure with NSSH and SSH in the trivariate ACE models, and the contributions of A, C and E to the correlations
#make table for supp materials
#phenotypic correlations
#load packages
library(tidyverse)
library(fs)
library(readxl)
library(ggforce)
library(patchwork)
library(viridis)
library(colortools)
library(plyr)
library(drlib)
specify_decimal <- function(x, k) trimws(format(round(x, k), nsmall=k))
path<-"/Users/kai/OneDrive - King's College London/PhD/TEDS_project/results/14_reanalyses_trivariate/trivariate_proportion_16_June_2020.xlsx"
prop <- path %>%
excel_sheets() %>%
set_names() %>%
map_df(read_excel,
path = path,
.id = "trait") #id = column name for the sheet name as column values
prop2<-as.data.frame(prop)
prop2$phenocor=prop2$A+prop2$C+prop2$E
colnames(prop2)<-c( "trait","selfharm","A","C","E","phenotypic_cor")
pheno<- filter(prop2, selfharm=="NSSH"|selfharm=="SSH")
percent<- filter(prop2, selfharm=="NSSH%"|selfharm=="SSH%")
colnames(percent)<-c("trait_prop","selfharm_prop","A_prop","C_prop","E_prop","phenotypic_cor_prop")
bigdata<-data.frame(pheno,percent)
bigdata$`correlation due to A`=paste(specify_decimal(bigdata$A,3), " (", specify_decimal(bigdata$A_prop,1),"%", ")", sep="")
bigdata$`correlation due to C`=paste(specify_decimal(bigdata$C,3), " (", specify_decimal(bigdata$C_prop,1),"%", ")",sep="")
bigdata$`correlation due to E`=paste(specify_decimal(bigdata$E,3), " (", specify_decimal(bigdata$E_prop,1),"%", ")",sep="")
bigdata<-bigdata%>%
add_column(trait_category=ifelse(bigdata$trait=="pSDQ"|
bigdata$trait=="cSDQ"|
bigdata$trait=="pAUT"|
bigdata$trait=="cAUT", "Others",
ifelse(bigdata$trait=="pCONN"|
bigdata$trait=="pEMOLv2"|
bigdata$trait=="pINAT"|
bigdata$trait=="pHYPER"|
bigdata$trait=="cSWAN","Externalising problems",
ifelse(bigdata$trait=="pMFQ"|
bigdata$trait=="cMFQv2"|
bigdata$trait=="pANX"|
bigdata$trait=="cANX"|
bigdata$trait=="cEAT"|
bigdata$trait=="cINSOM","Internalising problems",
ifelse(bigdata$trait=="cCAPS"|
bigdata$trait=="cGRAND"|
bigdata$trait=="cTEPS"|
bigdata$trait=="cANHE"|
bigdata$trait=="cPRND"|
bigdata$trait=="pSANS","Psychotic-like experiences",
ifelse(bigdata$trait=="cSMOK"|
bigdata$trait=="cALC"|
bigdata$trait=="cCANN","Substance abuse",NA))))))%>%
select(trait_category,trait,selfharm,phenotypic_cor,`correlation due to A`,`correlation due to C`,`correlation due to E`)%>%
arrange(trait)%>%
arrange(trait_category)
bigdata$trait[bigdata$trait=="pEMOLv2"]<-"pEMOL"
bigdata$trait[bigdata$trait=="cMFQv2"]<-"cMFQ"
knitr::kable(bigdata,digits=3)%>%
kableExtra::kable_styling(font_size = 12)%>%
kableExtra::collapse_rows()| trait_category | trait | selfharm | phenotypic_cor | correlation due to A | correlation due to C | correlation due to E |
|---|---|---|---|---|---|---|
| Externalising problems | cSWAN | NSSH | -0.127 | -0.081 (64.1%) | 0.001 (-0.7%) | -0.046 (36.6%) |
| SSH | -0.213 | -0.130 (61.0%) | 0.001 (-0.4%) | -0.084 (39.4%) | ||
| pCONN | NSSH | 0.113 | 0.062 (55.1%) | 0.033 (29.2%) | 0.018 (15.7%) | |
| SSH | 0.163 | 0.089 (55.0%) | 0.049 (29.9%) | 0.024 (15.1%) | ||
| pEMOL | NSSH | 0.150 | 0.047 (31.1%) | 0.067 (44.6%) | 0.036 (24.3%) | |
| SSH | 0.195 | 0.110 (56.6%) | 0.054 (27.7%) | 0.031 (15.8%) | ||
| pHYPER | NSSH | 0.053 | 0.018 (33.1%) | 0.026 (48.9%) | 0.010 (18.1%) | |
| SSH | 0.097 | 0.063 (64.6%) | 0.037 (38.5%) | -0.003 (-3.2%) | ||
| pINAT | NSSH | 0.129 | 0.110 (85.5%) | 0.001 (0.8%) | 0.018 (13.7%) | |
| SSH | 0.176 | 0.144 (81.9%) | 0.001 (0.5%) | 0.031 (17.6%) | ||
| Internalising problems | cANX | NSSH | 0.233 | 0.089 (38.0%) | 0.054 (23.2%) | 0.091 (38.8%) |
| SSH | 0.253 | 0.106 (41.8%) | 0.059 (23.1%) | 0.089 (35.1%) | ||
| cEAT | NSSH | 0.256 | 0.195 (76.3%) | 0.000 (0.0%) | 0.061 (23.7%) | |
| SSH | 0.311 | 0.228 (73.3%) | 0.083 (26.7%) | |||
| cINSOM | NSSH | 0.322 | 0.242 (75.1%) | 0.003 (0.8%) | 0.078 (24.1%) | |
| SSH | 0.361 | 0.270 (74.8%) | 0.002 (0.6%) | 0.089 (24.6%) | ||
| cMFQ | NSSH | 0.377 | 0.177 (47.1%) | 0.081 (21.5%) | 0.119 (31.4%) | |
| SSH | 0.396 | 0.225 (56.7%) | 0.056 (14.1%) | 0.116 (29.2%) | ||
| pANX | NSSH | 0.113 | 0.124 (109.9%) | 0.001 (1.2%) | -0.013 (-11.1%) | |
| SSH | 0.165 | 0.169 (102.5%) | 0.001 (0.6%) | -0.005 (-3.1%) | ||
| pMFQ | NSSH | 0.191 | 0.170 (89.3%) | 0.002 (0.8%) | 0.019 (9.9%) | |
| SSH | 0.227 | 0.197 (86.7%) | 0.001 (0.5%) | 0.029 (12.9%) | ||
| Others | cAUT | NSSH | 0.211 | 0.143 (67.6%) | 0.017 (8.2%) | 0.051 (24.2%) |
| SSH | 0.194 | 0.136 (70.4%) | 0.014 (7.1%) | 0.044 (22.5%) | ||
| cSDQ | NSSH | 0.364 | 0.213 (58.4%) | 0.050 (13.8%) | 0.101 (27.7%) | |
| SSH | 0.386 | 0.227 (58.7%) | 0.044 (11.5%) | 0.115 (29.7%) | ||
| pAUT | NSSH | 0.080 | -0.052 (-65.3%) | 0.115 (143.7%) | 0.017 (21.6%) | |
| SSH | 0.094 | -0.032 (-33.8%) | 0.108 (114.7%) | 0.018 (19.1%) | ||
| pSDQ | NSSH | 0.149 | 0.141 (95.1%) | -0.004 (-2.5%) | 0.011 (7.5%) | |
| SSH | 0.193 | 0.158 (82.0%) | 0.006 (3.0%) | 0.029 (15.0%) | ||
| Psychotic-like experiences | cANHE | NSSH | 0.182 | 0.167 (91.9%) | 0.006 (3.2%) | 0.009 (4.9%) |
| SSH | 0.229 | 0.193 (84.5%) | 0.005 (2.0%) | 0.031 (13.5%) | ||
| cCAPS | NSSH | 0.226 | 0.124 (55.0%) | 0.042 (18.4%) | 0.060 (26.6%) | |
| SSH | 0.252 | 0.105 (41.6%) | 0.051 (20.1%) | 0.096 (38.3%) | ||
| cGRAND | NSSH | -0.052 | -0.044 (85.1%) | 0.004 (-6.8%) | -0.011 (21.8%) | |
| SSH | -0.034 | -0.032 (94.2%) | 0.016 (-48.2%) | -0.018 (53.9%) | ||
| cPRND | NSSH | 0.312 | 0.243 (78.0%) | 0.009 (2.8%) | 0.060 (19.2%) | |
| SSH | 0.331 | 0.216 (65.4%) | 0.010 (3.1%) | 0.104 (31.5%) | ||
| cTEPS | NSSH | -0.208 | -0.180 (86.6%) | 0.000 (0.0%) | -0.028 (13.4%) | |
| SSH | -0.194 | -0.133 (68.6%) | -0.061 (31.4%) | |||
| pSANS | NSSH | 0.141 | 0.010 (7.3%) | 0.082 (58.4%) | 0.048 (34.3%) | |
| SSH | 0.198 | 0.056 (28.1%) | 0.083 (41.8%) | 0.060 (30.1%) | ||
| Substance abuse | cALC | NSSH | 0.138 | 0.009 (6.7%) | 0.077 (56.1%) | 0.051 (37.2%) |
| SSH | 0.162 | -0.057 (-35.3%) | 0.143 (88.1%) | 0.077 (47.2%) | ||
| cCANN | NSSH | 0.267 | 0.155 (58.2%) | 0.068 (25.7%) | 0.043 (16.1%) | |
| SSH | 0.162 (60.5%) | 0.081 (30.1%) | 0.025 (9.4%) | |||
| cSMOK | NSSH | 0.251 | 0.136 (54.0%) | 0.039 (15.5%) | 0.077 (30.5%) | |
| SSH | 0.293 | 0.087 (29.6%) | 0.095 (32.5%) | 0.111 (37.9%) |
#save as excel file for further editting
library(xlsx)
write.xlsx(bigdata, "phenotypic_correlation_tidied_up_25_July_2020.xlsx")Table S8: Genetic and environmental correlations in trivariate models
Code to compile genetic and environmental correlations between each measure with both NSSH and SSH in the trivariate models
Note: The column for phenotypic correlation in the table below was later moved to Table S7 using Excel functions after these two tables were generated and exported out from R, as we deemed that was a better way to present the results.
##read RPh,Ra,Rc,Re results
path_CI<-"/Users/kai/OneDrive - King's College London/PhD/TEDS_project/results/14_reanalyses_trivariate/trivariate_estimates_with_CI_16_June_2020.xlsx"
corr <- path_CI %>%
excel_sheets() %>%
set_names() %>%
map_df(read_excel,
path = path_CI,
.id = "trait") #id = column name for the sheet name as column values
corr2<-as.data.frame(corr)
colnames(corr2)[2]<-"correlation"
corr_plot <- corr2 %>%
add_column(typecor=ifelse(grepl("ACE.Rph",corr2$correlation),
"Rph",
ifelse(grepl("ACE.Ra",corr2$correlation),
"Ra",
ifelse(grepl("ACE.Rc",corr2$correlation),
"Rc", "Re")))) %>%
add_column(selfharm=rep(c("NSSH","SSH"),96))%>%
add_column(unique_ID=paste(corr2$trait,corr2$selfharm,sep="_"))%>%
add_column(rater=ifelse(grepl("c",corr2$trait),"child","parent"))
corr_plot$estimate_CI=paste(specify_decimal(corr_plot$estimate,3), " (",specify_decimal(corr_plot$lbound,3), ",", specify_decimal(corr_plot$ubound,3),")", sep="")
corr_plot2<-spread(corr_plot,typecor,estimate_CI)
corr_plot3<-corr_plot2%>%
select(trait,selfharm,Ra,Rc,Re,Rph)
Rph=corr_plot3[!is.na(corr_plot3$Rph),c("trait","selfharm","Rph")]
Ra=corr_plot3[!is.na(corr_plot3$Ra),c("trait","selfharm","Ra")]
Rc=corr_plot3[!is.na(corr_plot3$Rc),c("trait","selfharm","Rc")]
Re=corr_plot3[!is.na(corr_plot3$Re),c("trait","selfharm","Re")]
corr_plot4<-data.frame(Rph,Ra,Rc,Re)
corr_plot5<-corr_plot4%>%
select(trait,selfharm,Rph,Ra,Rc,Re)%>%
add_column(trait_category=ifelse(corr_plot4$trait=="pSDQ"|
corr_plot4$trait=="cSDQ"|
corr_plot4$trait=="pAUT"|
corr_plot4$trait=="cAUT", "Others",
ifelse(corr_plot4$trait=="pCONN"|
corr_plot4$trait=="pEMOLv2"|
corr_plot4$trait=="pINAT"|
corr_plot4$trait=="pHYPER"|
corr_plot4$trait=="cSWAN","Externalising problems",
ifelse(corr_plot4$trait=="pMFQ"|
corr_plot4$trait=="cMFQv2"|
corr_plot4$trait=="pANX"|
corr_plot4$trait=="cANX"|
corr_plot4$trait=="cEAT"|
corr_plot4$trait=="cINSOM","Internalising problems",
ifelse(corr_plot4$trait=="cCAPS"|
corr_plot4$trait=="cGRAND"|
corr_plot4$trait=="cTEPS"|
corr_plot4$trait=="cANHE"|
corr_plot4$trait=="cPRND"|
corr_plot4$trait=="pSANS","Psychotic-like experiences",
ifelse(corr_plot4$trait=="cSMOK"|
corr_plot4$trait=="cALC"|
corr_plot4$trait=="cCANN","Substance abuse",NA))))))%>%
select(trait_category,trait,selfharm,Rph,Ra,Rc,Re)%>%
arrange(trait)%>%
arrange(trait_category)
corr_plot5$trait[corr_plot5$trait=="pEMOLv2"]<-"pEMOL"
corr_plot5$trait[corr_plot5$trait=="cMFQv2"]<-"cMFQ"
knitr::kable(corr_plot5,digits=3)%>%
kableExtra::kable_styling(font_size = 12)%>%
kableExtra::collapse_rows()| trait_category | trait | selfharm | Rph | Ra | Rc | Re |
|---|---|---|---|---|---|---|
| Externalising problems | cSWAN | NSSH | -0.127 (-0.202,-0.049) | -0.159 (-0.402,0.112) | 1.000 (-1.000,1.000) | -0.096 (-0.266,0.086) |
| SSH | -0.213 (-0.305,-0.113) | -0.268 (-0.698,-0.268) | -0.163 (-0.359,0.048) | |||
| pCONN | NSSH | 0.113 (0.077,0.149) | 0.099 (0.083,0.233) | 1.000 (-0.012,1.000) | 0.069 (-0.019,0.155) | |
| SSH | 0.163 (0.119,0.205) | 0.153 (0.010,0.314) | 1.000 (0.562,1.000) | 0.089 (-0.014,0.177) | ||
| pEMOL | NSSH | 0.150 (0.116,0.182) | 0.098 (0.068,0.224) | 0.868 (-1.000,1.000) | 0.100 (0.022,0.134) | |
| SSH | 0.195 (0.155,0.234) | 0.221 (0.027,0.319) | 0.964 (-1.000,1.000) | 0.089 (-0.023,0.172) | ||
| pHYPER | NSSH | 0.053 (-0.029,0.082) | 0.003 (-0.028,0.033) | 0.470 (-1.000,1.000) | 0.034 (-0.069,0.139) | |
| SSH | 0.097 (0.054,0.138) | 0.121 (-0.023,0.267) | 1.000 (-1.000,1.000) | -0.011 (-0.113,0.087) | ||
| pINAT | NSSH | 0.129 (0.093,0.166) | 0.169 (0.086,0.250) | 0.979 (-1.000,1.000) | 0.058 (-0.027,0.142) | |
| SSH | 0.176 (0.133,0.221) | 0.231 (-0.952,0.964) | 0.542 (-1.000,1.000) | 0.096 (-0.004,0.196) | ||
| Internalising problems | cANX | NSSH | 0.233 (0.202,0.264) | 0.217 (0.105,0.375) | 1.000 (-1.000,1.000) | 0.172 (0.096,0.246) |
| SSH | 0.253 (0.215,0.289) | 0.279 (0.073,0.487) | 0.159 (0.071,0.246) | |||
| cEAT | NSSH | 0.256 (0.023,0.322) | 0.352 (0.122,1.000) | 0.668 (-1.000,1.000) | 0.135 (-0.028,0.294) | |
| SSH | 0.311 (0.220,0.391) | 0.434 (0.189,0.817) | 0.831 (-1.000,1.000) | 0.173 (-0.024,0.363) | ||
| cINSOM | NSSH | 0.322 (0.289,0.357) | 0.530 (0.530,0.714) | 1.000 (-1.000,1.000) | 0.148 (0.068,0.227) | |
| SSH | 0.361 (0.322,0.398) | 0.621 (0.621,0.897) | 0.159 (0.065,0.252) | |||
| cMFQ | NSSH | 0.377 (0.348,0.406) | 0.515 (0.515,0.833) | 0.921 (0.190,1.000) | 0.225 (0.145,0.300) | |
| SSH | 0.396 (0.360,0.431) | 0.671 (0.671,0.982) | 0.873 (0.768,1.000) | 0.207 (0.112,0.301) | ||
| pANX | NSSH | 0.113 (0.063,0.162) | 0.217 (0.016,0.983) | 1.000 (-1.000,1.000) | -0.029 (-0.160,0.104) | |
| SSH | 0.165 (0.108,0.220) | 0.310 (0.114,0.577) | -0.011 (-0.153,0.130) | |||
| pMFQ | NSSH | 0.191 (0.176,0.244) | 0.343 (-1.000,0.531) | 0.966 (-0.983,1.000) | 0.087 (-0.061,0.185) | |
| SSH | 0.227 (0.174,0.282) | 0.381 (0.264,0.417) | -0.986 (-1.000,1.000) | 0.077 (-0.013,0.220) | ||
| Others | cAUT | NSSH | 0.211 (0.178,0.243) | 0.287 (0.258,0.402) | 1.000 (-1.000,1.000) | 0.107 (0.030,0.141) |
| SSH | 0.194 (0.154,0.232) | 0.285 (0.211,0.432) | 0.086 (-0.004,0.176) | |||
| cSDQ | NSSH | 0.364 (0.334,0.393) | 0.452 (0.419,0.578) | 0.211 (0.137,0.284) | ||
| SSH | 0.386 (0.351,0.419) | 0.502 (0.484,0.694) | 1.000 (0.995,1.000) | 0.228 (0.138,0.315) | ||
| pAUT | NSSH | 0.080 (0.044,0.115) | -0.091 (-0.226,0.029) | 1.000 (1.000,1.000) | 0.079 (-0.004,0.162) | |
| SSH | 0.094 (0.052,0.137) | -0.059 (-0.235,0.088) | 1.000 (0.912,1.000) | 0.078 (-0.018,0.173) | ||
| pSDQ | NSSH | 0.149 (0.114,0.183) | 0.218 (0.096,0.245) | -0.036 (-1.000,1.000) | 0.039 (-0.048,0.123) | |
| SSH | 0.193 (0.151,0.233) | 0.257 (-0.488,0.346) | 0.451 (-1.000,1.000) | 0.094 (-0.007,0.189) | ||
| Psychotic-like experiences | cANHE | NSSH | 0.182 (0.149,0.214) | 0.365 (-0.975,0.499) | 1.000 (-1.000,1.000) | 0.016 (-0.060,0.095) |
| SSH | 0.229 (0.190,0.267) | 0.441 (0.441,0.628) | 0.056 (-0.035,0.147) | |||
| cCAPS | NSSH | 0.226 (0.194,0.257) | 0.297 (0.297,0.574) | 0.965 (0.718,1.000) | 0.118 (0.036,0.196) | |
| SSH | 0.252 (0.214,0.288) | 0.268 (0.268,0.588) | 0.996 (-1.000,1.000) | 0.178 (0.083,0.269) | ||
| cGRAND | NSSH | -0.052 (-0.087,-0.017) | -0.087 (-0.283,0.104) | 1.000 (-1.000,1.000) | -0.024 (-0.109,0.061) | |
| SSH | -0.034 (-0.075,0.008) | -0.067 (-0.337,0.146) | -0.036 (-0.137,0.066) | |||
| cPRND | NSSH | 0.312 (0.281,0.342) | 0.476 (0.476,0.704) | 0.572 (-1.000,1.000) | 0.127 (0.044,0.206) | |
| SSH | 0.331 (0.293,0.366) | 0.445 (0.445,0.693) | 0.703 (-1.000,1.000) | 0.209 (0.113,0.300) | ||
| cTEPS | NSSH | -0.208 (-0.240,-0.176) | -0.355 (-0.512,-0.239) | -0.913 (-1.000,1.000) | -0.057 (-0.131,0.018) | |
| SSH | -0.194 (-0.232,-0.157) | -0.277 (-0.470,-0.135) | -0.662 (-1.000,1.000) | -0.118 (-0.205,0.144) | ||
| pSANS | NSSH | 0.141 (0.105,0.176) | 0.018 (-0.106,0.153) | 1.000 (0.930,1.000) | 0.173 (0.085,0.259) | |
| SSH | 0.198 (0.156,0.239) | 0.102 (-0.081,0.268) | 1.000 (0.898,1.000) | 0.201 (0.095,0.302) | ||
| Substance abuse | cALC | NSSH | 0.138 (0.087,0.189) | 0.023 (-0.316,0.339) | 0.999 (-1.000,1.000) | 0.189 (-0.053,0.336) |
| SSH | 0.162 (0.107,0.219) | -0.082 (-0.531,0.325) | 0.991 (0.965,1.000) | 0.180 (-0.018,0.363) | ||
| cCANN | NSSH | 0.267 (0.203,0.330) | 0.353 (0.353,0.680) | 0.852 (-1.000,1.000) | 0.164 (-0.090,0.590) | |
| SSH | 0.267 (0.196,0.338) | 0.466 (0.466,0.888) | 0.985 (-1.000,1.000) | 0.096 (-0.215,0.391) | ||
| cSMOK | NSSH | 0.251 (0.202,0.301) | 0.253 (-0.010,0.538) | 0.981 (-1.000,1.000) | 0.276 (0.092,0.438) | |
| SSH | 0.293 (0.237,0.348) | 0.190 (-0.990,0.507) | 0.998 (-1.000,1.000) | 0.315 (0.117,0.572) |
#save the table into an excel file for further edit
write.xlsx(corr_plot5,"Ra_Rc_Re_compiled_25_July_2020.xlsx")Plot Figure 2: Graphical representation of Table S7
# plot graph for Rph and proportion
#load packages
library(tidyverse)
library(fs)
library(readxl)
library(ggforce)
library(patchwork)
library(viridis)
library(colortools)
library(plyr)
library(drlib)
library(psych)
path<-"/Users/kai/OneDrive - King's College London/PhD/TEDS_project/results/14_reanalyses_trivariate/trivariate_proportion_16_June_2020.xlsx"
prop <- path %>%
excel_sheets() %>%
set_names() %>%
map_df(read_excel,
path = path,
.id = "trait") #id = column name for the sheet name as column values
prop2<-as.data.frame(prop)
long_prop<-gather(prop2,ACE,proportion,A:E)
colnames(long_prop)<-c( "trait","selfharm","ACE","phenotypic_cor")
plot_data<- filter(long_prop, selfharm=="NSSH"|selfharm=="SSH")
plot_data$rater=NA
plot_data$rater<-as.character(grepl("c",plot_data$trait))
plot_data$rater2<-ifelse(plot_data$rater=="TRUE","child","parent")
plot_data$unique_ID<- with(plot_data, paste(trait,selfharm, sep="_"))
plot_data<-plot_data%>%
add_column(trait_category=ifelse(plot_data$trait=="pSDQ"|
plot_data$trait=="cSDQ"|
plot_data$trait=="pAUT"|
plot_data$trait=="cAUT", "Others",
ifelse(plot_data$trait=="pCONN"|
plot_data$trait=="pEMOLv2"|
plot_data$trait=="pINAT"|
plot_data$trait=="pHYPER"|
plot_data$trait=="cSWAN","Externalising problems",
ifelse(plot_data$trait=="pMFQ"|
plot_data$trait=="cMFQv2"|
plot_data$trait=="pANX"|
plot_data$trait=="cANX"|
plot_data$trait=="cEAT"|
plot_data$trait=="cINSOM","Internalising problems",
ifelse(plot_data$trait=="cCAPS"|
plot_data$trait=="cGRAND"|
plot_data$trait=="cTEPS"|
plot_data$trait=="cANHE"|
plot_data$trait=="cPRND"|
plot_data$trait=="pSANS","Psychotic-like experiences",
ifelse(plot_data$trait=="cSMOK"|
plot_data$trait=="cALC"|
plot_data$trait=="cCANN","Substance abuse",NA))))))
#plot_data$trait_ordered=factor(plot_data$unique_ID, levels = plot_data$unique_ID[order(plot_data$phenotypic_cor)])
#used this to choose colour: http://www.sthda.com/english/wiki/the-elements-of-choosing-colors-for-great-data-visualization-in-r
#wheel("darkcyan", num = 3)
#internalising problems
plot_data$trait_p = factor(plot_data$trait, levels=c("cMFQv2","cINSOM",'cEAT','cANX','cANHE','pMFQ','pANX'),
labels=c("cMFQ","cINSOM",'cEAT','cANX','cANHE','pMFQ','pANX'))
p<-ggplot(plot_data[plot_data$trait_category=="Internalising problems",],
aes(fill=ACE, y=phenotypic_cor, x=selfharm)) +
geom_bar(position="stack", stat="identity")+
theme(axis.text.x = element_text(angle = 90, hjust = 1))+
facet_grid(~trait_p)+ scale_fill_manual(values = wheel("darkcyan", num = 3))+ theme(legend.position = "none")+
theme(axis.title.x=element_blank(), axis.text.x=element_blank(), axis.ticks.x=element_blank(),
title=element_text(size=9,face="bold"),
axis.title.y = element_text(size=10),strip.text = element_text(size=9))+
labs(title="Internalising problems",y="Phenotypic correlation")+ylim(-0.22,0.4)
#externalising problems
plot_data$trait_q = factor(plot_data$trait, levels=c("cSDQ","cAUT",'pSDQ','pCONN','pEMOLv2','pINAT','pHYPER',"cSWAN","pAUT"),
labels=c("cSDQ","cAUT",'pSDQ','pCONN','pEMOL','pINAT','pHYPER',"cSWAN","pAUT"))
q<-ggplot(plot_data[plot_data$trait_category=="Externalising problems",],
aes(fill=ACE, y=phenotypic_cor, x=selfharm)) +
geom_bar(position="stack", stat="identity")+
theme(axis.text.x = element_blank(),axis.title.x=element_blank(),axis.ticks.x=element_blank(),
legend.title = element_blank(),axis.title.y = element_text(size=10),
title=element_text(size=9,face="bold"),strip.text = element_text(size=9))+
facet_grid(~trait_q)+scale_fill_manual(values = wheel("darkcyan", num = 3))+
labs(title="Externalising problems",y="Phenotypic correlation")+ylim(-0.22,0.4)+
guides(fill = guide_legend(nrow = 1, byrow = TRUE))
#psychotic symptoms
plot_data$trait_r = factor(plot_data$trait, levels=c("cPRND","cCAPS",'cANHE','pSANS','cGRAND','cTEPS'))
r<-ggplot(plot_data[plot_data$trait_category=="Psychotic-like experiences",],
aes(fill=ACE, y=phenotypic_cor, x=selfharm)) +
geom_bar(position="stack", stat="identity")+
theme(axis.text.x = element_text(angle = 45),
title=element_text(size=9,face="bold"),strip.text = element_text(size=9),
axis.title.x=element_text(face="bold",size=11),
axis.title.y = element_text(size=10))+
facet_grid(~trait_r)+scale_fill_manual(values = wheel("darkcyan", num = 3))+ theme(legend.position = "none")+
labs(title="Psychotic-like experiences", x = "Type of self-harm",y="Phenotypic correlation")+ylim(-0.22,0.4)
#substance abuse
plot_data$trait_s = factor(plot_data$trait, levels=c("cSMOK","cCANN",'cALC'))
s<-ggplot(plot_data[plot_data$trait_category=="Substance abuse",],
aes(fill=ACE, y=phenotypic_cor, x=selfharm)) +
geom_bar(position="stack", stat="identity")+
facet_grid(~trait_s)+scale_fill_manual(values = wheel("darkcyan", num = 3))+
theme(axis.title.x=element_blank(), axis.text.x=element_blank(), axis.ticks.x=element_blank(),
title=element_text(size=9,face="bold"),strip.text = element_text(size=9),
axis.title.y = element_text(size=10))+
theme(legend.position = "none")+labs(title="Substance abuse",y="Phenotypic correlation")+ylim(-0.22,0.4)
#others
plot_data$trait_t = factor(plot_data$trait, levels=c("cSDQ",'cAUT',"pSDQ", 'pAUT'))
t<-ggplot(plot_data[plot_data$trait_category=="Others",],
aes(fill=ACE, y=phenotypic_cor, x=selfharm)) +
geom_bar(position="stack", stat="identity")+
theme(axis.text.x = element_text(angle = 90, hjust = 1))+
facet_grid(~trait_t)+scale_fill_manual(values = wheel("darkcyan", num = 3))+
theme(axis.title.x=element_blank(),axis.text.x=element_blank(),axis.text.y=element_blank(), axis.ticks=element_blank(),
title=element_text(size=9,face="bold"),axis.title.y = element_text(size=10),strip.text = element_text(size=9))+
labs(title="Others")+ theme(legend.position = "none")+ylim(-0.22,0.4)+ylab(label="")
#use patchwork to have 4 plots together:
qq<-(q+plot_spacer()+plot_layout(ncol=2,widths = c(100,1)))
st<-(s+t+plot_layout(ncol=2,widths = c(3,4)))
pheno_plot<-(qq/st/p/r)
#pheno_plot<-(p/((r|s)+ plot_layout(ncol=2,widths=c(2,1))))/qpheno_plot
Plot Figure 3: Graphical representation of Table S8
######## now plot the second graph for rG, rC and rE #######
path_rg<-"/Users/kai/OneDrive - King's College London/PhD/TEDS_project/results/14_reanalyses_trivariate/trivariate_estimates_with_CI_16_June_2020.xlsx"
corr <- path_rg %>%
excel_sheets() %>%
set_names() %>%
map_df(read_excel,
path = path_rg,
.id = "trait") #id = column name for the sheet name as column values
corr2<-as.data.frame(corr)
colnames(corr2)[2]<-"correlation"
corr_plot <- corr2 %>%
add_column(typecor=ifelse(grepl("ACE.Rph",corr2$correlation),
"Rph",
ifelse(grepl("ACE.Ra",corr2$correlation),
"Ra",
ifelse(grepl("ACE.Rc",corr2$correlation),
"Rc", "Re")))) %>%
add_column(selfharm=rep(c("NSSH","SSH"),96))%>%
add_column(unique_ID=paste(corr2$trait,corr2$selfharm,sep="_"))%>%
add_column(rater=ifelse(grepl("c",corr2$trait),"child","parent"))
corr_plot<-corr_plot%>%
add_column(trait_category=ifelse(corr_plot$trait=="pSDQ"|
corr_plot$trait=="cSDQ"|
corr_plot$trait=="pAUT"|
corr_plot$trait=="cAUT","Others",
ifelse(corr_plot$trait=="pCONN"|
corr_plot$trait=="pEMOLv2"|
corr_plot$trait=="pINAT"|
corr_plot$trait=="pHYPER"|
corr_plot$trait=="cSWAN","Externalising problems",
ifelse(corr_plot$trait=="pMFQ"|
corr_plot$trait=="cMFQv2"|
corr_plot$trait=="pANX"|
corr_plot$trait=="cANX"|
corr_plot$trait=="cEAT"|
corr_plot$trait=="cINSOM","Internalising problems",
ifelse(corr_plot$trait=="cCAPS"|
corr_plot$trait=="cGRAND"|
corr_plot$trait=="cTEPS"|
corr_plot$trait=="cANHE"|
corr_plot$trait=="cPRND"|
corr_plot$trait=="pSANS","Psychotic-like experiences",
ifelse(corr_plot$trait=="cSMOK"|
corr_plot$trait=="cALC"|
corr_plot$trait=="cCANN","Substance abuse","No"))))))
corr_plot$trait_ra = factor(corr_plot$trait, levels=c("pHYPER",'pCONN',"pEMOLv2",'pINAT','pSDQ',"cAUT","cSDQ","pAUT","cSWAN",
"cANX","pANX","pMFQ","cEAT","cINSOM","cMFQv2",
"pSANS","cCAPS","cANHE","cPRND","cGRAND","cTEPS",
"cSMOK","cCANN","cALC"),
labels=c("pHYPER",'pCONN',"pEMOL",'pINAT','pSDQ',"cAUT","cSDQ","pAUT","cSWAN",
"cANX","pANX","pMFQ","cEAT","cINSOM","cMFQ",
"pSANS","cCAPS","cANHE","cPRND","cGRAND","cTEPS",
"cSMOK","cCANN","cALC"))
#### try to plot a heatmap suggested by reviewer ######
#https://jcoliver.github.io/learn-r/006-heatmaps.html
#https://stackoverflow.com/questions/13016022/ggplot2-heatmaps-using-different-gradients-for-categories
re_heat<-ggplot(corr_plot[corr_plot$typecor=="Re",],
mapping=aes(fill=estimate, x=trait_ra,y=selfharm))+
geom_tile()+
facet_grid(vars(typecor),vars(trait_category),scales = "free_x", space = "free_x",
labeller=labeller(trait_category=label_wrap_gen(width=10),
typecor=c(Re="Re")))+
theme(axis.text.x = element_text(angle =50, hjust = 1, size=10, face="plain"),
strip.text.x=element_blank(),
axis.title=element_blank(),
strip.text= element_text(size = 10, face="plain"),
axis.text.y=element_text(size=10, face="plain"))+
scale_fill_gradient2(low = "blue", high = "red", mid = "white",
midpoint = 0, limit = c(-0.7,0.7), space = "Lab",
name="")
ra_heat<-ggplot(corr_plot[corr_plot$typecor=="Ra",],
mapping=aes(fill=estimate, x=trait_ra,y=selfharm))+
geom_tile()+
facet_grid(vars(typecor),vars(trait_category),scales = "free_x", space = "free_x",
labeller=labeller(trait_category=label_wrap_gen(width=10),
typecor=c(Ra="Rg")))+
theme(axis.title=element_blank(),
axis.text.x=element_blank(),
axis.ticks.x=element_blank(),
legend.title = element_blank(),
strip.text= element_text(size = 10, face="plain"),
axis.text.y=element_text(size=10, face="plain"),
legend.position = "none")+
scale_fill_gradient2(low = "blue", high = "red", mid = "white",
midpoint = 0, limit = c(-0.7,0.7), space = "Lab",
name="")
rare_heat<-(ra_heat/re_heat)+plot_layout(guides="collect")
rare_heat
Table S9: Goodness of fit tests in trivariate analyses
Code to compile goodness of fit tests results into a table
#now read the chisquare results
path_chi<-"/Users/kai/OneDrive - King's College London/PhD/TEDS_project/results/14_reanalyses_trivariate/trivariate_constrained_results_16_June_2020.xlsx"
chi <- path_chi %>%
excel_sheets() %>%
set_names() %>%
map_df(read_excel,
path = path_chi,
.id = "trait") #id = column name for the sheet name as column values
chi2<-chi%>%
add_column(trait_category=ifelse(chi$trait=="pSDQ"|
chi$trait=="cSDQ"|
chi$trait=="pAUT"|
chi$trait=="cAUT", "Others",
ifelse(chi$trait=="pCONN"|
chi$trait=="pEMOLv2"|
chi$trait=="pINAT"|
chi$trait=="pHYPER"|
chi$trait=="cSWAN","Externalising problems",
ifelse(chi$trait=="pMFQ"|
chi$trait=="cMFQv2"|
chi$trait=="pANX"|
chi$trait=="cANX"|
chi$trait=="cEAT"|
chi$trait=="cINSOM","Internalising problems",
ifelse(chi$trait=="cCAPS"|
chi$trait=="cGRAND"|
chi$trait=="cTEPS"|
chi$trait=="cANHE"|
chi$trait=="cPRND"|
chi$trait=="pSANS","Psychotic-like experiences",
ifelse(chi$trait=="cSMOK"|
chi$trait=="cALC"|
chi$trait=="cCANN","Substance abuse",NA))))))%>%
select(trait_category,`...1`,trait,minus2LL,df,AIC,diffLL,diffdf,p)%>%
arrange(trait_category)
chi_p<-chi2[!is.na(chi2$p),]
chi_p$q<-p.adjust(chi_p$p,method="fdr")
chi_merged<-merge(x = chi2, y = chi_p[ , c("p", "q")], by = "p", all.x=T, all.y=T)%>%
select(trait_category,trait,`...1`,minus2LL,df,AIC,diffLL,diffdf,p,q)%>%
arrange(`...1`)%>%
arrange(trait)%>%
arrange(trait_category)
chi_merged$minus2LL<-specify_decimal(chi_merged$minus2LL,2)
chi_merged$AIC<-specify_decimal(chi_merged$AIC,2)
chi_merged$diffLL<-specify_decimal(chi_merged$diffLL,2)
chi_merged$trait[chi_merged$trait=="pEMOLv2"]<-"pEMOL"
chi_merged$trait[chi_merged$trait=="cMFQv2"]<-"cMFQ"
chi_merged$p[which(is.na(chi_merged$p))]<-chi_merged$p[which(is.na(chi_merged$p))+1]
chi_merged$q[which(is.na(chi_merged$q))]<-chi_merged$q[which(is.na(chi_merged$q))+1]
chi_merged$diffdf[which(is.na(chi_merged$diffdf))]<-chi_merged$diffdf[which(is.na(chi_merged$diffdf))+1]
chi_merged$diffLL[which(chi_merged$diffLL=="NA")] <- chi_merged$diffLL[which(chi_merged$diffLL=="NA")+1]
colnames(chi_merged)<-c("Category","Measure","Model", "-2 Log Likelihood","df","AIC","∆ -2 Log Likelihood",
"∆ df", "p-value", "q-value")
chi_merged$Model[chi_merged$Model==1]<-"ACE model"
chi_merged$Model[chi_merged$Model==2]<-"Constrained model"
knitr::kable(chi_merged,digits=3)%>%
kableExtra::kable_styling(font_size = 12)%>%
kableExtra::collapse_rows() | Category | Measure | Model | -2 Log Likelihood | df | AIC | ∆ -2 Log Likelihood | ∆ df | p-value | q-value |
|---|---|---|---|---|---|---|---|---|---|
| Externalising problems | cSWAN | ACE model | 23036.39 | 19852 | -16667.61 | 4.32 | 3 | 0.229 | 0.610 |
| Constrained model | 23040.71 | 19855 | -16669.29 | ||||||
| pCONN | ACE model | 41725.73 | 25890 | -10054.27 | 2.07 | 0.559 | 0.789 | ||
| Constrained model | 41727.79 | 25893 | -10058.21 | ||||||
| pEMOL | ACE model | 40229.31 | 25890 | -11550.69 | 5.35 | 0.148 | 0.595 | ||
| Constrained model | 40234.66 | 25893 | -11551.34 | ||||||
| pHYPER | ACE model | 42996.61 | 25887 | -8777.39 | 2.22 | 0.528 | 0.789 | ||
| Constrained model | 42998.83 | 25890 | -8781.17 | ||||||
| pINAT | ACE model | 42909.11 | 25889 | -8868.89 | 8.08 | 0.044 | 0.356 | ||
| Constrained model | 42917.19 | 25892 | -8866.81 | ||||||
| Internalising problems | cANX | ACE model | 45759.79 | 25896 | -6032.21 | 0.61 | 0.893 | 0.991 | |
| Constrained model | 45760.40 | 25899 | -6037.60 | ||||||
| cEAT | ACE model | 25519.81 | 19839 | -14158.19 | 3.28 | 0.350 | 0.617 | ||
| Constrained model | 25523.09 | 19842 | -14160.91 | ||||||
| cINSOM | ACE model | 36036.72 | 24115 | -12193.28 | 5.20 | 0.157 | 0.595 | ||
| Constrained model | 36041.93 | 24118 | -12194.07 | ||||||
| cMFQ | ACE model | 45289.22 | 25896 | -6502.78 | 2.16 | 0.541 | 0.789 | ||
| Constrained model | 45291.38 | 25899 | -6506.62 | ||||||
| pANX | ACE model | 28136.81 | 20905 | -13673.19 | 4.66 | 0.198 | 0.595 | ||
| Constrained model | 28141.48 | 20908 | -13674.52 | ||||||
| pMFQ | ACE model | 56337.82 | 25894 | 4549.82 | 9.85 | 0.020 | 0.356 | ||
| Constrained model | 56347.67 | 25897 | 4553.67 | ||||||
| Others | cAUT | ACE model | 46048.29 | 25889 | -5729.71 | 0.66 | 0.882 | 0.991 | |
| Constrained model | 46048.95 | 25892 | -5735.05 | ||||||
| cSDQ | ACE model | 45951.91 | 25887 | -5822.09 | 3.35 | 0.341 | 0.617 | ||
| Constrained model | 45955.26 | 25890 | -5824.74 | ||||||
| pAUT | ACE model | 42388.26 | 25894 | -9399.74 | 0.32 | 0.957 | 0.991 | ||
| Constrained model | 42388.58 | 25897 | -9405.42 | ||||||
| pSDQ | ACE model | 45621.87 | 25899 | -6176.13 | 4.73 | 0.192 | 0.595 | ||
| Constrained model | 45626.61 | 25902 | -6177.39 | ||||||
| Psychotic-like experiences | cANHE | ACE model | 22611.77 | 25886 | -29160.23 | 8.94 | 0.030 | 0.356 | |
| Constrained model | 22620.71 | 25889 | -29157.29 | ||||||
| cCAPS | ACE model | 42088.83 | 25898 | -9707.17 | 3.26 | 0.353 | 0.617 | ||
| Constrained model | 42092.09 | 25901 | -9709.91 | ||||||
| cGRAND | ACE model | 49025.66 | 25889 | -2752.34 | 0.11 | 0.991 | 0.991 | ||
| Constrained model | 49025.77 | 25892 | -2758.23 | ||||||
| cPRND | ACE model | 44502.34 | -7281.66 | 5.44 | 0.142 | 0.595 | |||
| Constrained model | 44507.78 | 25895 | -7282.22 | ||||||
| cTEPS | ACE model | 71995.56 | 25897 | 20201.56 | 3.21 | 0.360 | 0.617 | ||
| Constrained model | 71998.78 | 25900 | 20198.78 | ||||||
| pSANS | ACE model | 48818.38 | 25888 | -2957.62 | 3.88 | 0.274 | |||
| Constrained model | 48822.26 | 25891 | -2959.74 | ||||||
| Substance abuse | cALC | ACE model | 21776.33 | 18573 | -15369.67 | 0.80 | 0.849 | 0.991 | |
| Constrained model | 21777.14 | 18576 | -15374.86 | ||||||
| cCANN | ACE model | 17200.98 | 19226 | -21251.02 | 0.51 | 0.918 | |||
| Constrained model | 17201.49 | 19229 | -21256.51 | ||||||
| cSMOK | ACE model | 21512.15 | 19210 | -16907.85 | 1.78 | 0.620 | 0.827 | ||
| Constrained model | 21513.93 | 19213 | -16912.07 |
#save the table to an excel file
write.xlsx(chi_merged,"chi_test_2LL_2dp_25_July_2020.xlsx")