#########################################################################################
#########################################################################################
################### A WAY TO BREAK BONES? THE WEIGHT OF INTUITIVENESS ###################
# D. Vettese, T. Stavrova, A. Borel, J. Marin, M.-H. Moncel, M. Arzarello, C. Daujeard. #
#########################################################################################
#########################################################################################

## To run this code you will need to install the following packages:
install.packages("xlsx") # Install xlsx package
install.packages("corrplot") # Install corrplot package
install.packages("ggplot2") # Install ggplot2 package
install.packages("FactoMineR") # Install FactoMineR package
install.packages("car") # Install car package

#########################################################################################
# Electronic Supplementary Material 1.

# This code provides the results of the Fisher tests presented in the paper
#########################################################################################

# Make sure to have the "2020_09_07_quality_felt.xlsx" (Supporting Information 19)
# in the same folder as "A_way_to_break_bone.r".

# Construction of the script:
#     - step 1: import data of quality scale
#     - step 2: Fisher test of all Element regarding quality scale
#     - step 3: import data of felt scale
#     - step 4: Chi-square test of all Element regarding felt scale

########################################################
# Run the necessary libraries and function
library (xlsx)
library(corrplot)

# Function to verify the Cochran's rule:
cochran.verif <- function (datatab) {
  testCoch <- datatab
  testCochtheo<-suppressWarnings(chisq.test(testCoch)$expected)
  addmargins(as.table(testCochtheo))
  n.cases.theo<-length(testCochtheo)
  n.cases.inf.1<-length(which(testCochtheo<1))
  n.cases.inf.5<-length(which(testCochtheo<5))
  n.cases.entre.1et5<- length(which(testCochtheo<=5 & testCochtheo>=1))
  prop.Cochran<- length(which(testCochtheo>5))/n.cases.theo
  if(n.cases.inf.1>0){cat("The Cochran's rule is not respected\nThe following cells have expected frequencies under 1 :\n") ; print(which(testCochtheo<1, arr.ind=TRUE)) ; cat("\n")}
  if(n.cases.inf.1==0 & n.cases.inf.5>0 & prop.Cochran<0.8){cat("The Cochran's rule is not respected\nThe following cells have expected frequency between 1 and 5 :\n") ; print(which(testCochtheo<=5 & testCochtheo>=1, arr.ind=TRUE)) ; cat("And the proportion of expected cell frequencies under 5 is: ") ; cat(prop.Cochran, "\n")}
  if(n.cases.inf.1==0 & n.cases.inf.5>0 & prop.Cochran>=0.8){cat("The Cochran's rule is respected\nThe following cells have expected frequency between 1 and 5 :\n") ; print(which(testCochtheo<=5 & testCochtheo>=1, arr.ind=TRUE)) ; cat("And the proportion of expected cell frequencies above 5 is: ") ; cat(prop.Cochran, "\n")}
  if(n.cases.inf.5==0){cat("The Cochran's rule is respected\nNo cell have expected frequency less than 5\n")}
}
########################################################

###############################################
###### step 1 : import data #########
###############################################
quality <- read.xlsx("2020_09_07_quality_felt.xlsx", sheetName = "Quality", row.names=TRUE) # import the sheet "Quality"
str(quality)# observe the structure and verify that the import is correct

###############################################
###### Step 2: Fisher test of all Element regarding quality scale #########
###############################################
quality1<-quality[,-1] # Remove the column all.
quality1

# Verify Cochran's rule
cochran.verif(quality1)

# Fisher test results of quality scale
fisher.test(quality1, simulate.p.value=TRUE, B = 2000)

###############################################
###### step 3 : import data #########
###############################################
felt <- read.xlsx("2020_09_07_quality_felt.xlsx", sheetName = "Felt", row.names=TRUE) # import the sheet "Felt"
str(felt)# observe the structure and verify that the import is correct

###############################################
###### step 4: Fisher test of all Element regarding felt scale #########
###############################################
# Remove the column all.
felt1<-felt [,-1]
felt1

# Verify Cochran's rule
cochran.verif(felt1)

# Fisher test results of felt scale
fisher.test(felt1, simulate.p.value=TRUE, B = 2000)

#########################################################################################
# Electronic Supplementary Material 2.

# This code provides the results of the Spearman's correlation tests presented in the paper
# and used to build the figure of the Supporting Information 9
#########################################################################################

# Make sure to have the "Supplementary_data_15.xlsx" (Supporting Information 15)
# in the same folder as "A_way_to_break_bone.r".

# Packages needed:
# corrplot (Wei, T., Simko, V., Levy, M., Xie, Y., Jin, Y., & Zemla, J. (2017). R Package "corrplot". Statistician, 56(316), e24

# Construction of the script:
#     - step 1: import data
#     - step 2: plot spearman correlation results (see Vettese et al. 2020).

########################################################
# Run the necessary libraries
library (xlsx)
library(corrplot)
########################################################

###############################################
###### step 1 : import data #########
###############################################
Exp1 <- read.xlsx("Supplementary_data_15.xlsx", sheetIndex=1, row.names=TRUE)
str(Exp1)# observe the structure and verify that the import is correct

# Devide the dataset by bone type
Exphum<-subset(Exp1, Exp1$Element == "Humerus")
Exprau<- subset(Exp1, Exp1$Element == "Radio-ulna")
Expfem<- subset(Exp1, Exp1$Element == "Femur")
Exptib<- subset(Exp1, Exp1$Element == "Tibia")

######################################################
########### step 2: plot spearman correlation results #####################
######################################################
###All
#Open a new window
x11()
#Remove the column Individual, Bone.number, Element and Efficiency.index.
Exp1b<-Exp1[,-c(1,2,3,12)]
# Spearman correlation results on a matrix
resall<-cor(Exp1b,  method = c("spearman"))
# Plot of Spearman correlation results matrix
corrplot(resall, type="upper",  order="original",addCoef.col=T, tl.col="black", tl.srt=45)

###Humerus
#Open a new window
x11()
#Remove the column Individual, Bone.number, Element and Efficiency.index.
Exphum1<-Exphum[,-c(1,2,3,12)]
# Spearman correlation results on a matrix
reshum<-cor(Exphum1,  method = c("spearman"))
# Plot of Spearman correlation results matrix
corrplot(reshum, type="upper",  order="original",addCoef.col=T, tl.col="black", tl.srt=45)

###Radio-ulna
#Open a new window
x11()
#Remove the column Individual, Bone.number, Element and Efficiency.index.
Exprau1<-Exprau[,-c(1,2,3,12)]
# Spearman correlation results on a matrix
resrau<-cor(Exprau1,  method = c("spearman"))
# Plot of Spearman correlation results matrix
corrplot(resrau, type="upper",  order="original",addCoef.col=T, tl.col="black", tl.srt=45)

###Femur
#Open a new window
x11()
#Remove the column Individual, Bone.number, Element and Efficiency.index.
Expfem1<-Expfem[,-c(1,2,3,12)]
# Spearman correlation results on a matrix
resfem<-cor(Expfem1,  method = c("spearman"))
# Plot of Spearman correlation results matrix
corrplot(resfem, type="upper",  order="original",addCoef.col=T, tl.col="black", tl.srt=45)

###Tibia
#Open a new window
x11()
#Remove the column Individual, Bone.number, Element and Efficiency.index.
Exptib1<-Exptib[,-c(1,2,3,12)]
# Spearman correlation results on a matrix
restib<-cor(Exptib1,  method = c("spearman"))
# Plot of Spearman correlation results matrix
corrplot(restib, type="upper", order="original",addCoef.col=T, tl.col="black", tl.srt=45)

#########################################################################################
# Electronic Supplementary Material 3.

# This code provides the results of the Mann-Whitney U test/Wilcoxon signed rank test
# presented in the paper and used to build the table of the Supporting Information 8
#########################################################################################

# Make sure to have the "2020_09_07_Try_Blow_EFI_wilcoxon.xlsx" (Supporting Information 20)
# in the same folder as "A_way_to_break_bone.r".

# Construction of the script:
#     - step 1:EFFICIENCY INDEX, 3 FIRST TRIES VS 3 LAST ONES
#     - step 2:EFFICIENCY INDEX, 5 FIRST TRIES VS 5 LAST ONES
#     - step 3:BLOWS, 3 FIRST TRIES VS 3 LAST ONES
#     - step 3:BLOWS, 5 FIRST TRIES VS 5 LAST ONES

########################################################
# Run the necessary libraries
library (xlsx)
library(car)
########################################################

########################################################
##   EFFICIENCY INDEX, 3 FIRST TRIES VS 3 LAST ONES   ##

#####----------------------------------------------#####
#####               Import the data                #####
#####----------------------------------------------#####
data <- read.xlsx("2020_09_07_Try_Blow_EFI_wilcoxon.xlsx", sheetName="3_3")
data

#####----------------------------------------------#####
#####                 Divide by series             #####
#####----------------------------------------------#####

## Select 1st series
Try1 <- data[which(data$Try=="T1"),]
Try1

## Select 2nd series
Try2 <- data[which(data$Try=="T2"),]
Try2

#####----------------------------------------------#####
#####          Test assumptions for t-test         #####
#####----------------------------------------------#####
# test the assumption of normality of distribution:
# If p-value<0.05 then the distribution is not normal
shapiro.test(Try1$EFI)
x11(); hist(Try1$EFI)
shapiro.test(Try2$EFI)
x11(); hist(Try2$EFI)

x11(); qqPlot(Try1$EFI)
x11(); qqPlot(Try2$EFI)

# test the assumption of equality of variance:
# if p-value>0.05 => there is no significant difference between the two variances.
var.test(Try1$EFI, Try2$EFI, alternative = "two.sided")

#####----------------------------------------------#####
##### Assumptions for t-test are not respected so: #####
#####----------------------------------------------#####
# independent 2-group non parametric Mann-Whitney U Test
wilcox.test(Try1$EFI, Try2$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try from the same individual

########################################################
#####----------------------------------------------#####
#####         Divide by series and bone            #####
#####----------------------------------------------#####

## Select bones of 1st series
Try1Femur <- data[which(data$Try=="T1" & data$Bone=="Femur"),]
Try1Humerus <- data[which(data$Try=="T1" & data$Bone=="Humerus"),]
Try1RadioUlna <- data[which(data$Try=="T1" & data$Bone=="Radio-Ulna"),]
Try1Tibia <- data[which(data$Try=="T1" & data$Bone=="Tibia"),]

## Select bones of 2nd series
Try2Femur <- data[which(data$Try=="T2" & data$Bone=="Femur"),]
Try2Humerus <- data[which(data$Try=="T2" & data$Bone=="Humerus"),]
Try2RadioUlna <- data[which(data$Try=="T2" & data$Bone=="Radio-Ulna"),]
Try2Tibia <- data[which(data$Try=="T2" & data$Bone=="Tibia"),]

#####----------------------------------------------#####
#####          Test assumptions for t-test         #####
#####----------------------------------------------#####
# test the assumption of normality of distribution for each bone for each try:
# If significant p-value then the distribution is not normal
shapiro.test(Try1Femur$EFI)
x11(); hist(Try1Femur$EFI)
shapiro.test(Try1Humerus$EFI)
x11(); hist(Try1Humerus$EFI)
shapiro.test(Try1RadioUlna$EFI)
x11(); hist(Try1RadioUlna$EFI)
shapiro.test(Try1Tibia$EFI)
x11(); hist(Try1Tibia$EFI)

shapiro.test(Try2Femur$EFI)
x11(); hist(Try2Femur$EFI)
shapiro.test(Try2Humerus$EFI)
x11(); hist(Try2Humerus$EFI)
shapiro.test(Try2RadioUlna$EFI)
x11(); hist(Try2RadioUlna$EFI)
shapiro.test(Try2Tibia$EFI)
x11(); hist(Try2Tibia$EFI)

x11(); qqPlot(Try1Femur$EFI)
x11(); qqPlot(Try1Humerus$EFI)
x11(); qqPlot(Try1RadioUlna$EFI)
x11(); qqPlot(Try1Tibia$EFI)

x11(); qqPlot(Try2Femur$EFI)
x11(); qqPlot(Try2Humerus$EFI)
x11(); qqPlot(Try2RadioUlna$EFI)
x11(); qqPlot(Try2Tibia$EFI)

# test the assumption of equality of variance:
# if p-value>0.05 => there is no significant difference between the two variances.
var.test(Try1Femur$EFI, Try2Femur$EFI, alternative = "two.sided")
var.test(Try1Humerus$EFI, Try2Humerus$EFI, alternative = "two.sided")
var.test(Try1RadioUlna$EFI, Try2RadioUlna$EFI, alternative = "two.sided")
var.test(Try1Tibia$EFI, Try2Tibia$EFI, alternative = "two.sided")

#####-----------------------------------------------------#####
##### Assumptions for t-test are not always respected so: #####
#####-----------------------------------------------------#####
# independent 2-group non parametric Mann-Whitney U Test
wilcox.test(Try1Femur$EFI, Try2Femur$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1Humerus$EFI, Try2Humerus$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1RadioUlna$EFI, Try2RadioUlna$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1Tibia$EFI, Try2Tibia$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual

########################################################
##   EFFICIENCY INDEX, 5 FIRST TRIES VS 5 LAST ONES   ##

#####----------------------------------------------#####
#####               Import the data                #####
#####----------------------------------------------#####
data <- read.xlsx("2020_09_07_Try_Blow_EFI_wilcoxon.xlsx", sheetName="5_5")
data

#####----------------------------------------------#####
#####                 Divide by series             #####
#####----------------------------------------------#####

## Select 1st series
Try1 <- data[which(data$Try=="T1"),]
Try1

## Select 2nd series
Try2 <- data[which(data$Try=="T2"),]
Try2

#####----------------------------------------------#####
#####          Test assumptions for t-test         #####
#####----------------------------------------------#####
# test the assumption of normality of distribution:
# If p-value<0.05 then the distribution is not normal
shapiro.test(Try1$EFI)
x11(); hist(Try1$EFI)
shapiro.test(Try2$EFI)
x11(); hist(Try2$EFI)

x11(); qqPlot(Try1$EFI)
x11(); qqPlot(Try2$EFI)

# test the assumption of equality of variance:
# if p-value>0.05 => there is no significant difference between the two variances.
var.test(Try1$EFI, Try2$EFI, alternative = "two.sided")

#####----------------------------------------------#####
##### Assumptions for t-test are not respected so: #####
#####----------------------------------------------#####
# independent 2-group non parametric Mann-Whitney U Test
wilcox.test(Try1$EFI, Try2$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try from the same individual

########################################################
#####----------------------------------------------#####
#####         Divide by series and bone            #####
#####----------------------------------------------#####

## Select bones of 1st series
Try1Femur <- data[which(data$Try=="T1" & data$Bone=="Femur"),]
Try1Humerus <- data[which(data$Try=="T1" & data$Bone=="Humerus"),]
Try1RadioUlna <- data[which(data$Try=="T1" & data$Bone=="Radio-Ulna"),]
Try1Tibia <- data[which(data$Try=="T1" & data$Bone=="Tibia"),]

## Select bones of 2nd series
Try2Femur <- data[which(data$Try=="T2" & data$Bone=="Femur"),]
Try2Humerus <- data[which(data$Try=="T2" & data$Bone=="Humerus"),]
Try2RadioUlna <- data[which(data$Try=="T2" & data$Bone=="Radio-Ulna"),]
Try2Tibia <- data[which(data$Try=="T2" & data$Bone=="Tibia"),]

#####----------------------------------------------#####
#####          Test assumptions for t-test         #####
#####----------------------------------------------#####
# test the assumption of normality of distribution for each bone for each try:
# If significant p-value then the distribution is not normal
shapiro.test(Try1Femur$EFI)
x11(); hist(Try1Femur$EFI)
shapiro.test(Try1Humerus$EFI)
x11(); hist(Try1Humerus$EFI)
shapiro.test(Try1RadioUlna$EFI)
x11(); hist(Try1RadioUlna$EFI)
shapiro.test(Try1Tibia$EFI)
x11(); hist(Try1Tibia$EFI)

shapiro.test(Try2Femur$EFI)
x11(); hist(Try2Femur$EFI)
shapiro.test(Try2Humerus$EFI)
x11(); hist(Try2Humerus$EFI)
shapiro.test(Try2RadioUlna$EFI)
x11(); hist(Try2RadioUlna$EFI)
shapiro.test(Try2Tibia$EFI)
x11(); hist(Try2Tibia$EFI)

x11(); qqPlot(Try1Femur$EFI)
x11(); qqPlot(Try1Humerus$EFI)
x11(); qqPlot(Try1RadioUlna$EFI)
x11(); qqPlot(Try1Tibia$EFI)

x11(); qqPlot(Try2Femur$EFI)
x11(); qqPlot(Try2Humerus$EFI)
x11(); qqPlot(Try2RadioUlna$EFI)
x11(); qqPlot(Try2Tibia$EFI)

# test the assumption of equality of variance:
# if p-value>0.05 => there is no significant difference between the two variances.
var.test(Try1Femur$EFI, Try2Femur$EFI, alternative = "two.sided")
var.test(Try1Humerus$EFI, Try2Humerus$EFI, alternative = "two.sided")
var.test(Try1RadioUlna$EFI, Try2RadioUlna$EFI, alternative = "two.sided")
var.test(Try1Tibia$EFI, Try2Tibia$EFI, alternative = "two.sided")

#####-----------------------------------------------------#####
##### Assumptions for t-test are not always respected so: #####
#####-----------------------------------------------------#####
# independent 2-group non parametric Mann-Whitney U Test
wilcox.test(Try1Femur$EFI, Try2Femur$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1Humerus$EFI, Try2Humerus$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1RadioUlna$EFI, Try2RadioUlna$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1Tibia$EFI, Try2Tibia$EFI, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual

#######################################################
##   NUMBER OF BLOWS, 3 FIRST TRIES VS 3 LAST ONES   ##

#####----------------------------------------------#####
#####               Import the data                #####
#####----------------------------------------------#####
data <- read.xlsx("2020_09_07_Try_Blow_EFI_wilcoxon.xlsx", sheetName="3_3")
data

#####----------------------------------------------#####
#####                 Divide by series             #####
#####----------------------------------------------#####

## Select 1st series
Try1 <- data[which(data$Try=="T1"),]
Try1

## Select 2nd series
Try2 <- data[which(data$Try=="T2"),]
Try2

#####----------------------------------------------#####
#####          Test assumptions for t-test         #####
#####----------------------------------------------#####
# test the assumption of normality of distribution:
# If p-value<0.05 then the distribution is not normal
shapiro.test(Try1$Blows)
x11(); hist(Try1$Blows)
shapiro.test(Try2$Blows)
x11(); hist(Try2$Blows)

x11(); qqPlot(Try1$Blows)
x11(); qqPlot(Try2$Blows)

# test the assumption of equality of variance:
# if p-value>0.05 => there is no significant difference between the two variances.
var.test(Try1$Blows, Try2$Blows, alternative = "two.sided")

#####----------------------------------------------#####
##### Assumptions for t-test are not respected so: #####
#####----------------------------------------------#####
# independent 2-group non parametric Mann-Whitney U Test
wilcox.test(Try1$Blows, Try2$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try from the same individual

########################################################
#####----------------------------------------------#####
#####         Divide by series and bone            #####
#####----------------------------------------------#####

## Select bones of 1st series
Try1Femur <- data[which(data$Try=="T1" & data$Bone=="Femur"),]
Try1Humerus <- data[which(data$Try=="T1" & data$Bone=="Humerus"),]
Try1RadioUlna <- data[which(data$Try=="T1" & data$Bone=="Radio-Ulna"),]
Try1Tibia <- data[which(data$Try=="T1" & data$Bone=="Tibia"),]

## Select bones of 2nd series
Try2Femur <- data[which(data$Try=="T2" & data$Bone=="Femur"),]
Try2Humerus <- data[which(data$Try=="T2" & data$Bone=="Humerus"),]
Try2RadioUlna <- data[which(data$Try=="T2" & data$Bone=="Radio-Ulna"),]
Try2Tibia <- data[which(data$Try=="T2" & data$Bone=="Tibia"),]

#####----------------------------------------------#####
#####          Test assumptions for t-test         #####
#####----------------------------------------------#####
# test the assumption of normality of distribution for each bone for each try:
# If significant p-value then the distribution is not normal
shapiro.test(Try1Femur$Blows)
x11(); hist(Try1Femur$Blows)
shapiro.test(Try1Humerus$Blows)
x11(); hist(Try1Humerus$Blows)
shapiro.test(Try1RadioUlna$Blows)
x11(); hist(Try1RadioUlna$Blows)
shapiro.test(Try1Tibia$Blows)
x11(); hist(Try1Tibia$Blows)

shapiro.test(Try2Femur$Blows)
x11(); hist(Try2Femur$Blows)
shapiro.test(Try2Humerus$Blows)
x11(); hist(Try2Humerus$Blows)
shapiro.test(Try2RadioUlna$Blows)
x11(); hist(Try2RadioUlna$Blows)
shapiro.test(Try2Tibia$Blows)
x11(); hist(Try2Tibia$Blows)

x11(); qqPlot(Try1Femur$Blows)
x11(); qqPlot(Try1Humerus$Blows)
x11(); qqPlot(Try1RadioUlna$Blows)
x11(); qqPlot(Try1Tibia$Blows)

x11(); qqPlot(Try2Femur$Blows)
x11(); qqPlot(Try2Humerus$Blows)
x11(); qqPlot(Try2RadioUlna$Blows)
x11(); qqPlot(Try2Tibia$Blows)

# test the assumption of equality of variance:
# if p-value>0.05 => there is no significant difference between the two variances.
var.test(Try1Femur$Blows, Try2Femur$Blows, alternative = "two.sided")
var.test(Try1Humerus$Blows, Try2Humerus$Blows, alternative = "two.sided")
var.test(Try1RadioUlna$Blows, Try2RadioUlna$Blows, alternative = "two.sided")
var.test(Try1Tibia$Blows, Try2Tibia$Blows, alternative = "two.sided")

#####-----------------------------------------------------#####
##### Assumptions for t-test are not always respected so: #####
#####-----------------------------------------------------#####
# independent 2-group non parametric Mann-Whitney U Test
wilcox.test(Try1Femur$Blows, Try2Femur$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1Humerus$Blows, Try2Humerus$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1RadioUlna$Blows, Try2RadioUlna$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1Tibia$Blows, Try2Tibia$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual

#######################################################
##   NUMBER OF BLOWS, 5 FIRST TRIES VS 5 LAST ONES   ##

#####----------------------------------------------#####
#####               Import the data                #####
#####----------------------------------------------#####
data <- read.xlsx("2020_09_07_Try_Blow_EFI_wilcoxon.xlsx", sheetName="5_5")
data

#####----------------------------------------------#####
#####                 Divide by series             #####
#####----------------------------------------------#####

## Select 1st series
Try1 <- data[which(data$Try=="T1"),]
Try1

## Select 2nd series
Try2 <- data[which(data$Try=="T2"),]
Try2

#####----------------------------------------------#####
#####          Test assumptions for t-test         #####
#####----------------------------------------------#####
# test the assumption of normality of distribution:
# If p-value<0.05 then the distribution is not normal
shapiro.test(Try1$Blows)
x11(); hist(Try1$Blows)
shapiro.test(Try2$Blows)
x11(); hist(Try2$Blows)

x11(); qqPlot(Try1$Blows)
x11(); qqPlot(Try2$Blows)

# test the assumption of equality of variance:
# if p-value>0.05 => there is no significant difference between the two variances.
var.test(Try1$Blows, Try2$Blows, alternative = "two.sided")

#####----------------------------------------------#####
##### Assumptions for t-test are not respected so: #####
#####----------------------------------------------#####
# independent 2-group non parametric Mann-Whitney U Test
wilcox.test(Try1$Blows, Try2$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try from the same individual

########################################################
#####----------------------------------------------#####
#####         Divide by series and bone            #####
#####----------------------------------------------#####

## Select bones of 1st series
Try1Femur <- data[which(data$Try=="T1" & data$Bone=="Femur"),]
Try1Humerus <- data[which(data$Try=="T1" & data$Bone=="Humerus"),]
Try1RadioUlna <- data[which(data$Try=="T1" & data$Bone=="Radio-Ulna"),]
Try1Tibia <- data[which(data$Try=="T1" & data$Bone=="Tibia"),]

## Select bones of 2nd series
Try2Femur <- data[which(data$Try=="T2" & data$Bone=="Femur"),]
Try2Humerus <- data[which(data$Try=="T2" & data$Bone=="Humerus"),]
Try2RadioUlna <- data[which(data$Try=="T2" & data$Bone=="Radio-Ulna"),]
Try2Tibia <- data[which(data$Try=="T2" & data$Bone=="Tibia"),]

#####----------------------------------------------#####
#####          Test assumptions for t-test         #####
#####----------------------------------------------#####
# test the assumption of normality of distribution for each bone for each try:
# If significant p-value then the distribution is not normal
shapiro.test(Try1Femur$Blows)
x11(); hist(Try1Femur$Blows)
shapiro.test(Try1Humerus$Blows)
x11(); hist(Try1Humerus$Blows)
shapiro.test(Try1RadioUlna$Blows)
x11(); hist(Try1RadioUlna$Blows)
shapiro.test(Try1Tibia$Blows)
x11(); hist(Try1Tibia$Blows)

shapiro.test(Try2Femur$Blows)
x11(); hist(Try2Femur$Blows)
shapiro.test(Try2Humerus$Blows)
x11(); hist(Try2Humerus$Blows)
shapiro.test(Try2RadioUlna$Blows)
x11(); hist(Try2RadioUlna$Blows)
shapiro.test(Try2Tibia$Blows)
x11(); hist(Try2Tibia$Blows)

x11(); qqPlot(Try1Femur$Blows)
x11(); qqPlot(Try1Humerus$Blows)
x11(); qqPlot(Try1RadioUlna$Blows)
x11(); qqPlot(Try1Tibia$Blows)

x11(); qqPlot(Try2Femur$Blows)
x11(); qqPlot(Try2Humerus$Blows)
x11(); qqPlot(Try2RadioUlna$Blows)
x11(); qqPlot(Try2Tibia$Blows)

# test the assumption of equality of variance:
# if p-value>0.05 => there is no significant difference between the two variances.
var.test(Try1Femur$Blows, Try2Femur$Blows, alternative = "two.sided")
var.test(Try1Humerus$Blows, Try2Humerus$Blows, alternative = "two.sided")
var.test(Try1RadioUlna$Blows, Try2RadioUlna$Blows, alternative = "two.sided")
var.test(Try1Tibia$Blows, Try2Tibia$Blows, alternative = "two.sided")

#####-----------------------------------------------------#####
##### Assumptions for t-test are not always respected so: #####
#####-----------------------------------------------------#####
# independent 2-group non parametric Mann-Whitney U Test
wilcox.test(Try1Femur$Blows, Try2Femur$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1Humerus$Blows, Try2Humerus$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1RadioUlna$Blows, Try2RadioUlna$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual
wilcox.test(Try1Tibia$Blows, Try2Tibia$Blows, alternative = "two.sided", paired = TRUE) # paired = TRUE because we are testing paired data, first try and second try be the same individual

#########################################################################################
# Electronic Supplementary Material 4.

# This code provides the results of the PCA presented in the figure 3 of the paper
#########################################################################################

# Make sure to have the "Supplementary_data_15.xlsx" (Supporting Information 15)
# in the same folder as "A_way_to_break_bone.r".

# Packages needed:
# FactoMineR: Lê, S., Josse, J., & Husson, F. (2008). FactoMineR: an R package for multivariate analysis. Journal of statistical software, 25(1), 1-18.
# Factoshiny, Vaissie, P., Monge, A., & Husson, F. (2015). Factoshiny: perform factorial analysis from FactoMineR with a shiny application. R package version, 1.

# Construction of the script:
#     - step 1: import data
#     - step 2: compute PCA
#     - step 3: Plot PCA

###############################################
# Run the necessary libraries
library(xlsx)
library(FactoMineR)
###############################################

###############################################
##           step 1 : import data            ##
###############################################
data <- read.xlsx("Supplementary_data_15.xlsx", sheetIndex=1)
str(data)# observe the structure and verify that the import is correct

#Keep the variable of interest
data.acp <- data[,c(3, 4, 5, 9, 13)]
str(data.acp)

###############################################
##            step 2: Compute PCA            ##
###############################################
res.PCA<-PCA(data.acp, quali.sup=c(2), graph=F)

###############################################
##             step 3: Plot PCA              ##
###############################################
# Graph of variables
x11(); plot(res.PCA, choix="var")

# Graph of individuals
x11(); plotellipses(res.PCA, label="quali", level = 0.95, means = TRUE)

#########################################################################################
# Electronic Supplementary Material 5.

# This code provides the results of the boxplots presented in the figure 2 of the paper
#########################################################################################

# Make sure to have the "2019_07_23_EFI pour box plot.xlsx" (Supporting Information 18)
# in the same folder as "A_way_to_break_bone.r".

# Packages needed:
# ggplot2: Wickham, H. (2011). ggplot2. Wiley Interdisciplinary Reviews: Computational Statistics, 3(2), 180-185.

# Construction of the script:
#     - step 1: import data
#     - step 2: build boxplots for all the series and then for the first 7 and the first 3 series

########################################################
# Run the necessary libraries and function
library (xlsx)
library (ggplot2)

###############################################
###### step 1: import data #########
###############################################
EFI <- read.xlsx("2019_07_23_EFI pour box plot.xlsx", sheetName = "EFIall") # import the sheet "EFIall"
str(EFI)# observe the structure and verify that the import is correct

EFI7 <- read.xlsx("2019_07_23_EFI pour box plot.xlsx", sheetName = "EFI7") # import the sheet "EFI7"
str(EFI7)# observe the structure and verify that the import is correct

EFI3 <- read.xlsx("2019_07_23_EFI pour box plot.xlsx", sheetName = "EFI3") # import the sheet "EFI3"
str(EFI3)# observe the structure and verify that the import is correct

###############################################
###### step 2: boxplot #########
###############################################
# For all series number
names <- c(EFI$Individual)
value <- c(EFI$EFIall)
data <- data.frame(names, value, EFI$Element)
# Open a new window
x11()
ggplot( data, aes(x=as.factor(names) , y=value , fill=EFI$Element))+
  geom_boxplot()+
  labs(x="NIndividual", y = "EFIall")+
  scale_fill_discrete(name="Element")+
  theme_minimal()+
  scale_x_discrete(limits=c("1", "7", "11","2","9","12","3","5","8","4","6","10"))

# For the last seven series number
names <- c(EFI7$Individual)
value <- c(EFI7$EFI7)
data <- data.frame(names,value,EFI7$Element )
# Open a new window
x11()
ggplot( data, aes(x=as.factor(names) , y=value , fill=EFI7$Element))+
  geom_boxplot()+
  labs(x="NIndividual", y = "EFI7")+
  scale_fill_discrete(name="Element")+
  theme_minimal()+
  scale_x_discrete(limits=c("1", "7", "11","2","9","12","3","5","8","4","6","10"))

# For the three first series number
names <- c(EFI3$Individual)
value <- c(EFI3$EFI3)
data <- data.frame(names,value,EFI3$Element )
# Open a new window
x11()
ggplot( data, aes(x=as.factor(names) , y=value , fill=EFI3$Element))+
  geom_boxplot()+labs(x="NIndividual", y = "EFI3")+
  scale_fill_discrete(name="Element")+
  theme_minimal()+
  scale_x_discrete(limits=c("1", "7", "11","2","9","12","3","5","8","4","6","10"))


blah <- read.table("blah.dat", col.names = c("bins", "fft_speed", "dft_speed", "fft_error", "dft_error", "kahan_error"))
fft_speed_model <- deriv(~ a / x / log(x), "a", function(a, x){})
dft_speed_model <- deriv(~ a / x / x, "a", function(a, x){})
fft_error_model <- deriv(~ a * log(x), c("a"), function(a, x){})
dft_error_model <- deriv(~ a * sqrt(x), c("a"), function(a, x){})
fft_speed_fit <- nls(fft_speed ~ fft_speed_model(a, bins), data = blah, start = list(a = 1))
dft_speed_fit <- nls(dft_speed ~ dft_speed_model(a, bins), data = blah, start = list(a = 1))
fft_error_fit <- nls(fft_error ~ fft_error_model(a, bins), data = blah, start = list(a = 1))
dft_error_fit <- nls(dft_error ~ dft_error_model(a, bins), data = blah, start = list(a = 1e-16))
a = coef(fft_speed_fit)
b = coef(dft_speed_fit)
c = coef(fft_error_fit)
d = coef(dft_error_fit)
par(mfrow = c(2, 2))
plot(fft_speed ~ bins, data = blah, log = "xy", main = bquote(.(a)~"/(n*log(n))"), xlab = "bin count (log scale)", ylab = "fft/s (log scale)")
curve(fft_speed_model(a, x), add = TRUE)
plot(dft_speed ~ bins, data = blah, log = "xy", main = bquote(.(b)~"/(n*n)"), xlab = "bin count (log scale)", ylab = "dft/s (log scale)")
curve(dft_speed_model(b, x), add = TRUE)
plot(fft_error ~ bins, data = blah, log = "x", main = bquote(.(c)~"*log(n)"), xlab = "bin count (log scale)", ylab = "fft error (lin scale)")
curve(fft_error_model(c, x), add = TRUE)
plot(dft_error ~ bins, data = blah, log = "xy", main = bquote(.(d)~"*sqrt(n)"), xlab = "bin count (log scale)", ylab = "dft error (log scale)")
curve(dft_error_model(d, x), add = TRUE)


demean <- function(x){
  x-mean(x,na.rm=T)
}

my_pstr <- function(d,y=y,x=x,w=NULL,tv,g_start=2,c_start=.5,tf=1,max_it=100){

  d[,y_t:=demean(y),by=Dyad]
  d[,x_t:=demean(x),by=Dyad]

  if(!is.null(w)){
    d[,paste0(w,"_t") := lapply(.SD,demean),.SDcols=w,by=Dyad]
  }

  tv1 <- as.matrix(d[,..tv])

  ghat1 <- g_start
  chat1 <- quantile(tv1,c_start)
  if(tf==2){
    chat1 <- quantile(tv1,c(c_start-.2,c_start+.2))
  }
  sig1 <- sd(tv1)

  itnum = 0

  repeat{

    itnum = itnum+1

    tf1 <- as.numeric((1+exp(-(ghat1/(sig1))*(tv1-chat1)))^(-1))
    if(tf==2){
      tf1 <- as.numeric((1+exp(-(ghat1/(sig1^2))*(tv1-chat1[1])*(tv1-chat1[2])))^(-1))
    }

    # x0 <- d$x_t

    d[,xg:=(x*tf1)]
    d[,xg_t:=demean(xg),by=Dyad]
    d[,xg_bar:=mean(xg),by=Dyad]

    if(!is.null(w)){
      fmla <- as.formula(paste("y_t~x_t+xg_t+",paste0(w,collapse="+"),"-1",sep=""))
      bhat <- round(lm(fmla,d)$coef,4)
    }else{
      fmla <- as.formula(paste("y_t~x_t+xg_t-1",sep=""))
      bhat <- round(lm(y_t~x_t+xg_t-1,d)$coef,4)
    }

    b <- as.numeric(c(bhat,ghat1,chat1))

    func1 <- paste0("((1+exp(-g1*(",tv,"-c1)/",sig1,"))^(-1))")
    if(tf==2){
      func1 <- paste0("((1+exp(-g1*(",tv,"-c11)*(",tv,"-c12)/",sig1^2,"))^(-1))")
    }

    options(warn=-1)

    if(!is.null(w)){
      if(tf==1){
        names(b) <- c(sprintf("a%d",1),sprintf("b%d",1),sprintf("d%d",1:length(w)),"g1","c1")
        fmla <- as.formula(paste0("y_t~",b["a1"],"*x_t+",b["b1"],"*(x_t*",func1,"-xg_bar)+",paste0(paste(b[3:(length(b)-2)],paste0(w,"_t"),sep="*"),collapse="+")))
        stcoef <- coef(nls(fmla,data=d,start=b[-c(1:(length(b)-2))],control=nls.control(maxiter=1,warnOnly=T),lower=c(.1,quantile(tv1,.1)),upper=c(1000,quantile(tv1,.9)),algorithm = "port"))
      }else{
        names(b) <- c(sprintf("a%d",1),sprintf("b%d",1),sprintf("d%d",1:length(w)),"g1","c11","c12")
        fmla <- as.formula(paste0("y_t~",b["a1"],"*x_t+",b["b1"],"*(x_t*",func1,"-xg_bar)+",paste0(paste(b[3:(length(b)-2)],paste0(w,"_t"),sep="*"),collapse="+")))
        stcoef <- coef(nls(fmla,data=d,start=b[-c(1:(length(b)-3))],control=nls.control(maxiter=1,warnOnly=T),lower=c(.1,quantile(tv1,c(.1,.4))),upper=c(1000,quantile(tv1,c(.6,.9))),algorithm = "port"))
      }
    }else{
      if(tf==1){
        names(b) <- c(sprintf("a%d",1),sprintf("b%d",1),"g1","c1")
        fmla <- as.formula(paste0("y_t~",b["a1"],"*x_t+",b["b1"],"*(x_t*",func1,"-xg_bar)"))
        stcoef <- coef(nls(fmla,data=d,start=b[-c(1:(length(b)-2))],control=nls.control(maxiter=1,warnOnly=T),lower=c(.1,quantile(tv1,.1)),upper=c(1000,quantile(tv1,.9)),algorithm = "port"))
      }else{
        names(b) <- c(sprintf("a%d",1),sprintf("b%d",1),"g1","c11","c12")
        fmla <- as.formula(paste0("y_t~",b["a1"],"*x_t+",b["b1"],"*(x_t*",func1,"-xg_bar)"))
        stcoef <- coef(nls(fmla,data=d,start=b[-c(1:(length(b)-3))],control=nls.control(maxiter=1,warnOnly=T),lower=c(.1,quantile(tv1,c(.1,.4))),upper=c(1000,quantile(tv1,c(.6,.9))),algorithm = "port"))
      }
    }

    if(tf==1){
      if(crossprod(c(ghat1-stcoef["g1"],chat1-stcoef["c1"]))<1e-6){
        break
      }
      ghat1=stcoef["g1"]
      chat1=stcoef["c1"]
    }else{
      if(crossprod(c(ghat1-stcoef["g1"],chat1[1]-stcoef["c11"],chat1[2]-stcoef["c12"]))<1e-6){
        break
      }
      ghat1=stcoef["g1"]
      chat1=stcoef[c("c11","c12")]
    }

    if(ghat1==1000){
      break
    }

    if(itnum==max_it){
      break
    }

  }

  return(stcoef)

}


 DGESDD Example Program Results

 Singular values
     9.9966  3.6831  1.3569  0.5000
 Left singular vectors
          1       2       3       4
 1   0.1921  0.8030  0.0041  0.5642
 2  -0.8794  0.3926 -0.0752 -0.2587
 3   0.2140  0.2980  0.7827 -0.5027
 4  -0.3795 -0.3351  0.6178  0.6017

 Right singular vectors by row (first m rows of V**T)
          1       2       3       4       5       6
 1   0.2774  0.2020  0.2918 -0.0938 -0.4213  0.7816
 2   0.6003  0.0301 -0.3348  0.3699 -0.5266 -0.3353
 3  -0.1277  0.2805  0.6453  0.6781  0.0413 -0.1645
 4  -0.1323 -0.7034 -0.1906  0.5399  0.0575  0.3957

 Error estimate for the singular values
        2.2E-15

 Error estimates for the left singular vectors
        3.5E-16    9.5E-16    2.6E-15    2.6E-15

 Error estimates for the right singular vectors
        3.5E-16    9.5E-16    2.6E-15    4.4E-15


library(xlsx)
options(width=300)
cat("\nTP par: Fortas Mohammed Abdeldjalil Mokhtar\n\n")

data = read.xlsx('./media_prof_afc.xls', header=T, sheetIndex=1)

# listes temporaires
tempLignes <- NULL
tempCols <- 00

# effectif marginal des lignes
for( i in 1:8){
  tempLignes <- c(tempLignes, sum(data[i,tail(-1)]))
}

# effectif marginal des colonnes
for( i in 2:7){
  tempCols <- c(tempCols, sum(data[,i]))
}

newDataFrame <- data
newDataFrame$total <- tempLignes
tempCols <- c(tempCols, sum(tempLignes))
newDataFrame[nrow(newDataFrame) + 1,] = tempCols
cat("\n\nLe résultat est:\n\n")
print(newDataFrame)
rm(tempLignes, tempCols)

# profile ligne
linesDf <- newDataFrame
for (i in 1:8) {
  for (j in 2:8) {
    linesDf[i,j] <- linesDf[i,j]/linesDf[i,ncol(linesDf)]
  }
}
cat("\n\nProfile ligne:\n\n")
print(linesDf[-9,])
rm(linesDf)

# profile colonne
colsDf <- newDataFrame
for (i in 1:9) {
  for (j in 2:7) {
    colsDf[i,j] <- colsDf[i,j]/colsDf[nrow(colsDf),j]
  }
}
cat("\n\nProfile colonne:\n\n")
print(colsDf[,-8])
rm(colsDf)

# effectif theorique
total = newDataFrame[nrow(newDataFrame),ncol(newDataFrame)]
efcMat = newDataFrame
for (i in 1:8) {
  for (j in 2:7) {
    efcMat[i,j] <- (efcMat[i, ncol(efcMat)] * efcMat[nrow(efcMat), j])/total
  }
}
cat("\n\nEffectif calculé\n\n")
print(efcMat[-9,-8])

# khi2
khiMat = newDataFrame
for (i in 1:8) {
  for (j in 2:7) {
    khiMat[i,j] <- ((newDataFrame[i,j]-efcMat[i,j])**2)/efcMat[i,j]
  }
}
cat("\n\nKhi2:\n")
print(sum(khiMat[1:8,2:7]))


# # check of code on hjcondvine.R
#
# library(CopulaModel)
# source("hjcondvine.R")
# d=5
# np=matrix(1,d,d)
# ntrunc=4
# udat=matrix(c(.1,.2,.3,.4,.5, .6,.7,.8,.9,.5),2,5,byrow=T)
# parvec=c(2,2,2,2,1.5,1.5,1.5,1.2,1.2,1.1)
#
# # D-vine
# D5=Dvinearray(d)
# pcondmat=matrix("pcondgum",d,d)
# qcondmat=matrix("qcondgum",d,d)
#
# pmatd=rvinepcond(parvec,udat,D5,ntrunc,pcondmat,np)
# print(pmatd)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7385935 0.8312337 0.8782010
# #[2,]  0.6 0.7328919 0.8830648 0.9754268 0.1403602
#
# qmatd=rvineqcond(pmatd,D5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatd) # same as udat
#
# q5=rvineqcond(pmatd,D5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q5)
# # [1] 0.5 0.5
# pnewd=pmatd; pnewd[,d]=0.9
# q5b=rvineqcond(pnewd,D5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q5b)
# # [1] 0.5227173 0.8994989
#
# # truncated vine
# pmatd2=rvinepcond(parvec,udat,D5,2,pcondmat,np)
# print(pmatd2)
# #      [,1]      [,2]      [,3]      [,4]       [,5]
# #[1,]  0.1 0.4938008 0.7385935 0.7430672 0.76377507
# #[2,]  0.6 0.7328919 0.8830648 0.9508236 0.08757126
# qmatd2=rvineqcond(pmatd2,D5,2,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatd2) # same as udat
# q52=rvineqcond(pmatd2,D5,2,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q52)
# # [1] 0.5 0.5
# pnewd=pmatd2; pnewd[,d]=0.9
# q52b=rvineqcond(pnewd,D5,2,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q52b)
# # [1] 0.6190225 0.9281953
#
# # ============================================================
#
# # C-vine
# C5=Cvinearray(d)
# pmatc=rvinepcond(parvec,udat,C5,ntrunc,pcondmat,np)
# print(pmatc)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7228406 0.8433683 0.9167192
# #[2,]  0.6 0.7328919 0.8700505 0.9776872 0.1262401
#
# qmatc=rvineqcond(pmatc,C5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatc) # same as udat
#
# q5=rvineqcond(pmatc,C5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q5)
# # [1] 0.5 0.5
# pnewc=pmatc; pnewc[,d]=0.9
# q5b=rvineqcond(pnewc,C5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q5b)
# # [1] 0.4800962 0.8916635
#
# # different truncation levels
# pmatc3=rvinepcond(parvec,udat,C5,3,pcondmat,np)
# print(pmatc3)
# #     [,1]      [,2]      [,3]      [,4]      [,5]
# #[1,]  0.1 0.4938008 0.7228406 0.8433683 0.9319560
# #[2,]  0.6 0.7328919 0.8700505 0.9776872 0.1922732
#
# qmatc3=rvineqcond(pmatc3,C5,3,parvec,np,qcondmat,pcondmat,iinv=F)
# print(qmatc3) # same as udat
# q53=rvineqcond(pmatc3,C5,3,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q53)
# # [1] 0.5 0.5
# pnewc=pmatc3; pnewc[,d]=0.9
# q53b=rvineqcond(pnewc,C5,3,parvec,np,qcondmat,pcondmat,iinv=T)
# print(q53b)
# # [1] 0.4562103 0.8437685
#
# # different quantiles of case 1
#
# newpmatc=matrix(pmatc[1,],9,d,byrow=T)
# newpmatc[,d]=seq(.1,.9,.1)
# print(newpmatc)
# #      [,1]      [,2]      [,3]      [,4] [,5]
# # [1,]  0.1 0.4938008 0.7228406 0.8433683  0.1
# # [2,]  0.1 0.4938008 0.7228406 0.8433683  0.2
# # [3,]  0.1 0.4938008 0.7228406 0.8433683  0.3
# # [4,]  0.1 0.4938008 0.7228406 0.8433683  0.4
# # [5,]  0.1 0.4938008 0.7228406 0.8433683  0.5
# # [6,]  0.1 0.4938008 0.7228406 0.8433683  0.6
# # [7,]  0.1 0.4938008 0.7228406 0.8433683  0.7
# # [8,]  0.1 0.4938008 0.7228406 0.8433683  0.8
# # [9,]  0.1 0.4938008 0.7228406 0.8433683  0.9
#
# newqmatc=rvineqcond(newpmatc,C5,ntrunc,parvec,np,qcondmat,pcondmat,iinv=T)
# print(newqmatc)
# # [1] 0.06239024 0.10819359 0.15071992 0.19263156 0.23561800 0.28141551 0.33255194
# # [8] 0.39398474 0.48009621


source("R/EpiProgInf.r")
source("R/makebetas.R")

n.sims <-  500 # number of simulations
 n.epis <- 100 #number of simulated epidemics per simulation

 fs <- matrix(nrow=n.epis, ncol=n.sims) #matrix to hold final sizes
 pcts <- matrix(nrow=n.epis, ncol=n.sims) #matrix to hold proportion complete at time of simulation

 #initialize each model

 K.VC_linear <- fs
 K.VC_rpart <- fs
 K.VC_super <- fs
 K.norm_linear <-fs
 K.norm_rpart <-fs
 K.norm_super <- fs
 K.VC_alone <- fs
 K.norm_alone <- fs
 K.linear_alone <- fs
 K.rpart_alone <- fs
 K.super_alone <- fs

 for (i in 1:n.sims) {

   cat("iteration ", i, "\n")

  x <- runif(n.epis, 0, 3)
  fs[,i] <- rpois(n.epis, 1000*3^x)
  pcts[,i] <- runif(n.epis, .05,1)

  ecs <- gen.epicurves.ViboudChowell(pcts[,i], fs[,i], r = 1, p = 0.6)

  dat <- data.frame(K=2*sapply(ecs,sum),
                    x=x)

  K.VC_linear[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.linear.fit,
                               epi.mdl.ViboudChowell.fit2,
                               stat.mdl.linear.pred,
                               epi.mdl.ViboudChowell.pred2,
                               threshold = 1)$K

  K.VC_rpart[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.rpart.fit,
                               epi.mdl.ViboudChowell.fit2,
                               stat.mdl.rpart.pred,
                               epi.mdl.ViboudChowell.pred2,
                               threshold = 1)$K

   K.VC_super[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.sl.fit,
                               epi.mdl.ViboudChowell.fit2,
                               stat.mdl.sl.pred,
                               epi.mdl.ViboudChowell.pred2,
                               threshold = 1)$K

  K.norm_linear[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.linear.fit,
                               epi.mdl.normcurve.fit,
                               stat.mdl.linear.pred,
                               epi.mdl.normcurve.pred,
                               threshold = 1)$K

  K.norm_rpart[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.rpart.fit,
                               epi.mdl.normcurve.fit,
                               stat.mdl.rpart.pred,
                               epi.mdl.normcurve.pred,
                               threshold = 1)$K

   K.norm_super[,i] <- epiInf.EM(ecs, dat,
                               stat.mdl.sl.fit,
                               epi.mdl.normcurve.fit,
                               stat.mdl.sl.pred,
                               epi.mdl.normcurve.pred,
                               threshold = 1)$K

   K.VC_alone[,i] <- epi.mdl.ViboudChowell.init2(ecs)$K

   K.norm_alone[,i] <- epi.mdl.normcurve.init(ecs)$K

   tmp.dat <- dat
   tmp.dat$K <- sapply(ecs, sum)

   print("RPART STAT")
   K.rpart_alone[,i] <- stat.mdl.rpart.pred(stat.mdl.rpart.fit(tmp.dat))

   print("RPART LIN")
   K.linear_alone[,i] <- stat.mdl.linear.pred(stat.mdl.linear.fit(tmp.dat))

   print("RPART SUPER")
   K.super_alone[,i] <- stat.mdl.sl.pred(stat.mdl.sl.fit(tmp.dat))
 }

save(pcts, fs, K.VC_linear, K.VC_rpart, K.VC_super, K.norm_linear, K.norm_rpart, K.norm_super,
     K.VC_alone, K.norm_alone, K.rpart_alone, K.linear_alone, K.super_alone, file="VCSingleVarRuns100.RData")


source("./nimble_utilities.r")
mod_multi_country_mixture <- nimbleCode({

	for(p in 1:N_countries){

		s_xi[p]     ~ dinvgamma(1,1)
		s_lomega[p] ~ dinvgamma(1,1)
		s_alpha[p]  ~ dinvgamma(1,1)
		s_mu[p]     ~ dinvgamma(1,1)
		s_lsigma[p] ~ dinvgamma(1,1)
		s_eta1[p]   ~ dinvgamma(1,1)
		s_eta2[p]   ~ dinvgamma(1,1)

		# Drift parameters
		drift_xi[p] ~ dnorm(mean = 0, sd = 1)
		drift_lomega[p] ~ dnorm(mean = 0, sd = 1)
		drift_alpha[p] ~ dnorm(mean = 0, sd = 1)

		drift_mu[p] ~ dnorm(mean = 0, sd = 1)
		drift_lsigma[p] ~ dnorm(mean = 0, sd = 1)

		drift_eta1[p] ~ dnorm(mean = 0, sd = 1)
		drift_eta2[p] ~ dnorm(mean = 0, sd = 1)

		m_xi_0[p] ~ dnorm( mean = m_xi, sd = 1)
		m_lomega_0[p] ~ dnorm( mean = m_lomega, sd = 1)
		m_alpha_0[p] ~ dnorm( mean = m_alpha, sd = 1)
		m_mu_0[p] ~ dnorm( mean = m_mu, sd = 1)
		m_lsigma_0[p] ~ dnorm( mean = m_lsigma, sd = 1)
		m_eta1_0[p] ~ dnorm( mean = m_eta1, sd = 1)
		m_eta2_0[p] ~ dnorm( mean = m_eta2, sd = 1)

		# random walk. First observation
		xi[p,1] ~ dnorm(mean     =  m_xi_0[p], var = s_xi[p])
		lomega[p,1] ~ dnorm(mean =  m_lomega_0[p], var = s_lomega[p])
		alpha[p,1] ~ dnorm(mean  =  m_alpha_0[p], var = s_alpha[p])

		mu[p,1] ~ dnorm(mean     =  m_mu_0[p], var = s_mu[p])
		lsigma[p,1] ~ dnorm(mean =  m_lsigma_0[p], var = s_lsigma[p])

		eta1[p,1] ~ dnorm(mean = m_eta1_0[p], var = s_eta1[p])
		eta2[p,1] ~ dnorm(mean = m_eta2_0[p], var = s_eta2[p])
	}

	#++++++++++++++++++++++++++++++++++++++++++++++++++
	# Time recursion: multivariate random walk + drift
	#++++++++++++++++++++++++++++++++++++++++++++++++++

	for(p in 1:N_countries){
		for (tt in 2:Time){
			xi[p,tt] ~ dnorm(mean = drift_xi[p] + xi[p, tt-1], var = s_xi[p])
			lomega[p,tt] ~ dnorm(mean = drift_lomega[p] + lomega[p, tt-1], var = s_lomega[p])
			alpha[p,tt] ~ dnorm(mean = drift_alpha[p] + alpha[p, tt-1], var = s_alpha[p])

			mu[p,tt] ~ dnorm(mean = drift_mu[p] + mu[p, tt-1], var = s_mu[p])
			lsigma[p,tt] ~ dnorm(mean = drift_lsigma[p] + lsigma[p, tt-1], var = s_lsigma[p])

			eta1[p,tt] ~ dnorm(mean = drift_eta1[p] + eta1[p, tt-1], var = s_eta1[p])
			eta2[p,tt] ~ dnorm(mean = drift_eta2[p] + eta2[p, tt-1], var = s_eta2[p])

		}

	}

	# multinomial likelihood
	for(p in 1:N_countries){

		for(tt in 1:Time) {
			# We use a different parametrization here, cumulative logit
			# works better in practice
			w[p,3,tt] <- expit(eta1[p,tt] )
			w[p,2,tt] <- expit(eta2[p,tt]) * expit(-eta1[p,tt])
			w[p,1,tt] <- 1 - w[p,2,tt] - w[p,3,tt]
			#w[p,1,tt] <- expit(-eta2[p,tt]) * expit(-eta1[p,tt])

			probs[p,1:n,tt] <- link_func(x[1:n],w[p,1:3,tt],
						     mu[p,tt],lsigma[p,tt],
						     xi[p,tt],lomega[p,tt],alpha[p,tt])
			y[p,1:n,tt] ~ dmulti(probs[p,1:n,tt],N[p,tt])

		}

	}
})


library(MASS)

General_Euler_Multi_D <- function(num_of_paths, num_of_steps, mu, sigma, cov_matrix, Texp=1, X0=0, convert_y_to_x_func=function(y) y){
    # Simulate a 1-dimensional process using Monte Carlo with the standard Euler scheme.
    # This can be used to simulate the payoff of an option and calculate the implied volatility smile.
    #
    # Args:
    #     num_of_paths (int): The number of Monte Carlo paths
    #     num_of_steps (int): The number of steps in each Monte Carlo path
    #     mu (vector of functions): A vector of the drift coefficient functions, a function of t (float) and X (array-like) returning a scalar
    #     sigma (vector of functions): A vector of the diffusion coefficient, a function of t (float) and X (array-like) returning a scalar
    #     cov_matrix (matrix of floats): A covariance matrix of the diffusion
    #     Texp (Optional[float]): Time, in years, to simulate process. Defaults to 1.
    #     X0 (vector of floats): Initial values for each of the process, Xhat. Defaults to 0.
    #     convert_y_to_x (function): A function to convert Y_t to X_t. Defaults to X_t <- Y_t
    # Returns:
    #     (list of function): A list with a single entry - the run_monte_carlo function stored in the key run_monte_carlo

    # Check that the inputs are correct dimensions
    if (!is.vector(mu)) stop('mu must be a vector')
    if (!is.vector(sigma)) stop('sigma must be a vector')
    num_dim <- length(mu)
    if (num_dim != length(sigma)) stop('mu and sigma must be the same length')
    if (nrow(cov_matrix) != num_dim) stop('cov_matrix must be the same size as mu and sigma')

    dt <- Texp / num_of_steps

    run_monte_carlo <- function(g_maker, strikes, num_paths_to_plot=FALSE){
        # Runs the Monte Carlo simulation to calculate E[g(X_T)] for different strikes.
        #
        # Args:
        #     g_maker (function): A function that returns a function f(x) <- g(x,K)
        #     strikes (array-like): An array of strikes to pass in to g_maker
        #     num_paths_to_plot (Optional[integer or logical]): How many paths should be plotted. Defaults to FALSE.  If TRUE, defaults to 100. (NOT USED)
        # Returns:
        #     (array-like): A array of E[g(X_T)] for the range of strikes

        # Simulates the process X across time.
        # X is a 3-dimensional array-like:
        #     -The first dimension represents the dimensions of the process
        #     -The second dimension represents the timesteps.
        #     -The third dimension represents the paths. Each "sheet" is a path.

        # Generate dW and put it into the correct 3-dimensional form described above
        dW <- mvrnorm(n=num_of_paths*num_of_steps, mu=rep(0, num_dim), Sigma=dt*cov_matrix)
        dW <- t(dW) # Transposed so that time goes across cols instead of rows
        dim(dW) <- c(num_dim, num_of_steps, num_of_paths)

        # Generate X
        X <- array(rep(NA, num_dim*(num_of_steps+1)*num_of_paths), c(num_dim, num_of_steps+1, num_of_paths))
        X[,1,] <- X0
        for (t in 1:num_of_steps)
            #for (d in 1:num_dim)
            #    X[d,t+1,] <- X[d,t,] + mu[[d]]((t-1)*dt, X[,t,]) * dt + sigma[[d]]((t-1)*dt, X[,t,]) * dW[d,t,]

            # Hard code for Section 5.2
            X[,t+1,] <- X[,t,]*exp(0.5*dW[,t,] + (0.1*(sqrt(X[,t,])-1) - 1/8)*dt)

        #X_Ts <- sapply(X[,ncol(X),], convert_y_to_x_func)
        X_Ts <- X[,ncol(X),]

        return(vapply(strikes, function(K) mean(g_maker(K)(X_Ts)), FUN.VALUE=1))
    }
    return(list(run_monte_carlo=run_monte_carlo)) # Return a list holding the function so we can call it oop style
}


softmax <- function(par){
  n.par <- length(par)
  par1 <- sort(par, decreasing = TRUE)
  Lk <- par1[1]
  for (k in 1:(n.par-1)) {
    Lk <- max(par1[k+1], Lk) + log1p(exp(-abs(par1[k+1] - Lk)))
  }
  val <- exp(par - Lk)
  return(val)
}
# data must have x1, which is the lagged value. It uses this to estimate the cohorts.
# The model matrix can be whatever, but it must have authoritarianism, scaled 0 to 1

#### Incorporate this block into my code below. Align the distributions
######################################################################
# This block can just go in the plotting part, add a place for
# Pass "mod formula" -- or dissect from other mod formula ###
# The rest can be dumped into that function. Main by authoritarianism
# generates the probability of each category

################################################################################################################
####################### Main Effects Estimates: Probability of cat 1-5, each time point #######################
################################################################################################################

main_by_authoritarianism = function(mod_formula = MOD1, data = tmp_data, ....){
      y.var <- all.vars(mod_formula)[1]
      x.var <- data[, nlme::Names(mod_formula, data)[-1]]
      models = list()
      tmp = nnet::multinom(mod_formula,
                        data = data)
      models <- rbind(0, coef(tmp) )
      ## Generate linear predictions ###
      low_auth =  x.var %>%  mutate(latent =0)
      low_auth = data.frame(1, low_auth)
      high_auth =  x.var %>% mutate(latent =1)
      high_auth = data.frame(1, high_auth)
      # Construct the transition matrix for the ith value of the IV....
      linear_effect1 <- c()
      linear_effect2 <- c()
      for(i in 1:nrow(models)){
          linear_effect1 <- rbind(linear_effect1,  models[i,] %*% t(low_auth) %>% t() %>%  mean())
          linear_effect2 <- rbind(linear_effect2,  models[i,] %*% t(high_auth) %>% t() %>% mean())
        }
      out1 = linear_effect1  %>% t %>% softmax()
      out2 = linear_effect2  %>% t %>% softmax()
        return(list(low_auth = out1, high_auth = out2))
}

################################################################################################################
####################### Transition Estimates                                             #######################
################################################################################################################

transition_by_authoritarianism_boot = function(data = data, indices,
                                               mod_formula, authoritarianism = 0){
                                              .df = data[indices, ]
                                                y.var <- .df[,  c(1:2)]
                                                x.var <- .df[,  c(3:ncol(.df))]
                                              models = list()
                                              for(i in 1:length(unique(.df$x1))){
                                                tmp = multinom(mod_formula,
                                                              data = subset(.df, x1 ==i))
                                                models[[i]] <- rbind(rep(0, times = (ncol(x.var) + 1)), coef(tmp) )
                                              }
                                              ## Generate linear predictions ###
                                              low_auth =  x.var %>%  mutate(authoritarianism =0)
                                              low_auth = data.frame(int = 1, low_auth)
                                              high_auth =  x.var %>% mutate(authoritarianism =1)
                                              high_auth = data.frame(int = 1, high_auth)
                                              # Construct the trhansition matrix for the ith value of the IV....
                                              linear_effect1 <- c()
                                              linear_effect2 <- c()
                                              for(k in 1:length(models)){
                                                for(i in 1:nrow(models[[k]])){
                                                  linear_effect1 <- rbind(linear_effect1,  models[[k]][i,] %*% t(low_auth) %>%  mean())
                                                  linear_effect2 <- rbind(linear_effect2,  models[[k]][i,] %*% t(high_auth) %>% mean())
                                                }
                                              }

                                              linear_effect1 = linear_effect1 %>% matrix(ncol = 5)
                                              linear_effect2 = linear_effect2 %>% matrix(ncol = 5)
                                              out1 <- matrix(NA, nrow = nrow(linear_effect1), ncol = 5)
                                              out2 <- matrix(NA, nrow = nrow(linear_effect1), ncol = 5)
                                              for(i in 1:nrow(out1)){
                                                out1[i,] <- softmax(linear_effect1[,i])
                                                out2[i,] <- softmax(linear_effect2[,i])
                                              }
                                              me = out2 - out1
                                              if(authoritarianism ==0) return(t(out1))
                                              if(authoritarianism ==1) return(t(out2))
}
# Wrapper to generate effects, need to just pass the ncessary plot parms
# Returns marginal distributions for each variable and the transition plot
draw_transition_effects = function(tran = low,
                                   data = tmp_data,
                                   mod1 = MOD1,
                                   mod2 = MOD2,
                                   auth_score = c("AUTH", "NON"),
                                   CAT_LABELS,
                                   x.label = "2016 Election",
                                   y.label = "2020 Election",
                                   alpha = 0.25,
                                   axis.text.size = 10,
                                   axis.label.size = 10,
                                   vote = 0,
                                   ...
                                   ){
                        t1 = main_by_authoritarianism(mod1, data)
                        t2 = main_by_authoritarianism(mod2, data)
                        marginal_data = data.frame(
                            x                 = rep(c(1:length(t1$low_auth)), times = 4),
                            y                 = c(unlist(t1), unlist(t1)),
                            authoritarianism  = rep(c(0,1), each = length(t1$low_auth)),
                            period            = rep(c(1,2), each = length(t1$low_auth)*2)
                        )

                       if(auth_score == "NON"){
                        tempdat1 = subset(marginal_data, period == 1 & authoritarianism == 0)
                        tempdat2 = subset(marginal_data, period == 2 & authoritarianism == 0)
                        mplot = ggplot(mapping = aes(x=x, y=y)) +
                          geom_bar(data = tempdat1, stat="identity", width = 0.8, fill = "#746c6c", alpha = 0.4) +
                          coord_flip() +
                          scale_x_discrete("", limits = factor(c(1:5))) +
                          scale_fill_grey() +
                          theme(panel.border = element_blank()) +
                          theme(panel.background = element_blank()) +
                          theme(axis.text = element_blank(),
                                axis.ticks = element_blank(),
                                axis.title = element_blank())
                       }
                      if(auth_score == "AUTH"){
                        tempdat1 = subset(marginal_data, period == 1 & authoritarianism == 1)
                        tempdat2 = subset(marginal_data, period == 2 & authoritarianism == 1)
                        mplot = ggplot(mapping = aes(x=x, y=y)) +
                          geom_bar(data = tempdat1, stat="identity", width = 0.8, fill = "#746c6c", alpha = 0.4) +
                          coord_flip() +
                          scale_x_discrete("", limits = factor(c(1:5))) +
                          scale_fill_grey() +
                          theme(panel.border = element_blank()) +
                          theme(panel.background = element_blank()) +
                          theme(axis.text = element_blank(),
                                axis.ticks = element_blank(),
                                axis.title = element_blank())
                       }
        plot_dat = data.frame(
            score =  c(tran),
            t1    = rep(CAT_LABELS, times = length(c(low))),
            t2    = rep(CAT_LABELS, each =  length(CAT_LABELS))
            )
            plot_dat$gridx = car::recode(plot_dat$t1,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; "))
            plot_dat$gridy = car::recode(plot_dat$t2,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; "))
            plot_dat$sizes = tempdat1$y * plot_dat$score
            plot_dat$lab =   as.character(round(plot_dat$score, 3))
            #plot_dat$mean * plot_dat$x1 * plot_dat$x2
            if(vote == 0){
            plot_dat$colour = rep(c("#3355FF", "#33C7FF", "#9F33FF", "#EC747D", "#D0000F"),
                              each = nrow(plot_dat)/5)
            }
            else{
            plot_dat$colour = rep(c("#3355FF", "#D0000F"),
                              each = nrow(plot_dat)/2)
            }
if(vote == 0){
   label.x =c("1" = "Democrat", "2" = "Lean Democrat",
                               "3" = "Independent",
                               "4" = "Lean Republican", "5" = "Republican")
    label.y =c("1" = "Dem", "2" = "Lean Dem",
                               "3" = "Ind",
                                "4" = "Lean Rep", "5" = "Rep")
}

if(vote == 1){
   label.x =c("1" = "Vote Democrat", "2" = "Vote Republican")
   label.y =c("1" = "Democrat", "2" = "Republican")
}

  a = ggplot(plot_dat,
                 aes(y = as.factor(gridy), x = as.factor(gridx))) +
    geom_point(alpha = .0001) +
    scale_size(range = c(4,9), name="Cell Sizes") +
    theme(panel.background=element_rect(fill="white")) +
    scale_x_discrete(x.label,
                     labels =label.x) +
    scale_y_discrete(y.label,
                     labels = label.y, position = "right") +
    geom_text(aes(label = lab, size = sizes))  + coord_flip()  +
    theme(legend.position = "none",
           axis.text=element_text(size=axis.text.size),
           axis.title=element_text(size=axis.label.size))

    return(list (a, mplot))
}
pid.r<-function(x){
  return(car::recode(x, "1:2=1; 3=2; 4=3; 5=4; 6:7=5"))
}

latent_model =  function(formula = FORMULA,  ordered = ORDERED,
                        data = DATA){
                data$identifier = seq(1:nrow(data))
                model = cfa(formula, ordered=ordered, data=data)
                a= lavPredict(model, append.data = TRUE,  assemble = TRUE) %>%  as.data.frame()
                a$identifier = seq(1:nrow(a))
                a$latent = a$latent %>% zero.one()
                temp =  merge(data, a, "identifier", all.x = T)
                return(temp)
                        }

msm_fit = function(data = data_long,
         starts =  twoway2.q,
         covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college"),
         time = 1,
         fixed_values = list(authoritarianism = 0, sex = 0),
         category_labels = CAT_LABELS){
         model<-msm(state~time, covariates = as.formula(paste0("~", paste0(covariates, collapse = "+"))),
           subject=id, data=data_long,
           qmatrix= twoway2.q,, obstype=1,
           method="BFGS",
           control=list(trace=1,
           REPORT=1,fnscale=10, maxit=10000))
        tran <- pmatrix.msm(model, t=time, ci="none", covariates = fixed_values) %>% c() %>% matrix(ncol = length(category_labels))
        rownames(tran) <- colnames(tran)  <- CAT_LABELS
        return(tran)
}
twoway2.q<-rbind(c(0,0.20),
                 c(0.2, 0))

education_effects = function(data_long = data_long,
                             timer = 1,
                             x.label = "2000 Election",
                             y.label = "2004 Election",
                             label.x =c("1" = "Vote Democrat", "2" = "Vote Republican") ,
                             label.y =c("1" = "Democrat", "2" = "Republican")
    ){
                                                plot_dat = data.frame(
                                                    score = c(
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 0, college = 0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 0, college = 1),
                                                        time = timer,
                                                        category_labels = CAT_LABELS) %>% c(),
                                                        msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 1, college = 0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 1, college = 1),
                                                        time = timer,
                                                        category_labels = CAT_LABELS) %>% c()),
                                                    education = rep(c("No College", "College"), each = 4),
                                                    authoritarianism = rep(c("Non-Authoritarian", "Authoritarian"), each = 4*2),
                                                    t1    = rep(CAT_LABELS),
                                                    t2    = rep(CAT_LABELS, each =  length(CAT_LABELS))
                                                    )
                                                    plot_dat$gridx = car::recode(plot_dat$t1,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; ")) %>% as.numeric
                                                    plot_dat$gridy = car::recode(plot_dat$t2,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; ")) %>% as.numeric
                                                    plot_dat$lab =   as.character(round(plot_dat$score, 3))

                                                    p =  ggplot(plot_dat,
                                                                    aes(y = as.factor(gridy), x = as.factor(gridx))) +
                                                                    facet_wrap(~authoritarianism + education) +
                                                        geom_point(alpha = .0001) +
                                                        scale_size(range = c(4,9), name="Cell Sizes") +
                                                        theme(panel.background=element_rect(fill="white")) +
                                                        geom_text(aes(label = lab))  + coord_flip() +
                                                        scale_x_discrete(x.label,
                                                                        labels =label.x) +
                                                        scale_y_discrete(y.label,
                                                                        labels = label.y, position = "left")
                                                return(p)

}

education_effects_interaction = function(data_long = data_long,
                             timer = 1,
                             x.label = "2000 Election",
                             y.label = "2004 Election",
                             label.x =c("1" = "Vote Democrat", "2" = "Vote Republican") ,
                             label.y =c("1" = "Democrat", "2" = "Republican")
    ){
                                                plot_dat = data.frame(
                                                    score = c(
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 0, college = 0, authXcollege =0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS,
                                                       covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college", "authXcollege")) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 0, college = 1,  authXcollege =0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS,
                                                        covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college", "authXcollege")) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 1, college = 0,  authXcollege =0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS,
                                                        covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college", "authXcollege")) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 1, college = 1, authXcollege =1),
                                                        time = timer,
                                                        category_labels = CAT_LABELS,
                                                        covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college", "authXcollege")) %>% c()),
                                                    education = rep(c("No College", "College"), each = 4),
                                                    authoritarianism = rep(c("Non-Authoritarian", "Authoritarian"), each = 4*2),
                                                    t1    = rep(CAT_LABELS),
                                                    t2    = rep(CAT_LABELS, each =  length(CAT_LABELS))
                                                    )
                                                    plot_dat$gridx = car::recode(plot_dat$t1,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; ")) %>% as.numeric
                                                    plot_dat$gridy = car::recode(plot_dat$t2,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; ")) %>% as.numeric
                                                    plot_dat$lab =   as.character(round(plot_dat$score, 3))

                                                    p =  ggplot(plot_dat,
                                                                    aes(y = as.factor(gridy), x = as.factor(gridx))) +
                                                                    facet_wrap(~authoritarianism + education) +
                                                        geom_point(alpha = .0001) +
                                                        scale_size(range = c(4,9), name="Cell Sizes") +
                                                        theme(panel.background=element_rect(fill="white")) +
                                                        geom_text(aes(label = lab))  + coord_flip() +
                                                        scale_x_discrete(x.label,
                                                                        labels =label.x) +
                                                        scale_y_discrete(y.label,
                                                                        labels = label.y, position = "left")
                                                return(p)

}


# Example of application of the R functions related to the paper:
#
# "A shared-parameter continuous-time hidden Markov and survival model for longitudinal data
#  with informative drop-out"
# by F.Bartolucci and A.Farcomeni (2018)

# Simulation of data (see the function code for the help)

# Normal distribution for the responses
source("simulate_joint_HMcontinuous.r")
out = simulate_joint_HMcontinuous()

# Estimate with complete data
tT = out$tT   # time of any (time-continuous jump)
TT = out$TT   # observation times
tU = out$tU   # latent states
TT = out$TT   # time of observation of any longitudinal outcome
W = out$W     # matrix of baseline covariates
X = out$X     # array of time-varying covariates
Y = out$Y     # array of time-varying covariates
tv = out$tv   # vector of survival times
dev = out$dev # vector of censoring
source("est_comp_joint_HMcontinuous.r")
est = est_comp_joint_HMcontinuous(tT,tU,TT,W,X,Y,tv,dev,k=k0,type="norm")

# Estimate with incomplete data
source("est_incomp_joint_HMcontinuous.r")
est1 = est_incomp_joint_HMcontinuous(Y,TT,X,W,tv,dev,k=k0,type="norm",verbose=TRUE,stderr=TRUE)

# Bernoulli distribution for the responses
out1 = simulate_joint_HMcontinuous(n=500,type="bino")

# Estimate under with complete data
tT = out1$tT   # time of any (time-continuous jump)
TT = out1$TT   # observation times
tU = out1$tU   # latent states
TT = out1$TT   # time of observation of any longitudinal outcome
W = out1$W     # matrix of baseline covariates
X = out1$X     # array of time-varying covariates
Y = out1$Y     # array of time-varying covariates
tv = out1$tv   # vector of survival times
dev = out1$dev # vector of censoring
est2 = est_comp_joint_HMcontinuous(tT,tU,TT,W,X,Y,tv,dev,k=k0,type="bino")

# Estimate with incomplete data
source("est_incomp_joint_HMcontinuous.r")
est3 = est_incomp_joint_HMcontinuous(Y,TT,X,W,tv,dev,k=k0,type="bino",verbose=TRUE,stderr=TRUE)


#' @name bc
#' @aliases jaccard
#' @title Compute dissimilarity indices
#' @param comm Community matrix giving sites (rows) by species (columns); values are abundances. Column and row labels are highly recommended
#' @return Site by site dissimilarity matrix
#' @rdname bc
#' @export
bc <- function(comm)
{
	# get min abundance of shared species
	# pretty slow right now because it uses nested applies
	# a fast way to do this would be great
	shared_abundance <- apply(comm, 1, function(site1) {
		apply(comm, 1, function(site2) {
			mask <- site1 <= site2
			sum((site1 * mask) + ((!mask) * site2))
		})
	})

	# total abundance at each site for each pairwise combo
	site1 <- matrix(rowSums(comm), nrow=nrow(comm), ncol=nrow(comm))
	site2 <- t(site1)

	1.0 - ((2.0 * shared_abundance)/(site1 + site2))
}

#' @rdname bc
#' @export
jaccard <- function(comm)
{
	# get the intersection of all sites - number of sp in common
	site_similarity <- comm %*% t(comm)
	richness <- rowSums(comm)
	# make richness matrices for comparisons
	ra <- matrix(richness, nrow=length(richness), ncol=length(richness))
	1 - (site_similarity / (ra + t(ra) - site_similarity))
}

#' Compute a dataframe of environmental dissimilarity values
#'
#' @param x A data frame of environmental covariates.
#' @param sites Either a vector of site names or a column index (or column name) giving the location of the site names
#'              in x. If 0, row names will be used; if rownames are missing rows will be numbered
#' @param sitenames Boolean; should site names be returned with the data frame?
#' @return A data frame including both sites' names, environmental dissimilarity between the two sites, and midpoints
#'         between the two sites for each variable
#' @export
env_dissim <- function(x, sites = 0, sitenames = TRUE) {
	if(length(sites) == nrow(x)) {
		rownames(x) <- sites
	} else if(sites != 0) {
		rownames(x) <- x[,sites]
		x <- x[,-sites]
	}
	if(all(is.null(rownames(x))))
		rownames(x) <- 1:nrow(x)

	if(is.null(colnames(x)))
		colnames(x) <- paste0("var", seq_len(ncol(x)))

	midpoints <- apply(x, 2, function(v) {
		mat <- sapply(v, function(x) (x+v)/2)
		mat[lower.tri(mat)]
	})
	distance <- as.vector(dist(x))
	covars <- as.data.frame(cbind(distance, midpoints))
	colnames(covars) <- c('distance', colnames(x))
	if(sitenames)
	{
		nms <- t(do.call(cbind, sapply(1:(nrow(x) - 1), function(i) {
			sapply((i+1):nrow(x), function(j) {
				c(rownames(x)[i], rownames(x)[j])
			})
		})))
		covars$site1 <- nms[,1]
		covars$site2 <- nms[,2]
	}
	covars
}


#Calculate delta(SNP Index)

#' @title Calculate delta(SNP index)
#' @description This function is used to calculate the ∆(SNP-index) by subtracting the SNP-index value of the wild-type bulk from the SNP-index value of the mutant bulk.
#'
#' \deqn{mean_M_SNPindex - mean_WT_SNPindex.WT}
#'
#' @param SNPindex.windows data frame obtained after running the slidingWindow()function
#'
#' @return Data frame containing start, mid and stop positions of each window in the chromosome, as well as the corresponding mean SNP-index value for each bulk and ∆(SNP-index)value.
#'
#' @details For each row in the data frame returned by slidingWindow(), corresponding to a different window, ∆(SNP-index) is calculated by subtracting the SNP-index value of the reference bulk to the SNP-index value of the mutant bulk.
#' The values of ∆(SNP-index)ineach window are added to the data frame as a new column.
#'
#' @importFrom dplyr %>%
#' @export calc_deltaSNPindex
#' @examples
#' deltaSNPindex_windows <- calc_deltaSNPindex(SNPindex.windows=SNPindex_windows)

calc_deltaSNPindex <- function(SNPindex.windows) {

  #Calculate delta SNP-index and add it as new column
  deltaSNPindex.windows <- SNPindex.windows %>% dplyr::mutate("delta_SNPindex" = (mean_SNPindex.M - mean_SNPindex.WT))
  return(deltaSNPindex.windows)
}


#############################################
# MCMC Algorithm Shell
#############################################

# Define a single iteration of the MH within Gibbs sampler
blocked.mcmc.update <- function(U.data, cur){
        cur <- sample.th(U.data, cur)
        cur <- sample.a(U.data, cur)
        cur <- sample.b(U.data, cur)
        cur <- sample.s2(U.data, cur)
        return(cur)
}

# MCMC Chain Update
run.chain.2pl <- function(M.burnin, M.keep, M.thin, U.data, hyperpars,
                          th.init, a.init, b.init, s2.init,
                          MH.th, MH.a, MH.b, verbose = FALSE){
        # Define and initialize the list of things to keep track of in the current state of the chain
        cur <- list(th = th.init, a = a.init, b= b.init, s2 = s2.init,
                    hyperpars = hyperpars,
                    MH = list(th = MH.th, a = MH.a, b = MH.b),
                    ACC = list(th = 0, th.n = 0, a = 0, a.n = 0, b = 0, b.n = 0))

        # Define matrix to store MCMC results ...
        chain.keep <- matrix(NA, ncol = M.keep,
                             nrow = length(th.init) + length(a.init)
                             + length(b.init) + length(s2.init))
        rownames(chain.keep) <- c(paste('theta.abl', 1:length(th.init)),
                                  paste('a.disc', 1:length(a.init)),
                                  paste('b.diff', 1:length(b.init)),
                                  'sigma.theta')

        # Burnin phase : do not keep these results
        if(M.burnin > 0){
                for (ii in 1:M.burnin) {
                        cur <- blocked.mcmc.update(U.data, cur)
                }
        }

        # Converged phase: Keep these results after thinning
        for (m in 1:M.keep) {
                # Skip the thinned pieces of the chain
                if (M.thin > 1) {
                        for (ii in 1:(M.thin-1)) {
                                cur <- blocked.mcmc.update(U.data, cur)
                        }
                }
                # Generate a kept update and save its results
                cur <- blocked.mcmc.update(U.data, cur)
                chain.keep[,m] <- c(cur$th, cur$a, cur$b, cur$s2)

                if(m %% 100 == 0){
                        print(m)
                        # Adaptive tuning would go here
                }
        }

        if (verbose) {
                cat(paste("Average acceptance rates:",
                          "\n theta.abl:", round(cur$ACC$th / cur$ACC$th.n, 3),
                          "\n a.disc:   ", round(cur$ACC$a  / cur$ACC$a.n, 3),
                          "\n b.diff:   ", round(cur$ACC$b  / cur$ACC$b.n, 3),
                          "\n"))
        }
        return(chain.keep)
}