#########################################################################################
#########################################################################################
################### 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"))


#!/usr/bin/env Rscript
args <- commandArgs(trailingOnly = TRUE)

# Re-create the plot from the last exercise
csv_data <- read.csv(args[1])
print (args[1])

png('Scatterplot_R.png')
plot(x = csv_data$x,
     y = csv_data$y,
     xlab = "x",
     ylab = "y",
     main = "Regrex Data")
dev.off()

png(filename="Linearplot_R.png")
plot(x = csv_data$x,
     y = csv_data$y,
     xlab = "x",
     ylab = "y",
     col = "black",
     main = "Regrex Data")
abline(lm(csv_data$y ~ csv_data$x,
          data = csv_data), col = "black")
dev.off()


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(1:30, 10)
} else {
  x = NULL
}

tester = function(x, i, j)
{
  if (comm.rank() == 0)
    x_true = x[, j, drop=FALSE]
  dx = expand(x)
  x_test = collapse(dx[, j])
  comm.print(all.equal(x_true, x_test))
}

tester(x, j=-1)
tester(x, j=c(-1, -3))

tester(x, j=2)
tester(x, j=c(1, 3))

tester(x, j=c(F, F, F))
tester(x, j=c(T, F, T))

tester = function(x, i, j, value)
{
  if (comm.rank() == 0)
  {
    x_true = x
    x_true[, j] <- value
  }
  dx = expand(x)
  ### some care is needed here for reasons I don't entirely understand
  x_test = dx
  dx[, j] <- value
  x_test = collapse(dx)
  comm.print(all.equal(x_true, x_test))
}

tester(x, j=-1, value=1)
tester(x, j=1, value=1)
tester(x, j=c(1, 3), value=1)
tester(x, j=c(-1, -3), value=1)

### [<-

if (comm.rank() == 0){
  m = 10
  x = matrix(1:20, m)
  y = matrix(1:30, m)
  z = matrix(1:10, m)
  c = cbind(x, y, z)
} else {
  x = NULL
  y = NULL
  z = NULL
}

dx = expand(x)
dy = expand(y)
dz = expand(z)

dc = cbind(dx, dy, dz)
c_test = collapse(dc)

comm.print(all.equal(c, c_test))

finalize()


library(readr)
library(dplyr)
library(readr)
library(plotly)
#importing libraries

forkmeans <- read_csv("C:/Users/mudit/Google Drive/for project/4th year project/forkmeans.csv")
#reading dataset
forkmeans1 <-remove_missing(forkmeans)
#removing missing values
forkmeans1 <-subset(forkmeans1, select = -c(Time,Humidity))
#subsetting values of time and temperature
forkmeans1$Value <- if_else(forkmeans1$Temperature >27,1,0)
##creating a new column based on a condition

plot(forkmeans1)
#creating a simple plot

#Scaling each column in the data to zero mean and unit standard deviation (z-scores).
#This prevents one attribute with a large range to dominate the others
#for the distance calculation.
forkmeans1_scaled <- scale(forkmeans1)
plot(forkmeans1_scaled)

#Clustering method 1
#k-means Clustering
#Assumes Euclidean distances. We use k=2 clusters and run the algorithm 10 times
#with random initialized centroids. The best result is returned.
km <- kmeans(forkmeans1_scaled, centers=2, nstart=10)
km

#plotting for kmeans
plot(forkmeans1_scaled, col=km$cluster)
points(km$centers, pch=3, cex=2) # this adds the centroids
text(km$centers, labels=1:2, pos=2) # this adds the cluster ID

#printing about clusters from the results of k-means
centers <- km$centers[km$cluster, ]
print(forkmeans1_scaled[km$cluster])
km$cluster
km$cluster[10]
print(forkmeans1_scaled[km$cluster[10]])
forkmeans1_scaled[km$cluster==1]
forkmeans1_scaled[km$cluster==2]

#unscaling
forkmeans1_scaled <- unscale(forkmeans1_scaled,forkmeans1_scaled)

# Inspecting the centroids (cluster profiles)
km$centers

#Clustering method 2
#Density-based clustering with DBSCAN
library(dbscan)
#loading dbscan library

#Parameters: minPts is often chosen as dimensionality of the data +1.
#Decide on epsilon using the knee in the kNN distance plot

#running the dbscan function
db <- dbscan(forkmeans1_scaled, eps=2, minPts=2)

#plotting dbscan results
db
str(db)
plot(forkmeans1_scaled, col=db$cluster+1L)

#Alternative visualization from package dbscan
hullplot(forkmeans1_scaled, db)

#printing values from the results of dbscan
print(forkmeans1_scaled[db$cluster])
db$cluster[10]
print(forkmeans1_scaled[db$cluster[10]])
forkmeans1_scaled[db$cluster==1]
forkmeans1_scaled[db$cluster==2]


library(raster)
library(rgdal)
setwd("c:/todel/demo r/")

alt <- getData('alt', country = "VNM")
tinh <- getData('GADM', country = "VNM", level = 1)
anual_temp = getData('worldclim', var="bio",res=10)

plot(alt)
plot(tinh, add=T)

alt_tinh=extract(alt, tinh, fun = mean, na.rm = T, small = T, df = T)

province_alt=merge(alt_tinh,tinh,by.x="ID",by.y="OBJECTID",all.y=TRUE)
myvars = c("VNM_msk_alt", "VARNAME_1")
province_alt2 = province_alt[myvars]
write.csv(province_alt2,file="province_alt_csv.csv")


#!/usr/bin/env R --slave -f
dat <- read.table(pipe("zcat summarize.0.gz | perl -pe s/\\'/^/g"), col.names=c("name", "tagp", "freq", "v4", "subs", "v6", "otpw", "v8", "word", "v10", "wsub"))
attach(dat)
tagp1 <- tagp[tagp>1]
word1 <- word[tagp>1]
subs1 <- subs[tagp>1]
bw <- 1.0
kword <- ksmooth(tagp1, word1, "normal", bw)
ksubs <- ksmooth(tagp1, subs1, "normal", bw)
output <- data.frame(kword$x, kword$y, ksubs$y)
write.table(output, file="ksmooth.out", col.names=FALSE, row.names=FALSE)

## > length(word)
## [1] 49205
## > r <- tagp>2
## > length(word[r])
## [1] 832
## > length(word[r])/length(word)
## [1] 0.01690885
## > sum(freq[r])
## [1] 0.0501795
## > mean(word[r])
## [1] 0.3871478
## > mean(subs[r])
## [1] 0.4111982
## > sum(word[r]*freq[r])/sum(freq[r])
## [1] 0.4277153
## > sum(subs[r]*freq[r])/sum(freq[r])
## [1] 0.4272569


# datasets for one million(m개의 wildtype에서 n개의 mutant type fragment(n/m % tumor contents)가 섞인 dataset 제작)
dataset_adv2 <- function(n,m){
  a <- c(rep(1, times=n),rep(0, times=(m-n)))
  b <- a[sample(length(a))]
  return(b)
}

# data에서 n번 sampling 후 벡터로 제작 후 sum of them으로 1000번 안에서 probablity계산(m개의 windows)
resample_adv <- function(data,n,m) {
  counter <- 0
  for (i in 1:1000){
    vec=NULL
    for (j in 1:n) {
      c = sample(data,m,replace=F)
      vec <- c(vec, c)
    }
    if (sum(vec) > 1){
      counter <- counter + 1
    }
  }
  prob <- counter/1000
  return(prob)
}

# Let's do simulation!!!(n개의 mutation을 검출할때, tumor fraction 0.01%-10% 구간에서의 the probablity of detection(1000x100))
binomial_test_adv <- function(n){
  vec=NULL
  for (i in seq(1.5,1515,by=0.1)){
    a <- dataset_adv2(i,15150)
    b <- resample_adv(a,1000,n)
    print(b)
    vec = rbind(vec, b)
    if (b == 1){
      break
    }
  }
  return(b)
}


# See for context:
#   http://ww2.coastal.edu/kingw/statistics/R-tutorials/logistic.html

# Logistic Regression: Multiple Numerical Predictors

file = "http://ww2.coastal.edu/kingw/statistics/R-tutorials/text/gorilla.csv"
# huh, you can turn it around as well.. could be handy
read.csv(file) -> gorilla
str(gorilla)

# correlation matrix
cor(gorilla)

# or another way
with(gorilla, tapply(W, seen, mean))
with(gorilla, tapply(C, seen, mean))
with(gorilla, tapply(CW, seen, mean))

# ^ no significant relations to be found

glm.out = glm(seen ~ W * C * CW, family=binomial(logit), data=gorilla)
# check out regression coefficients with standard errors and a z-test
summary(glm.out)
  # None of the coefficients are significantly different from zero (but a few are close)
  # The deviance was reduced by 8.157 points on 7 degrees of freedom, for a p-value of
	1 - pchisq(65.438 - 57.281, df=7)
  # Overall, the model appears to have performed poorly, showing no significant reduction in deviance (no significant difference from the null model).

# The second print out shows the same overall reduction in deviance, from 65.438 to 57.281 on 7 degrees of freedom.
anova(glm.out, test="Chisq")
# In this print out, however, the reduction in deviance is shown for each term, added sequentially first to last.
# Of note is the 3-way interaction term, which produced a nearly significant reduction in deviance of 3.305 on 1 degree of freedom (p = 0.069).

# plot todo: intepretation
# 0.3 & 0.5 via antilog?
plot(glm.out$fitted)
abline(v=30.5,col="red")
abline(h=.3,col="green")
abline(h=.5,col="green")
text(15, 0.9, "seen = 0")
text(40, 0.9, "seen = 1")


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)

}


library(stringr)

terrain <- read.csv2("./input", header=FALSE, sep="")

# First Star ---------------------------------------------------------------
p1_slope <- c(x = 3, y = 1)

width <- str_length(terrain[1,1])
count_trees <- function(slope) {
  treecount = 0
  loc <- c(x = 1, y = 1)
  while (loc['y'] <= dim(terrain)[1]) {
    x <- loc['x']
    if (x == 0) x <- width
    y <- loc['y']
    row = terrain[y, 1]
    #print(loc)
    if (substr(row, x, x) == '#') {
      rowdebug <- paste0(substr(row, 0, x-1), 'X', substr(row, x+1, str_length(row)))
      #print(paste(rowdebug,"Tree at ", paste(loc, collapse = ',')))
      treecount <- treecount + 1
    } else {
      rowdebug <- paste0(substr(row, 0, x-1), 'O', substr(row, x+1, str_length(row)))
      #print(paste(rowdebug,"No tree at ", paste(loc, collapse = ',')))
    }

    loc['x'] <- (x + slope['x']) %% (width)
    loc['y'] <- y + slope['y']
  }
  return(treecount)
}

print(count_trees(p1_slope))

# Second Star -------------------------------------------------------------

allslopes = list(c(x = 1, y = 1),
                 c(x = 3, y = 1),
                 c(x = 5, y = 1),
                 c(x = 7, y = 1),
                 c(x = 1, y = 2))

treecounts <- sapply(allslopes, count_trees)
print(treecounts)
print(Reduce(`*`, treecounts))


url <- "https://raw.githubusercontent.com/NicoleRadziwill/Data-for-R-Examples/master/mnm-clean.csv"
mm.df <- read.csv(url,header=T)
count.colors <- table(mm.df$color)
barplot(count.colors, main="M&M Color Distribution", xlab="M&M Colors", ylab="Number of M&M in bag",
		      col=c("Blue","Brown","Green","Orange","Red","Yellow"))


 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


Args<-commandArgs()
in_file<-Args[6]
loading_file<-Args[7]
coord_file<-Args[8]
std_file<-Args[9]
do_trans<-Args[10]
data<-read.table(in_file, header=T, com='', sep="\t")
d<-data[,2:length(data)]
mat<-as.matrix(d) # convert to matrix
if (do_trans == 'T') {
	mat<-t(mat)
	colnames(mat)<-data[,1]
} else {
	rownames(mat)<-data[,1]
}
res<-prcomp(mat)
write.table(res$rotation[,1:3], file=loading_file, sep='\t', col.names=FALSE);
write.table(res$x[,1:3], file=coord_file, sep='\t', col.names=FALSE);
write.table(res$sdev, file=std_file, sep='\t', col.names=FALSE);


library(circlize)
x = rnorm(2300)
sectors = sample(letters[1:23], 2300, replace = TRUE)
circos.initialize(sectors, x=x)
circos.trackHist(sectors, x=x, col="#FF0000", bg.border="#FF0000", border="#FF0000", draw.density=TRUE)
circos.trackHist(sectors, x=x, col="#00FF00", bg.border="#00FF00", border="#00FF00")
circos.trackHist(sectors, x=x, col="#0000FF", bg.border="#0000FF", border="#0000FF", bin.size=0.5)
circos.trackHist(sectors, x=x, col="#C0C0C0", bg.border="#C0C0C0", border="#C0C0C0", bin.size=0.1)


library(base)
library(C50)
library(caret)
library(e1071)
library(modules)
library(rpart)
library(rpart.plot)
library(rstudioapi)
library(stats)
library(tidyverse)
library(utils)

base::setwd(base::dirname(rstudioapi::getActiveDocumentContext()$path))
start <- base::Sys.time()

base::set.seed(0xACDC)

train_test_prop <- 0.75

data <- modules::use('data')$get_data$get_data()
data$url <- NULL

data$status <- base::as.factor(data$status)

formula <- stats::as.formula('status ~ .')

index <-
  base::sample(base::nrow(data),
               base::round(train_test_prop * base::nrow(data)))

train <- data[index, ]
test <- data[-index, ]

train_label <- base::as.factor(train$status)
test_label <- base::as.factor(test$status)

tree_result <-
  rpart::rpart(formula, train, method = 'class')

plot_tree <- function(tree) {
  rpart.plot::rpart.plot(
    tree,
    type = 1,
    tweak = 1.1,
    box.palette = base::c('#00AFBB', '#FC4E07')
  )
}

eval_tree <- function(tree, set, label) {
  predicted <- stats::predict(tree, newdata = set, type = 'class')
  cm_train <- caret::confusionMatrix(predicted, label)
  base::print(cm_train$table)
  base::print(cm_train$overall['Accuracy'])
}

plot_tree(tree_result)

base::print('Train (rpart):')
eval_tree(tree_result, train, train_label)

base::print('Test (rpart):')
eval_tree(tree_result, test, test_label)

rpart::plotcp(tree_result, col = 'red', upper = 'splits')

tree_pruned <- rpart::prune(tree_result, cp = 0.014)

plot_tree(tree_pruned)

base::print('Train (rpart, pruned):')
eval_tree(tree_pruned, train, train_label)

base::print('Test (rpart, pruned):')
eval_tree(tree_pruned, test, test_label)

tree_result_C50 <- C50::C5.0(
  formula,
  data = train,
  control = C50::C5.0Control(CF = 0.25)
)

base::print('Train (C5.0):')
eval_tree(tree_result_C50, train, train_label)

base::print('Test (C5.0):')
eval_tree(tree_result_C50, test, test_label)

base::print(base::Sys.time() - start)
base::rm(start, index)

predict_using_rpart <- function(file = 'scripts/output.csv') {
  output <- utils::read.csv(
    file,
    header = TRUE,
    sep = ',',
    stringsAsFactors = FALSE,
    strip.white = TRUE
  )

  urls <- output$url
  output$url <- NULL

  results <-
    stats::predict(tree_pruned, newdata = output, type = 'class')

  base::print(base::data.frame(url = urls, status = results))
}

predict_using_C50 <- function(file = 'scripts/output.csv') {
  output <- utils::read.csv(
    file,
    header = TRUE,
    sep = ',',
    stringsAsFactors = FALSE,
    strip.white = TRUE
  )

  urls <- output$url
  output$url <- NULL

  results <-
    stats::predict(tree_result_C50, newdata = output, type = 'class')

  base::print(base::data.frame(url = urls, status = results))
}


context("Test functions")

test_that("mathGmv is as expected", {

  x <- mathGmv(midcap.ts[,1:10])

  expect_that(x$wts[1],is_equivalent_to(0.264138002824520323752))
  expect_that(x$wts[2],is_equivalent_to(-0.058874497255879558455))
  expect_that(sum(x$wts),equals(1))
  expect_that(x$mu,equals(0.016525251092767000161))
  expect_that(x$vol,equals(0.05184660161563151709))
})


suppressPackageStartupMessages(library(kazaam))
comm.set.seed(12345)

if (comm.rank() == 0){
  tol = 1e-2

  x = matrix(rnorm(30), 10)
  svd = svd(x)
  d = svd$d
  u = svd$u
  v = svd$v
} else {
  x = NULL
}

dx = expand(x)
k = 1

svd_test = rsvd(dx, k=k)
u_test = collapse(svd_test$u)
comm.print(all.equal(svd_test$d, svd$d[1:k], tol=tol))
comm.print(all.equal(abs(u_test), abs(svd$u[, 1:k, drop=FALSE]), tol=tol))
comm.print(all.equal(abs(svd_test$v), abs(svd$v[, 1:k, drop=FALSE]), tol=tol))

finalize()


print2 = function(string){
    cat(string)
    cat("\n")
}

trueGenotypes = as.matrix(read.table("baseData/trueGenotypes.txt"))

getGwasCor = function(mat, true) {
    cors = sapply(1:ncol(true), function(ii){
        cor(true[,ii], mat[,ii], use = "pair")
    })
    return(mean(cors, na.rm = T))
}

assessPeeling = function(filePrefix){

    newFile = as.matrix(read.table(paste0("outputs/", filePrefix)))
    print2(" ")
    print2(paste("Assessing peeling file:", filePrefix))
    newAcc = getGwasCor(newFile[,-1], trueGenotypes[,-1])
    print2(paste("Accuracy: ", round(newAcc, digits=3)))

}

assessPeeling("peeling.dosages")
assessPeeling("peeling.multi.seq.dosages")
assessPeeling("peeling.single.dosages")
assessPeeling("peeling.hybrid.dosages")
assessPeeling("peeling.hybrid.seq.dosages")


 ZHBGST Example Program Results

 Eigenvalues
    -6.6089 -2.0416  0.1603  1.7712


set.seed(2093)
pred <- runif(1000)
act <- round(pred)
pred[sample(1000, 300)] <- runif(300) # noises

## Test correctness ------------------------------------------------------------

## act_fct <- factor(act, levels = c("1", "0"))
## pred_fct <- factor(ifelse(pred >= 0.5, 1, 0), levels = c("1", "0"))
## caret::confusionMatrix(act_fct, pred_fct)
## kappa=0.692
## irr::kappa2(cbind(act_fct, pred_fct), weight = "unweighted")
## kappa=0.692
expect_equal(mtr_cohen_kappa(act, pred), target = 0.692, tol = 1e-4)

## Test error ------------------------------------------------------------------

## raise error if cutoff is out of range
expect_error(
    mtr_cohen_kappa(act, pred, cutoff = 1.1)
)

## raise error if actual is multi-class
expect_error(
    mtr_cohen_kappa(c(0, 1, 2), c(0.1, 0.2, 0.3))
)

## raise error if actual is different than 0 and 1
expect_error(
    mtr_cohen_kappa(c(0, -1), c(0.1, 0.2))
)


library(survival)
library(RNCEP)

bp <- c(43.4617827,-65.7567228)
seal <- c(43.4083358,-66.0250048)

site.ll <- tribble(~bandsite,  ~lat,        ~lon,
                  'BP',    43.4617827,  -65.7567228,
                  'SEAL',  43.4083358,  -66.0250048)

w.variable <- "tcdc.eatm"
w.level <- 'gaussian'
w.months.minmax <- c(8, 9)
w.years.minmax <- c(2016, 2017)
w.lat.southnorth <- c(43.39, 43.49)
w.lon.westeast <- c(-66.02, -65.74)

w.data <- NCEP.gather(w.variable, w.level, w.months.minmax, w.years.minmax, w.lat.southnorth, w.lon.westeast)

w.aggregate.data <- NCEP.aggregate(w.data)

NCEP.vis.area(w.aggregate.data)

depFlights$ts.dep

site.ll[site.ll$site == flightBySunset$bandsite,]$lat

flightByWeather <- flightBySunset %>% left_join(site.ll, by = 'bandsite')

get.interp.data <- function(w.variable, w.level, lats, lons, times) {
  NCEP.interp(w.variable, w.level, lats, lons, times)
}

flightBySunset.cc <- get.interp.data('tcdc.eatm', 'gaussian', flightBySunset$lat, flightBySunset$lon, flightBySunset$ts) # cloud cover

flightBySunset.vwind <- get.interp.data('vwnd.sig995', 'surface', flightBySunset$lat, flightBySunset$lon, flightBySunset$ts) # lat wind

flightBySunset.uwind <- get.interp.data('uwnd.sig995', 'surface', flightBySunset$lat, flightBySunset$lon, flightBySunset$ts) # lon wind

flightBySunset.wind.abs <- sqrt((flightBySunset.uwind^2) + (flightBySunset.vwind^2))

flightBySunset.wind.dir <- atan2((flightBySunset.uwind/flightBySunset.wind.abs), (flightBySunset.vwind/flightBySunset.wind.abs))*(180/pi) + 180

flightByWeather$vwind <- flightBySunset.vwind
flightByWeather$uwind <- flightBySunset.uwind
flightByWeather$wind.abs <- flightBySunset.wind.abs * (3.6) # Convert m/s to km/h
flightByWeather$wind.dir <- flightBySunset.wind.dir

flightByWeather$cc <- flightBySunset.cc

#### Cloud cover

flightByWeather %>%
  filter(isDep) %>%
  ggplot(aes(bandsite, (cc)))+
  geom_boxplot()+
  facet_grid(age~.)+
  ylab('Cloud Cover (%)')+
  xlab('Banding site')

flightByWeather %>%
  filter(isDep) %>%
  ggplot(aes((cc))) +
  geom_histogram()+
  facet_grid(age~bandsite)

glm7 <- flightByWeather %>% filter(isDep) %>% glm(formula = (cc) ~ age * bandsite, family = gaussian)

plot(glm7)

summary(glm7)

anova(glm7, test = 'F')

#### Wind Velocity

flightByWeather %>%
  filter(isDep) %>%
  ggplot(aes(bandsite, log(wind.abs)))+
  geom_boxplot()+
  facet_grid(age~.)+
#  ylab('Cloud Cover (%)')+
  xlab('Banding site')

flightByWeather %>%
  filter(isDep) %>%
  ggplot(aes(log(wind.abs))) +
  geom_histogram()+
  facet_grid(age~bandsite)

glm8 <- flightByWeather %>% filter(isDep) %>% glm(formula = log(wind.abs) ~ age * bandsite, family = gaussian)

plot(glm8)

summary(glm8)

anova(glm8, test = 'F')

#### Wind direction

flightByWeather %>%
  filter(isDep) %>%
  ggplot(aes(bandsite, (wind.dir)))+
  geom_boxplot()+
  facet_grid(age~.)+
#  ylab('Cloud Cover (%)')+
  xlab('Banding site')

flightByWeather %>%
  filter(isDep) %>%
  ggplot(aes((wind.dir))) +
  geom_histogram()+
  facet_grid(age~bandsite)

glm9.1 <- flightByWeather %>% filter(isDep) %>% glm(formula = (wind.dir) ~ age * bandsite, family = gaussian)
glm9.2 <- flightByWeather %>% filter(isDep) %>% glm(formula = (wind.dir) ~ age + bandsite, family = gaussian)
glm9.3 <- flightByWeather %>% filter(isDep) %>% glm(formula = (wind.dir) ~ 1, family = gaussian)

plot(glm9)

summary(glm9.1)
summary(glm9.2)
summary(glm9.3)

anova(glm9.1, glm9.3, test = 'F')

anova(glm9, update(glm9, .~ -age:bandsite), test = 'F')
anova(glm9, update(glm9, .~ -age:bandsite), test = 'F')


library(leaps)
library(neuralnet)
library(hydroGOF)
library(arules)

#dataset <- read.csv("~/Desktop/6th_semester/srcr/project/projecto_rna/discrExaustao.csv")
#set.seed(11) # set a seed so that sample always gives the same train set
#sample <- sample.int(n=nrow(dataset), size=floor(.75*nrow(dataset)),replace=F)
#train <- dataset[sample, ]
#test  <- dataset[-sample, ]

#sigmoid <- function(x) {1/(1+exp(-x))}
# formula variables should be changed after calling regsubsets(form, dataset, nvmax=8) after running conversion.r
#formula <- FatigueLevel ~ Performance.MAMean + Performance.AEDMean + Performance.DDCMean + Performance.DMSMean
formulaFL <- FatigueLevel ~ Performance.KDTMean + Performance.DMSMean#+ Performance.MAMean# + Performance.DDCMean# + Performance.AEDMean
#formulaT <- Performance.Task ~ Performance.KDTMean + Performance.DDCMean + Performance.MAMean + Performance.DMSMean + Performance.MVMean
fatigue1 <- neuralnet(formulaFL, train, hidden=c(7,4,3), lifesign = "FULL",algorithm="rprop+",linear.output = FALSE,threshold = 0.03)

# get a subset of test set (only de columns of the variables used in formula)
test.01 <- subset(test, select=c("Performance.KDTMean", "Performance.DMSMean"))#,"Performance.MAMean"))#, "Performance.DDCMean"))#, "Performance.MVMean"))
fatigue1.resultados <- compute(fatigue1, test.01)
resultados <- data.frame(atual=test$FatigueLevel, previsao=(fatigue1.resultados$net.result*3)+1)
resultados$previsao <- round(resultados$previsao, digits=0)
resultados$atual <- round(resultados$atual, digits=0)
rmse(c(test$FatigueLevel), c(resultados$previsao))


library(raster)
library(rgdal)

# This script is for calculating the RSDS for the TEM model in the IEM project
# modified code from Steph McAfee, by Michael Lindgren September 14, 2012

# SET THE WORKING DIRECTORY
setwd('/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/outputs')

# ADD THE FUNCTION calcNr.r
source('/workspace/UA/malindgren/projects/iem/PHASE2_DATA/code/FromSteph_and_Dave_Radiation/StephSept/calcn_startwithlat/calcNr.R')

# read in a raster layer that has the same extent and projection system as the desired output Rad files
tmp = raster("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/Elevation/akcanada_prism_aspect_1km_MASTER.tif")

# project that raster to WGS1984 lat/long
xy = projectExtent(tmp,crs="+proj=longlat +datum=WGS84")

# find the resolution of latitudes from the grid cell center of the first row to the grid cell center of the last row
# this finds lat from the cell# 1 in row 1 and cell# 1 in row 2227 of xy and divides the later by the number of rows
# between 1 and 2227, which is 2226, thus returning the cell resolution
yres = (yFromRow(xy,1)-yFromRow(xy,nrow(xy)))/(nrow(xy)-1)

lat.ll.m = as.matrix(coordinates(xy)[,2],nrow(xy),ncol(xy))

# Modified version of the lat Calc
lat = raster(extent(tmp), nrows=nrow(tmp), ncols=ncol(tmp), crs=projection(tmp))
lat = setValues(lat, lat.ll.m)

# mask the raster
lat = mask(lat,tmp)

# convert lat from degrees to radian
lat = lat*(pi/180)

# set the min and max values
# lat = setMinMax(lat)

# trim the lat raster
lat = trim(lat)

# MAKE A VECTOR OF MONTH INDICATORS
month = c('01','02','03','04','05','06','07','08','09','10','11','12')

# MAKE A VECTOR THAT DESCRIBES THE NUMBER OF DAYS IN EACH MONTH
ndm <- matrix(c(31,28,31,30,31,30,31,31,30,31,30,31))

# USE THAT MATRIX TO PULL TOGETHER A MATRIX LISTING THE FIRST AND LAST DAY OF EACH MONTH
d <- matrix(NA,12,2)
for (m in 1:12) {
d[m,2] <- sum(c(ndm[1:m]))   # Sum up number of days in months to find last day of month
} # close that loop

d[,1] <- (d[,2]-ndm)+1 # Subtract number of days in a month from the end date and add one to get Julian Day of the first day of month
rm(ndm,m) # Delete ndm b/c not needed any more; clean up looping variable
D = apply(d,1,mean)
rm(d)
# This version of the file calculates N for the mean of the days of the year in each month;
for (m in 1:12) {  # month loop
    j=D[m]
    N = calcNr(j)
    rm(j)
       # Write the output data to a geotiff
        writeRaster(N,filename=paste("rad_1km_AKCanada_",month[m],'.tif',sep=''),format = 'GTiff',options='COMPRESS=LZW',datatype='FLT4S',overwrite=T)
        rm(N)
} # close the month loop


"Cleans and prepocesses data csv data from the web to a local filepath a csv
Writes the training and test data to separate feather files.

Usage: src/preprocess_data.r --input=<input> --out_dir=<out_dir>

Options:
--input=<input>       Path (including filename) to raw data (csv file)
--out_dir=<out_dir>   Path to directory where the processed data should be written
" -> doc

library(tidyverse)
library(docopt)
library(tidymodels)
library(ggplot2)
library(GGally)
library(rlang)
library(magrittr)
library(dplyr)
set.seed(4)
library(group2)
# source("R/clean_data.r")
# source("R/diagnosis.r")

opt <- docopt(doc)

main <- function(input, out_dir){

    # Read Data and Add Colnames and Clean it
    raw_data <- read.csv(input)
    colnames(raw_data) <- c("age",
                            "sex",
                            "chest_pain",
                            "resting_blood_pressure",
                            "serum_cholesterol",
                            "fasting_blood_sugar",
                            "resting_ecg",
                            "max_heart_rate",
                            "exercise_induced_angina",
                            "oldpeak",
                            "slope",
                            "num_of_major_vessels",
                            "thalassemia",
                            "diagnosis")
    raw_data_clean <- clean_data(raw_data)
    raw_data_numerical <- subset(raw_data_clean, select = -c(sex, chest_pain,
                                                         fasting_blood_sugar, resting_ecg,
                                                         exercise_induced_angina, slope,
                                                         thalassemia))

    raw_data_num_diag <- diagnosis(raw_data_numerical)

    # split into training and test data sets
    raw_data_split <- initial_split(raw_data_num_diag, prop = 0.75, strata = diagnosis)
    data_train <- training(raw_data_split)
    data_test <- testing(raw_data_split)

    # scale test data using scale factor
    # x_train <- data_train %>% dplyr::select(-diagnosis)
    # x_test <- data_test %>% dplyr::select(-diagnosis)

    x_train <- subset(data_train, select = -diagnosis)
    x_test <- subset(data_test, select = -diagnosis)
    full_data <- subset(raw_data_num_diag, select = -diagnosis)

#     scaler <- preProcess(x_train, method = c("center", "scale"))

#     x_train_scaled <- predict(scaler, x_train)
#     x_test_scaled <- predict(scaler, x_test)

#     x_train_scaled <- scale(x_train)
#     x_test_scaled <- scale(x_test)

#     training_scaled <- x_train_scaled %>% mutate(class = data_train %>% dplyr::select(diagnosis) %>% pull())
#     test_scaled <- x_test_scaled %>% mutate(class = data_test %>% dplyr::select(diagnosis) %>% pull())

    x_train_scaled <- scale(x_train)
    x_test_scaled <- scale(x_test)
    full_data_scaled <- scale(full_data)

    training_scaled <- x_train_scaled
    test_scaled <- x_test_scaled
    full_data_scaled_diag <- full_data_scaled

    training_scaled <- cbind(x_train_scaled, data_train$diagnosis)
    test_scaled <- cbind(test_scaled, data_test$diagnosis)
    full_data_scaled_diag <- cbind(full_data_scaled_diag, raw_data_num_diag$diagnosis)

    training_scaled<-as.data.frame(training_scaled)
    test_scaled<-as.data.frame(test_scaled)
    full_data_scaled_diag<-as.data.frame(full_data_scaled_diag)

    colnames(training_scaled) <- c("age",
                    "resting_blood_pressure",
                    "serum_cholesterol",
                    "max_heart_rate",
                    "oldpeak",
                    "num_of_major_vessels",
                    "diagnosis")

    colnames(test_scaled) <- c("age",
                               "resting_blood_pressure",
                               "serum_cholesterol",
                               "max_heart_rate",
                               "oldpeak",
                               "num_of_major_vessels",
                               "diagnosis")

    colnames(full_data_scaled_diag) <- c("age",
                               "resting_blood_pressure",
                               "serum_cholesterol",
                               "max_heart_rate",
                               "oldpeak",
                               "num_of_major_vessels",
                               "diagnosis")

    full_data_scaled_diag$diagnosis <- as.factor(full_data_scaled_diag$diagnosis)
    training_scaled$diagnosis <- as.factor(training_scaled$diagnosis)
    test_scaled$diagnosis <- as.factor(test_scaled$diagnosis)

    # # write scale factor to a file
    # try({
    #     dir.create(out_dir)
    # })
    # saveRDS(scaler, file = paste0(out_dir, "/scale_factor.rds"))

    # write training and test data to feather files
    dir.create(out_dir, recursive = TRUE)
    write.csv(full_data_scaled_diag, paste0(out_dir, "/full.csv"), row.names=FALSE)
    write.csv(training_scaled, paste0(out_dir, "/training.csv"), row.names=FALSE)
    write.csv(test_scaled, paste0(out_dir, "/test.csv"), row.names=FALSE)
}
main(opt[["--input"]], opt[["--out_dir"]])


#!/usr/bin/Rscript
# Meta-analysis on test data

# to customize: input data
mydata <- read.csv("~/test/page_data/outlier.csv", sep=",", head=T)
betas <- mydata[, 3]
ses <- mydata[, 4]

weight <- 1 / (ses^2)
se <- sqrt(1 / sum(weight))
beta <- sum(betas * weight) / sum(weight)

z_score <- beta / se
cat("Z: ")
print(z_score)

p_value <- 2 * pnorm(-abs(z_score))
cat("P: ")
print(p_value)

if (F) {
mydata["p_value_secure"] <- NA
mydata$p_value_secure <- 2 * pnorm(-abs(mydata[, 1]))

mydata["p_value_plain"] <- NA
mydata$p_value_plain <- 2 * pnorm(-abs(mydata[, 2]))

write.table(mydata, file=paste(datadir, "/data/p_value.csv", sep=""), sep=",", quote=F, row.names=F, col.names=T)

}


setwd("/home/nan/Dropbox/CSE881/HW4")
ONP<-read.csv('OnlineNewsPopularity.csv',header=T)
ONP<-data.frame(ONP)
ONP<-as.matrix(ONP)
Pre<-ONP[,1:58]
Tar<-ONP[,59]
Tar=log(Tar)
Len<-length(Tar)
k<-c(1:35,38:58)
Pre1<-Pre[,k]+0
# mlr
TrainPre<-Pre1[1:2000,]
sTrainPre<-(Pre1-mean(Pre1))/sd(Pre1)
TrainTar<-Tar[1:2000]
TestPre<-Pre1[2001:length(Tar),]
TestTar<-Tar[2001:length(Tar)]
mlreg<-lm(TrainTar~TrainPre)
TestPre<-as.matrix(data.frame(TestPre,as.matrix(rep(1,dim(TestPre)[1]))))
w<-as.matrix(as.vector(coef(mlreg)))
Pred<-TestPre%*%w
cor(Pred,TestTar)


##Basic statistics=group
##Layer=vector
##Field=Field Layer

Summary_statistics <- data.frame(rbind(
                                  sum(Layer[[Field]]),
                                  length(Layer[[Field]]),
                                  length(unique(Layer[[Field]])),
                                  min(Layer[[Field]]),
                                  max(Layer[[Field]]),
                                  max(Layer[[Field]])-min(Layer[[Field]]),
                                  mean(Layer[[Field]]),
                                  median(Layer[[Field]]),
                                  sd(Layer[[Field]])),
                                  row.names=c("Sum:",
                                              "Count:",
                                              "Unique values:",
                                              "Minimum value:",
                                              "Maximum value:",
                                              "Range:",
                                              "Mean value:",
                                              "Median value:",
                                              "Standard deviation:")
                              )

colnames(Summary_statistics) <- c(Field)
>Summary_statistics


scenario <- 2

source(paste("data_regression_NIG_scenario_", scenario, ".r", sep = ""))
summary(lm(y_0 ~ -1 + X_0))

library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

lm.data <- list(
  N0 = N_0,
  X0 = X_0,
  y0 = y_0,
  P = ncol(X_0),
  mu_beta = rep(0, P),
  lambda_0 = solve(vb * diag(P)),
  alpha0 = as,
  beta0 = bs,
  a_0 = NA
)

invlambda0 <- solve(lm.data$lambda_0)

############
### Unnormalised posterior

compiled.model.unnorm.posterior <- stan_model("stan/simple_linear_regression_NIG_posterior_unnormalised.stan")

lm.data.forposterior <- list(
  N0 = N_0,
  X0 = X_0,
  y0 = y_0,
  P = ncol(X_0),
  mu_beta = rep(0, P),
  lambda_0 = solve(vb * diag(P)),
  alpha0 = as,
  beta0 = bs,
  eta = eta,
  nu = nu,
  X = X,
  N = N,
  y = y
)

unnorm.posterior.lm <- sampling(compiled.model.unnorm.posterior,
                                data = lm.data.forposterior,
                                iter = 5000,
                                control = list(adapt_delta = .95, max_treedepth = 15))
unnorm.posterior.lm
pairs(unnorm.posterior.lm, pars = c("a_0", "beta"))

unnorm.betas <- extract(unnorm.posterior.lm, 'beta')$beta

### The approximately normalised prior

J <- 20

constant_data <- read.csv(paste("../data/constant_data/RegressionNIG_logCA0_adaptive_J=", J, "_scenario_", scenario, ".csv",  sep = ""))

library(mgcv)
fit.gam <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = constant_data)

# plot(constant_data$a0, predict.gam(fit.gam), type = "l")
# points(lc_a0 ~ a0 , constant_data)

approx.normalised.model <- stan_model("stan/simple_linear_regression_NIG_posterior_normalised_approximate.stan")

Ks <- c(5e4, 1e5)

get_posterior_K <- function(K, verbose = FALSE){
  indicator <- as.numeric(verbose)
  cat("Doing k=", K, "\n")
  pred_a0s <- seq(0, max(constant_data$a0), length.out = K)
  a0_grid <- data.frame(a0 = pred_a0s,
                        lc_pred = predict(fit.gam, newdata = data.frame(a0 = pred_a0s)))
  lm.data.forposterior$pred_grid_x <- a0_grid$a0
  lm.data.forposterior$pred_grid_y <- a0_grid$lc_pred
  approx.norm.posterior.lm <- sampling(approx.normalised.model,
                                          data = lm.data.forposterior,
                                       iter = 5000,
                                       control = list(adapt_delta = .99, max_treedepth = 15),
                                       refresh = indicator * 500)
  return(approx.norm.posterior.lm)
}

system.time(
  all.approximates <- lapply(Ks, get_posterior_K, verbose = TRUE)
)

approximate.betas <- lapply(all.approximates, function(x) extract(x, 'beta')$beta)

## Now the normalised version

normalised.model <- stan_model("stan/simple_linear_regression_NIG_posterior_normalised.stan")

norm.posterior.lm <- sampling(normalised.model, data = lm.data.forposterior,
                              iter = 5000,
                              control = list(adapt_delta = .95, max_treedepth = 15))
norm.posterior.lm
pairs(norm.posterior.lm, pars = c("a_0", "beta"))

norm.betas <- extract(norm.posterior.lm, 'beta')$beta

summy <- function(x, alpha = .95){
  x <- na.omit(x)
  data.frame(
    lwr = quantile(x, probs = (1-alpha)/2),
    mean = mean(x),
    upr = quantile(x, probs = (1 + alpha)/2)
  )
}
#
is_contained <- function(x, l, u){
  as.numeric(all(x >= l,  x<= u))
}
is_contained <- Vectorize(is_contained)
#
covered <- function(dt, truepar){
  ans <- sapply(1:nrow(dt), function(i) is_contained(truepar[i], dt$lwr[i], dt$upr[i]))
  dt <- data.frame(dt, true = truepar, in.ci = ans, width = dt$upr - dt$lwr, sq_error = (dt$mean - truepar)^2)
  return(dt)
}
#####

results.unnorm <- covered(do.call(rbind, apply(unnorm.betas, 2, summy)), truepar = true.betas)
results.approx <- covered(do.call(rbind,apply(approximate.betas[[length(Ks)]], 2, summy) ), truepar = true.betas)
result.norm <- covered(do.call(rbind, apply(norm.betas, 2, summy) ), truepar = true.betas)

summary(results.unnorm)
summary(results.approx)
summary(result.norm)

#####

##### Analysis of p(a_0 | data)
a0.unnorm <- extract(unnorm.posterior.lm, 'a_0')$a_0

a0.approx.list <- lapply(Ks, function(k){
  i <- match(k, Ks)
  a0 <- extract(all.approximates[[i]], 'a_0')$a_0
  return(data.frame(a0 = a0, normalisation = paste("K=", k, sep = "")))
} )

a0.norm <- extract(norm.posterior.lm, 'a_0')$a_0

a0.dt <-
  rbind(
    data.frame(a0 = c(a0.unnorm, a0.norm),
               normalisation = c( rep("none", length(a0.unnorm)),
                                  rep("exact", length(a0.norm)) )
    ),
    do.call(rbind, a0.approx.list)
  )

library(ggplot2)

a0_dist <- ggplot(a0.dt, aes(x = a0, fill = normalisation, colour = normalisation)) +
  geom_density(alpha = .4) +
  stat_function(fun = function(x) dbeta(x, eta, nu),
                geom = "line", colour = "black", linetype = "longdash") +
  ggtitle("Linear regression") +
  facet_grid(normalisation~., scales = "free") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  scale_x_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw(base_size = 20)

a0_dist

ggsave(filename = paste("../figures/a0_posterior_RegressionNIG_scenario_", scenario, ".pdf", sep = ""), plot = a0_dist, dpi = 300)

a0_dist_norm <- ggplot(subset(a0.dt, normalisation != "none"),
                       aes(x = normalisation, y = a0,
                           fill = normalisation, colour = normalisation)) +
  geom_boxplot(alpha = .4) +
  ggtitle("Linear regression") +
  scale_y_continuous(expression(a[0]), expand = c(0, 0)) +
  theme_bw(base_size = 20)

a0_dist_norm

ggsave(paste("../figures/a0_posterior_RegressionNIG_normalisation_comparison_scenario_", scenario, ".pdf", sep = ""), a0_dist_norm)

###
unnorm.pars <- as.data.frame(
  cbind(extract(unnorm.posterior.lm, 'beta')$beta,
        extract(unnorm.posterior.lm, 'sigma_sq')$sigma_sq)
)
names(unnorm.pars) <- c(paste("beta[", 1:4, "]", sep = ""), "sigma^2")

##

app.norm.pars.list <- lapply(all.approximates, function(x) {
  pars <- as.data.frame(
    cbind(extract(x, 'beta')$beta,
          extract(x, 'sigma_sq')$sigma_sq)
  )
  names(pars) <- c(paste("beta[", 1:4, "]", sep = ""), "sigma^2")
  return(pars)
})

library(reshape2)
app.norm.pars.df.list <- lapply(seq_along(app.norm.pars.list), function(i) {
  y <- app.norm.pars.list[[i]]
  dt <- melt(y, variable.name = "parameter", value.name = "sample")
  dt$normalisation <- paste("K=", Ks[i] ,sep = "")
  return(dt)
} )

##
norm.pars <- as.data.frame(
  cbind(extract(norm.posterior.lm, 'beta')$beta,
        extract(norm.posterior.lm, 'sigma_sq')$sigma_sq)
)
names(norm.pars) <- c(paste("beta[", 1:4, "]", sep = ""), "sigma^2")

unnorm.dt <- melt(unnorm.pars, variable.name = "parameter", value.name = "sample")
unnorm.dt$normalisation <- "none"
norm.dt <- melt(norm.pars, variable.name = "parameter", value.name = "sample")
norm.dt$normalisation <- "exact"

posterior.dt <- rbind(unnorm.dt, norm.dt, do.call(rbind, app.norm.pars.df.list))
posterior.dt$normalisation <- factor(posterior.dt$normalisation,
                                     levels = c("none", paste("K=", Ks, sep = ""), "exact") )

###

true.pars <- data.frame(parameter = names(norm.pars), value = c(true.betas, sy^2))

parameter_posteriors <- ggplot(data = posterior.dt, aes(x = sample, colour = normalisation, fill = normalisation)) +
  geom_density(alpha = .4) +
  scale_x_continuous("") +
  scale_y_continuous("Density", expand = c(0, 0)) +
  facet_wrap(.~parameter,  scales = "free", labeller = label_parsed) +
  geom_vline(data = true.pars, aes(xintercept = value), linetype = "dashed") +
  theme_bw(base_size = 16)

parameter_posteriors

ggsave(paste("../figures/parameter_posterior_Regression_scenario_", scenario, ".pdf", sep = ""), parameter_posteriors)


#----------------------------------------------------------------------------#
#' @title mean and sd
#' @description report a mean(sd) string
#' @param x a vector
#' @param digit number of digit
#' @param ... ...
#' @import stats
#' @export
mean_sd = function(x,digit = 2,...) {
  n = paste("%.",digit,"f",sep = "")
  mean1 = mean(x,na.rm =T)
  mean1 = sprintf(n, mean1)
  sd1 = sd(x, na.rm =T)
  sd1 = sprintf(n,sd1)
  a = paste(mean1,"(", sd1,")", sep = "")
  return(a)
}


# Exercise 7: DPLYR practice with NBA data

# Read in the NBA player data into a variable called `team.data` using `read.csv`

# The data.frame team.data should now be accessible to you.
# View it, and get some basic information about the number of rows/columns.
# Note the "X" preceding some of the column titles as well as the "*"
# following the names of teams that made it to the playoffs that year.

# Add a column that gives the turnovers to steals ratio (TOV / STL) for each team

# Sort the teams from lowest turnover/steal ratio to highest
# Which team has the lowest ratio?

# Using the pipe operator, create a new column of assists per game (AST / G) AND
# sort the data.frame by this new column in DESCENDING order.

# Create a data.frame called `good.offense` of teams that scored more than 8700 points (PTS)

# Create a data.frame called `good.defense` of teams that had more than 470 blocks (BLK)

# Create a data.frame called `defense.stats` that only shows defensive rebounds (DRB), steals (STL),
# and blocks (BLK) along with the team name.

# Create a data.frame called `offense.stats` that only shows offensive rebounds (ORB),
# field-goal % (FG.), and assists (AST) along with the team name.

### Bonus ###
# Create a function called `BetterShooters` that takes in two teams and returns
# a data.frame of the team with the better field-goal percentage. The returned
# data.frame should include the team name, field-goal percentage, and points.


#' Cooperation: A Package of Co-Operations
#'
#' @description
#' Fast implementations of the co-operations: covariance,
#' correlation, and cosine similarity.  The implementations are
#' fast and memory-efficient and their use is resolved
#' automatically based on the input data, handled by R's S3
#' methods.  Full descriptions of the algorithms and benchmarks
#' are available in the package vignettes.
#'
#' Covariance and correlation should largely need no introduction.
#' Cosine similarity is commonly needed in, for example, natural
#' language processing, where the cosine similarity coefficients
#' of all columns of a term-document or document-term matrix is
#' needed.
#'
#' @section The \code{inplace} argument:
#' When computing covariance and correlation with dense matrices,
#' we must operate on the centered and/or scaled input data.  When
#' \code{inplace=FALSE}, a copy of the matrix is made.  This
#' allows for very wall-clock efficient processing at the cost of
#' m*n additional double precision numbers allocated.  On the
#' other hand, if \code{inplace=TRUE}, then the wall-clock
#' performance will drop considerably, but at the memory expense
#' of only m+n additional doubles.  For perspective, given a
#' 30,000x30,000 matrix, a copy of the data requires an
#' additional 6.7 GiB of data, while the inplace method requires
#' only 469 KiB, a 15,000-fold difference.
#'
#' Note that cosine is always computed in place.
#'
#' @section The \code{t} functions:
#' The package also includes "t" functions, like \code{tcosine()}. These
#' behave analogously to \code{tcrossprod()} as \code{crossprod()} in base R.
#' So of \code{cosine()} operates on the columns of the input matrix, then
#' \code{tcosine()} operates on the rows.  Another way to think of it is,
#' \code{tcosine(x) = cosine(t(x))}.
#'
#' @section Implementation Details:
#' Multiple storage schemes for the input data are accepted.
#' For dense matrices, an ordinary R matrix input is accepted.
#' For sparse matrices, a matrix in COO format, namely
#' \code{simple_triplet_matrix} from the slam package, is accepted.
#'
#' The implementation for dense matrix inputs is dominated
#' by a symmetric rank-k update via the BLAS subroutine \code{dsyrk};
#' see the package vignette for a discussion of the algorithm
#' implementation and complexity.
#'
#' The implementation for two dense vector inputs is dominated by the
#' product \code{t(x) \%*\% y} performed by the BLAS subroutine
#' \code{dgemm} and the normalizing products \code{t(y) \%*\% y},
#' each computed via the BLAS function \code{dsyrk}.
#'
#' @docType package
#' @name coop-package
#' @author Drew Schmidt
#' @keywords package
NULL


  histogram_with_kernel = function(x, s0, s1, bwh, bwd, title, ...) {
    breaks = seq(s0, s1, bwh)
    out = hist(x, breaks=breaks, main=title, ...)
    k = density(x, bw=bwd)
    k$y = k$y * (k$n) * bwh
    lines(k, lwd=2)
    return(out)
  }


x = seq(0,4,0.05);
a = 2;
lambda = 3
k = 2
aprime = 0;
y1 = a*(1 - exp(-(x/lambda)^k))*(1-aprime)-a
y2 = -y1;

df = data.frame(xv = x, yv1=y1, yv2 = y2)

ggplot(df, aes(x)) +
  geom_line(aes(y = yv1, colour = "yv1")) +
  geom_line(aes(y = yv2, colour = "yv2"))


# 4. faza: Analiza podatkov

require(ggplot2)
require(dplyr)

#NAPOVED RASTI BRUTO MINIMALNE PLAČE V SLOVENIJI
napoved_slo <- min_place %>%
  filter(Drzava=="Slovenia")
odstopanje <- lm(data=napoved_slo, formula=Placa ~ as.numeric(Leto))
g <- data.frame(Leto=seq(2016, 2024, 1))
napoved <- mutate(g, Placa=predict(odstopanje, g))

graf_odstopanje <- ggplot(napoved_slo, aes(x=Leto, y=Placa)) +
  geom_point() +
  geom_smooth(method=lm, fullrange = TRUE, color="red") +
  geom_point(data=napoved, aes(x=Leto, y=Placa), color="dark green", size=2) +
  ggtitle("Napoved nadaljne rasti minimalne bruto plače v Sloveniji") +
  ylab("Plača")


#' Iterator that returns selected elements from an iterable.
#'
#' Constructs an iterator that returns elements from an iterable following the
#' given sequence with starting value \code{start} and ending value \code{end}.
#' The sequence's step size is given by \code{step}.
#'
#' The iterable given in \code{object} is traversed beginning with element
#' having index specified in \code{start}. If \code{start} is greater than 1,
#' then elements from the \code{object} are skipped until \code{start} is
#' reached. By default, elements are returned consecutively. However, if the
#' \code{step} size is greater than 1, elements in \code{object} are skipped.
#'
#' If \code{stop} is \code{NULL} (default), the iteration continues until the
#' iterator is exhausted unless \code{end} is specified. In this case,
#' \code{end} specifies the sequence position to stop iteration.
#'
#' @importFrom iterators iter nextElem
#' @export
#' @param object iterable object through which this function iterates
#' @param start the index of the first element to return from \code{object}
#' @param end the index of the last element to return from \code{object}
#' @param step the step size of the sequence
#' @return iterator that returns \code{object} in sequence
#'
#' @examples
#' it <- islice(1:5, start=2)
#' iterators::nextElem(it) # 2
#' iterators::nextElem(it) # 3
#' iterators::nextElem(it) # 4
#' iterators::nextElem(it) # 5
#'
#' it2 <- islice(1:10, start=2, end=5)
#' unlist(as.list(it2)) == 2:5
#'
#' it3 <- islice(1:10, start=2, end=9, step=2)
#' unlist(as.list(it3)) == c(2, 4, 6, 8)
islice <- function(object, start=1, end=NULL, step=1) {
  start <- as.integer(start)
  step <- as.integer(step)
  if (length(start) != 1 || start < 1) {
    stop("'start' must be positive integer of length 1")
  }
  if (length(step) != 1 || step < 1) {
    stop("'step' must be a positive integer of length 1")
  }
  if (!is.null(end)) {
    end <- as.integer(end)
    if (length(end) != 1) {
      stop("'end' must be a numeric value of length 1")
    }
  }

  iter_ienum <- ienumerate(object)
  iter_icount <- icount(start=start, step=step)

  nextElem <- function() {
    i <- iterators::nextElem(iter_icount)
    if (!is.null(end) && i > end) {
      stop("StopIteration", call.=FALSE)
    }

    repeat {
      next_ienum <- iterators::nextElem(iter_ienum)
      if (i == next_ienum$index) {
        return(next_ienum$value)
      }
    }
  }

  it <- list(nextElem=nextElem)
  class(it) <- c("abstractiter", "iter")
  it
}


# FizzBuzz Tree
This application conducts "FizzBuzz" on a tree while traversing through it by changing the node values on the tree inplace.

## Authors
Tanner Seramur & Caity Heath

## Challenge
Write a function called FizzBuzzTree which takes a tree as an argument. Without utilizing any of the built in methods available to JavaScript, determine whether or not the value of each node is divisible by 3, 5 or both and change the alue of each of the nodes
* 3 --> "fizz"
* 5 --> "buzz"
* both --> "fizzbuzz"

## Approach & Efficiency

We have decided to break the functionality of this application up. Our solution contains two functions. One takes a node as a parameter and checks assigns its value to the corresponding fizzbuzz value based off the fizzbuzz ruleset. The second function traverses the tree and calls the check function on each node.

The run-time efficiency for our approach is O(1). We never don't use arrays and so we do not need any loops.

## Solution

Problem Domain, Visual and Psuedo Code
![](./assets/image1.jpeg)

Big O and Solution Code including Node and BinaryTree constructors
![](./assets/image2.jpeg)


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), ","), function(st) {
  numzero <- function(i = 1, c = 4, z = 0) {
    if (c == 0) {
      if (z == 0) {
        1
      } else {
        0
      }
    } else if ((length(s) - i + 1 < c || z + c * s[i] > 0 || z + c * tail(s, n=1) < 0)) {
      0
    } else {
      numzero(i + 1, c - 1, z + s[i]) + numzero(i + 1, c, z)
    }
  }
  s <- sapply(st, as.integer)
  s <- s[order(s)]
  numzero()
}), sep="\n")


library(dplyr)
library(ggplot2)
library(plotly)
library(data.table)
library(ggrepel)

bat.data <- read.csv("batting.csv")

head(bat.data)
# str(bat.data)

#Batting Average
bat.data$BA <- bat.data$H / bat.data$AB

#on base percentage
bat.data$OBP <- (bat.data$H + bat.data$BB + bat.data$HBP) / (bat.data$AB + bat.data$BB + bat.data$HBP + bat.data$SF)

#singles
bat.data$X1B <- bat.data$H - (bat.data$X2B + bat.data$X3B + bat.data$HR)

#slugging percentage
bat.data$SLG <- (bat.data$X1B + (2 * bat.data$X2B) + (3 * bat.data$X3B) + (4 * bat.data$HR) ) / bat.data$AB

sal <- read.csv("Salaries.csv")

# summary(sal)

#salaries data start from 1985
bat.data <- subset(bat.data, bat.data$year >= 1985)

#merging the datasets
bat_sal.data <- merge(bat.data, sal, by = intersect(names(bat.data), names(sal)))

#players to replace
lost_players <- c('giambja01','damonjo01','saenzol01')

#lost players data
lp_data <- subset(bat_sal.data, bat_sal.data$playerID %in% lost_players)

#filtering by year
lp_data_2001 <- subset(lp_data, lp_data$yearID == 2001)

#relevant attributes
lp_data_2001 <- select(lp_data_2001, playerID, H, X2B, X3B, HR, OBP, SLG, BA, AB, salary)

#constraints for replacements
constr.data <- data.table(salary = 15000000)
constr.data$AB <- sum(lp_data_2001$AB)
constr.data$OBP <- mean(lp_data_2001$OBP)

# constr.data

#filtering the main dataset by year
bat_sal_2001.data <- subset(bat_sal.data, yearID == 2001)

#sorting by asc salary and then desc AB, OBP
bat_sal_2001.data <- arrange(bat_sal_2001.data, salary, desc(AB), desc(OBP))

#required players
reqd_players <- subset(bat_sal_2001.data, bat_sal_2001.data$AB >= median(lp_data_2001$AB) & bat_sal_2001.data$OBP >= median(lp_data_2001$OBP))

reqd_players <- select(reqd_players, playerID, H, X2B, X3B, HR, OBP, SLG, BA, AB, salary)

reqd_players$salarySlabs = ifelse( reqd_players$salary <= 5000000, 1, ifelse( reqd_players$salary <= 10000000, 2, 3))

reqd_players <- subset(reqd_players, salarySlabs != 3 )
#plotting the filtered players. sizes of point relative to their salary slabs
pl <- plot_ly(type = 'scatter', mode = 'markers') %>%
  add_trace( data = lp_data_2001,
             x = ~AB,
             y = ~OBP,
             text = ~playerID,
             hoverinfo = 'text',
             marker = list(color='red', symbol = 18, size = 15),
             showlegend = F
  )

pl <- add_trace(pl,data = reqd_players,
          x = ~AB,
          y = ~OBP,
          text = ~playerID,
          hoverinfo = 'text',
          marker = list(color='blue', size = ~I(8*salarySlabs)),
          showlegend = F
)