library(snipEM)
library(mvtnorm)

likco.fixed=function(y,xi,sigma,pi,PI,k,kmax,n,Ti) {

qu=array(NA,c(n,Ti,kmax))

for(j in 1:k[1])
{qu[,1,j]=dmvnorm(y[,1,],xi[k[1],j,],diag(sigma[k[1],j,]^2),log=TRUE)+log(pi[k[1],j])}

for(t in 2:Ti) {
for(j in 1:k[t]) {
if(k[t-1]>1) {
qu[,t,j]=(qu[,t-1,1]+log(PI[k[t-1],k[t],1,j]))
for(d in 2:k[t-1]) {
    cb=cbind(qu[,t,j],(qu[,t-1,d]+log(PI[k[t-1],k[t],d,j])))
    cb[ cb < -700]=-700
qu[,t,j]=apply(cb,1,sumlog)}
qu[,t,j]=qu[,t,j]+dmvnorm(y[,t,],xi[k[t],j,],diag(sigma[k[t],j,]^2),log=TRUE)}

if(k[t-1]==1) {
qu[,t,j]=dmvnorm(y[,t,],xi[k[t],j,],diag(sigma[k[t],j,]^2),log=TRUE)+qu[,t-1,1]+log(PI[k[t-1],k[t],1,j])
}

}}

    if(k[Ti]>1) {
        cb=qu[,Ti,1:k[Ti]]
        cb[ cb < -700]=-700
liks=apply(cb,1,sumlog)}
if(k[Ti]==1) {liks=qu[,Ti,1]}
res=sum(liks)

qub=qu
qub[,Ti,]=0
for(t in (Ti-1):1) {
for(c in 1:k[t]) {
qub[,t,c]=dmvnorm(y[,t+1,],xi[k[t+1],1,],diag(sigma[k[t+1],1,]^2),log=TRUE)+qub[,t+1,1]+log(PI[k[t],k[t+1],c,1])
if(k[t+1]>1) {
for(j in 2:k[t+1]) {
    jnk=dmvnorm(y[,t+1,],xi[k[t+1],j,],diag(sigma[k[t+1],j,]^2),log=TRUE)+qub[,t+1,j]+log(PI[k[t],k[t+1],c,j])
    cb=cbind(qub[,t,c],jnk)
    cb[ cb < -700]=-700
qub[,t,c]=apply(cb,1,sumlog)
}}}}

return(list(lik=res,liks=liks,qub=qub,qu=qu))}

rlm.fixed=function(y,k,tol=1e-4,maxit=Inf,inits=NULL,verbose=FALSE,debug=FALSE,exceed=NULL) {

n=nrow(y)
Ti=ncol(y)
kmax=max(k)
r=dim(y)[3]

if(all(k==1)) {

xi=apply(y,3,mean)
sigma=apply(y,3,sd)
lik=sum(dmvnorm(matrix(y,ncol=r),xi,diag(sigma^2),log=TRUE))
aic=-2*lik+2*2*r
bic=-2*lik+log(n)*2*r
return(list(V=array(1,c(n,Ti,1)),pi=1,PI=1,xi=xi,sigma=sigma,lik=lik,aic=aic,bic=bic))

}

xi=array(NA,c(kmax,kmax,r))
sigma=xi

pi=array(NA,c(kmax,kmax))
PI=array(NA,c(kmax,kmax,kmax,kmax))
## inits ##

if(!is.null(inits)) {
xi=inits$xi
sigma=inits$sigma
PI=inits$PI
pi=inits$pi
}

if(is.null(inits)) {
for(j in 1:kmax) {
for(u in 1:r) {
km=kmeans(as.vector(y[,,u]),j)
xi[j,1:j,u]=km$centers
sigma[j,1:j,u]=sqrt(km$withinss/km$size)}
if(j>1) {
for(l in 1:r) {
o=order(xi[j,1:j,l])
xi[j,1:j,l]=xi[j,1:j,l][o]
sigma[j,1:j,l]=sigma[j,1:j,l][o]}
}}}

if(is.null(inits$PI)) {

pi[1,1]=PI[,1,,1]=1
for(j in 2:kmax) {
pi[j,1:j]=1/j}
for(h in 2:kmax) {
for(j in 1:kmax) {
if(j>1) {
PI[j,h,1:j,1:h]=1
if(h>1 & j>1) {
diag(PI[j,h,1:j,1:h])=8+j
PI[j,h,1:j,1:h]=PI[j,h,1:j,1:h]/apply(PI[j,h,1:j,1:h],1,sum)
}}
if(j==1) {
PI[j,h,1,1:h]=1
PI[j,h,1,1]=8+j
PI[j,h,1:j,1:h]=PI[j,h,1:j,1:h]/sum(PI[j,h,1:j,1:h])
}}}
}
## E-step ##

lst=likco.fixed(y,xi,sigma,pi,PI,k,kmax,n,Ti)

qu=lst$qu
lik=lst$lik
liks=lst$liks
qub=lst$qub
V=qu+qub
for(j in 1:kmax) {
V[,,j]=sweep(V[,,j],1,liks)
}
V=exp(V)

Z=array(0,c(kmax,kmax,kmax,kmax))
for(j in 1:kmax) {
for(h in 1:kmax) {
trans=k[-Ti]==j & k[-1]==h
if(any(trans)) {
wtrans=which(trans)
for(c in 1:j) {
for(d in 1:h) {
sw=matrix(y[,wtrans+1,],ncol=r)
ap=matrix(dmvnorm(sw,xi[h,d,],diag(sigma[h,d,]^2),log=TRUE),ncol=length(wtrans),byrow=FALSE)
Z[j,h,c,d]=sumlog(log(PI[j,h,c,d])+sweep(qu[,wtrans,c]+qub[,wtrans+1,d]+ap,1,liks))}}
}}}
PI[PI<1e-32]=1e-32
lkold=lik*2
iters=1
if(is.null(exceed)) {exceed=Inf}
while(lik-lkold>tol & iters<maxit & lik<exceed) {

#if(verbose) {print("## update initial probabilities")}

if(k[1]>1) {
pi[k[1],1:k[1]]=apply(V[,1,1:k[1]],2,sum)
pi[k[1],]=pi[k[1],]/sum(pi[k[1],1:k[1]])
}
if(debug) {
lkpartial=likco.fixed(y,xi,sigma,pi,PI,k,kmax,n,Ti)$lik
if(lik-lkpartial>0) {print("problems with pi!!!")}}

#if(verbose) {print("## update hidden transitions")}

for(j in 1:kmax) {
for(h in 1:kmax) {
trans=k[-Ti]==j & k[-1]==h
if(any(trans)) {
if(j>1 & h>1) {
PI[j,h,1:j,1:h]=exp(sweep(Z[j,h,1:j,1:h],1,apply(Z[j,h,1:j,1:h],1,sumlog)))}
if(j==1) {
PI[j,h,1,1:h]=exp(Z[j,h,1,1:h]-sumlog(Z[j,h,1,1:h]))}
}}}
PI[PI<1e-32]=1e-32
if(debug) {
lkpartold=lkpartial
lkpartial=likco.fixed(y,xi,sigma,pi,PI,k,kmax,n,Ti)$lik
if(lkpartold-lkpartial>0) {print(paste("problems with PI at iteration",iters,"!!!"))}}

#if(verbose) {print("## update xi & sigma")}

for(ks in unique(k)) {
for(l in 1:r) {
for(d in 1:ks) {
xi[ks,d,l]=sum(V[,which(k==ks),d]*y[,which(k==ks),l])/sum(V[,which(k==ks),d])
sigma[ks,d,l]=sqrt(sum(V[,which(k==ks),d]*(y[,which(k==ks),l]-xi[ks,d,l])^2)/(sum(V[,which(k==ks),d])))
}}
if(ks>1) {
o=order(xi[ks,1:ks,1])
xi[ks,1:ks,]=xi[ks,1:ks,][o,]
sigma[ks,1:ks,]=sigma[ks,1:ks,][o,]}
}

if(debug) {
lkpartold=lkpartial
lkpartial=likco.fixed(y,xi,sigma,pi,PI,k,kmax,n,Ti)$lik
if(lkpartold-lkpartial>0) {print(paste("problems with xi or sigma at iteration",iters,"!!!"))}}

if(verbose) {print("## E-step")}
lst=likco.fixed(y,xi,sigma,pi,PI,k,kmax,n,Ti)

lkold=lik

qu=lst$qu
lik=lst$lik
liks=lst$liks
qub=lst$qub
V=qu+qub
for(j in 1:kmax) {
V[,,j]=sweep(V[,,j],1,liks)
}
V=exp(V)

Z=array(0,c(kmax,kmax,kmax,kmax))
for(j in 1:kmax) {
for(h in 1:kmax) {
trans=k[-Ti]==j & k[-1]==h
if(any(trans)) {
wtrans=which(trans)
for(c in 1:j) {
for(d in 1:h) {
sw=matrix(y[,wtrans+1,],ncol=r)
ap=matrix(dmvnorm(sw,xi[h,d,],diag(sigma[h,d,]^2),log=TRUE),ncol=length(wtrans),byrow=FALSE)
Z[j,h,c,d]=sumlog(log(PI[j,h,c,d])+sweep(qu[,wtrans,c]+qub[,wtrans+1,d]+ap,1,liks))}}
}}}

## drop empty clusters ##

#for(t in 1:Ti) {
#if(k[t]>1) {
#if(any(apply(V[,t,1:k[t]],2,sum)==0)) {
#print("DROPPED EMPTY CLUSTER!!!")
#k[t]=k[t]-1}}}

if(verbose) {print("lk diff")}
if(verbose) {print(c(lkold,lik,lik-lkold))}
iters=iters+1
}

np=sum(2*r*unique(k))+k[1]-1

for(j in 1:kmax) {
for(h in 1:kmax) {
trans=k[-Ti]==j & k[-1]==h
if(any(trans)) {
np=np+j*(h-1)
}}}

aic=-2*lik+2*np
bic=-2*lik+log(n)*np

return(list(V=V,pi=pi,PI=PI,xi=xi,sigma=sigma,lik=lik,aic=aic,bic=bic,liks=liks))}

library(compiler)

rlm.fixed=cmpfun(rlm.fixed)


## Tidy Tuesday 9.18.19
## Kat Racine
## Code Originated- 9.17.19

###

ggplot(data = gas_price) +
  geom_point(mapping = aes(x = year, y = gas_current, color = "Retail Gas Price"), size = 4) +
  geom_smooth(mapping = aes(x = year, y = gas_current), se = FALSE, color = "black") +
  geom_point(mapping = aes(x = year, y = gas_constant, color = "2015 Relative Gas Price"), shape = 18, size = 4) +
  geom_smooth(mapping = aes(x = year, y = gas_constant), se = FALSE, color = "black") +
  theme_dark() + theme_classic() +
  labs(x = "Year", y = "Dollars per Gallon", title = "Average Historical Annual Gasoline Pump Price, 1929 - 2015",
       caption = "Data Souce: Office of Energy Efficiency & Renewable Energy",
       color = "") +
  theme(legend.position = "top")

ggsave("tidey_tuesday_gas_plot.pdf")


simulateNullInstDG = function(minimal_data, num_cat, num_cont, iters = 100){

	#Parse Data
	dat = parseMinimalData(minimal_data, num_cat, num_cont,
		n_cutoff = 1)

	r = fitBabyMonitor(minimal_data,
		num_cat, num_cont,
		dat_out = TRUE,
		n_cutoff = 1, iters = 2, burn_in = 2)

	#Extract variables
	y = r$dat$y #binary outcome vector
	N = r$dat$N #total # of individuals
	p = r$dat$p #total # of institutions
	inst_mat = r$inst_mat[ ,c('inst', 'n', 'o_mean')]

	pcf_vec = as.factor(r$dat$pcf_vec) #factor of pcf categories

	#Calculate success probablity for each pcf category
	pcf_success_rates = as.numeric(sapply(levels(pcf_vec),
		function(level) mean(y[pcf_vec == level])))

	#N x 1 vector of success probablities
	individual_prob_vec = pcf_vec
	levels(individual_prob_vec) = pcf_success_rates
	individual_prob_vec = as.numeric(levels(individual_prob_vec))[individual_prob_vec]

	#Initialize storage
	stat_z_mat = effect_mat = effect_se_mat = matrix(NA, nrow = p, ncol = iters)

	data_mat = matrix(NA, nrow = N, ncol = iters)

	for (i in 1:iters){#Loop over monte carlo iterations

		#Simulate data
		data_mat[ ,i] = rbinom(N, 1, individual_prob_vec)

		m_temp = minimal_data
		m_temp[ ,1] = data_mat[ ,i]

		#Parse data
		dat_temp = parseMinimalData(m_temp, num_cat, num_cont, n_cutoff = 1)

		dg = designBased(0.5, dat_temp$y,dat_temp$pcf_vec,
		dat_temp$inst_vec)

		stat_z_mat[ ,i] =dg$Z
		effect_mat[ ,i] = dg$D
		effect_se_mat[ ,i] = dg$SE

	}
	return( list(
		inst_mat = inst_mat,
		stat_z = stat_z_mat,
		effect = effect_mat,
		effect_se = effect_se_mat,
		data_mat = data_mat
		))
}


suppressPackageStartupMessages(library(kazaam))

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

dx = expand(x)
y = collapse(dx)

comm.print(all.equal(x, y))

finalize()


#GSR handling
episode02 <- read.csv("episode02.csv")
#if needed run lo pass filtering
m <- nrow(episode02)
SampleRate <- 10 #change accordingly samples per second
Filtered <- c() #currently is used 0.5Hz filtering, which means averaging over 2 seconds.
for (i in 1:m){
  if(i<2*SampleRate) Filtered[i]<-0 else Filtered[i]<-mean(episode02$GSR[(i-2*SampleRate):i])
}
episode02<-cbind(episode02,Filtered)
#further, may use episode02$Filtered instead of episode02$GSR in dealing with peaks
#install.packages("IDPmisc")
library(IDPmisc)
#peak extraction
pks02 <- peaks(x=episode02$time,y=episode02$GSR,minPH=0.02)
colnames(pks02) <- c('time','peak','width')
#dealing with peaks' power i.e. relational height of peaks
n <- nrow(pks02)
pks <- c()
for (i in 1:m) {
  pks[i] <- 0
}
#adding peak values as a col in original data set
for (j in 1:n) {
  a <- pks02$time[j]
  for (i in 1:m){
    if (episode02$time[i]==a) pks[i] <- episode02$GSR[i]
  }
}
episode02 <- cbind(episode02,pks)
#adding peak powers as a col in original data set
pwr <- c()
for (i in 1:m) {
  if (episode02$pks[i]==0) pwr[i] <- 0 else {
    b <- i
    while (episode02$GSR[b] >= episode02$GSR[b-1]) {
      pwr[i] <- (episode02$GSR[i]-episode02$GSR[b])
      b <- b-1
    }
  }
}
episode02 <- cbind(episode02,pwr)
#saving data set as csv
write.csv(episode02, file="02.csv", row.names = FALSE)
#if needed plot GSR, peaks and peak's power in time as a graph as pdf
#pdf("02.pdf")
#plot(episode01$time,episode01$GSR,type="l",col="red")
#lines(episode01$time,episode01$pks,type="l",col="blue")
#lines(episode01$time,episode01$pwr,type="l",col="green")
#dev.off()
#if needed, may remove unnecessary "width" column
#pks01<-pks01[,-3]
#plotting pks data set graph as pdf
#pdf("pks02.pdf") #opens graphic device. If necessary, define width = 5, height=10 (in inches)
#plot(pks02$time,pks02$peaks,type="p")
#dev.off()


########################### BayesKin ###########################
## Bayesian estimates of rigid body kinematics
## Andy Pohl
## UofC - Faculty of Kinesiology

## Written by: Andy Pohl
## UofC - Faculty of Kinesiology
## June-Dec 2020
## Revision 1: April 2021
################################################################

##################### RunMdl_TripleLink.r  ###################
## Performs analysis comparing Bayesian to Least squares approaches for
## 3 link kinematic chains.
################################################################
rm(list = ls())

WORKING_DIR = "" # Replace with the location of the BayesKin/src directory on the local PC.
SAVE_MDL = TRUE # assume save

INIT_TYPE = 'ls_est' # either 'true_vals', 'ls_est', 'random

setwd(WORKING_DIR)

source('library.r') # Retrieve function library
set.seed(1)  # Set seed for reproducibility

## 1) Specify parameters
n.links = 3               # Number of links.
seg.length = c(0.45, 0.35, 0.25)         # Length of segment specified in m. NB: Pataky pg 2.
r_true = c(0.07, 0.03)      # Origin location in m.
theta_true = c(-55, -110, -10)          # Rotation angle in deg. NB: specified to avoid 0/360 issue
# and mirroring solutions.
sigma_true = 1.5/1000       # Measurement noise in m. NB Noise specified as 1.5mm
# midpoint of range explored by Pataky et al.
true_vals = c(r_true = r_true, theta_true = theta_true, sigma_true = sigma_true)

# Generate posture
links = list(gen_link(seg.length = seg.length[1],
                      plate.center = 0.7*seg.length[1]),
             gen_link(seg.length = seg.length[2],
                      plate.center = 0.5*seg.length[2]),
             gen_link(seg.length = seg.length[3],
                      plate.center = 0.5*seg.length[3]))
posture = gen_posture(links, r = r_true, theta = theta_true)

nits = 1000 # number of iterations.
seeds = 1:nits
i = 1
while (length(list.files('./TripleLink_Mdl/Bayes_p3/')) < nits){
    files = list.files(path = paste0("./TripleLink_Mdl/Bayes_p5/"))
    processed_seeds = as.numeric(gsub("(.+?)(\\_.*)", "\\1", files))
    #set seed
    seed = seeds[i]

    if(!(seed %in% processed_seeds)){
        set.seed(seed)
        print(sprintf("Iteration %.0f of %.0f  -  seed = %.0f",length(list.files('./TripleLink_Mdl/Bayes_p5/')), nits, seed))
        # gen obs
        y = gen_obs(posture, sigma_true)

        #Compute LS solution.
        LS_result = LS_soln(y, links,
                            inits = c(r_true, theta_true, sigma_true),
                            init_type = 'true_vals')

        print("LS Solution Complete")
        r_mdl_file_name = paste0('./TripleLink_Mdl/LS/', as.character(as.numeric(seed)))
        r_mdl_file_name = paste0(r_mdl_file_name, '_')
        r_mdl_file_name = paste0(r_mdl_file_name, 'LSModel')
        r_mdl_file_name = paste0(r_mdl_file_name, '.rda')
        print(sprintf("Saving file %s", r_mdl_file_name))
        saveRDS(LS_result, file = r_mdl_file_name)
        #
        # Compute Bayes_P1
            Bayes_p1_result = Bayes_soln(y=y,
                                         links = links,
                                         mdlfile = './BayesModel_p1.jags',
                                         init_type = INIT_TYPE,
                                         true_vals = true_vals,
                                         ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))
        print("Bayes P1 Solution Complete")
        mdl_type = 'BayesModel_p1'
        r_mdl_file_name = paste0('./TripleLink_Mdl/Bayes_p1/', as.character(as.numeric(seed)))
        r_mdl_file_name = paste0(r_mdl_file_name, '_')
        r_mdl_file_name = paste0(r_mdl_file_name, mdl_type)
        r_mdl_file_name = paste0(r_mdl_file_name, '.rda')
        print(sprintf("Saving file %s", r_mdl_file_name))
        saveRDS(Bayes_p1_result, file = r_mdl_file_name)

        # Compute Bayes_P2
        Bayes_p2_result = Bayes_soln(y=y,
                                         links = links,
                                         mdlfile = './BayesModel_p2.jags',
                                         init_type = INIT_TYPE,
                                         true_vals = true_vals,
                                         ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))

        print("Bayes P2 Solution Complete")
        mdl_type = 'BayesModel_p2'
        r_mdl_file_name = paste0('./TripleLink_Mdl/Bayes_p2/', as.character(as.numeric(seed)))
        r_mdl_file_name = paste0(r_mdl_file_name, '_')
        r_mdl_file_name = paste0(r_mdl_file_name, mdl_type)
        r_mdl_file_name = paste0(r_mdl_file_name, '.rda')
        print(sprintf("Saving file %s", r_mdl_file_name))
        saveRDS(Bayes_p2_result, file = r_mdl_file_name)

        # Compute Bayes_P3
        Bayes_p3_result = Bayes_soln(y=y,
                                         links = links,
                                         mdlfile = './BayesModel_p3.jags',
                                         init_type = INIT_TYPE,
                                         true_vals = true_vals,
                                         ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))

        print("Bayes P3 Solution Complete")
        mdl_type = 'BayesModel_p3'
        r_mdl_file_name = paste0('./TripleLink_Mdl/Bayes_p3/', as.character(as.numeric(seed)))
        r_mdl_file_name = paste0(r_mdl_file_name, '_')
        r_mdl_file_name = paste0(r_mdl_file_name, mdl_type)
        r_mdl_file_name = paste0(r_mdl_file_name, '.rda')
        print(sprintf("Saving file %s", r_mdl_file_name))
        saveRDS(Bayes_p3_result, file = r_mdl_file_name)

        # Comppute Bayes P4
        Bayes_p4_result = Bayes_soln(y=y,
                                     links = links,
                                     mdlfile = './BayesModel_p4.jags',
                                     init_type = INIT_TYPE,
                                     true_vals = true_vals,
                                     ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))

        mdl_type = 'BayesModel_p4'
        r_mdl_file_name = paste0('./TripleLink_Mdl/Bayes_p4/', as.character(as.numeric(seed)))
        r_mdl_file_name = paste0(r_mdl_file_name, '_')
        r_mdl_file_name = paste0(r_mdl_file_name, mdl_type)
        r_mdl_file_name = paste0(r_mdl_file_name, '.rda')
        print(sprintf("Saving file %s", r_mdl_file_name))
        saveRDS(Bayes_p4_result, file = r_mdl_file_name)

        # Comppute Bayes P5
        Bayes_p5_result = Bayes_soln(y=y,
                                     links = links,
                                     mdlfile = './BayesModel_p5.jags',
                                     init_type = INIT_TYPE,
                                     true_vals = true_vals,
                                     ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))

        mdl_type = 'BayesModel_p5'
        r_mdl_file_name = paste0('./TripleLink_Mdl/Bayes_p5/', as.character(as.numeric(seed)))
        r_mdl_file_name = paste0(r_mdl_file_name, '_')
        r_mdl_file_name = paste0(r_mdl_file_name, mdl_type)
        r_mdl_file_name = paste0(r_mdl_file_name, '.rda')
        print(sprintf("Saving file %s", r_mdl_file_name))
        saveRDS(Bayes_p5_result, file = r_mdl_file_name)
    }
    i = i+1
    print('#######################################################################')
}


# #Duplicating rows and columns
# #Identify food webs with rows/columns to duplicate - needs to be done if dealing with mutliple food webs at once
#   dup.fw <- NA
#   for(k in 1:length(GlobalWeb)){
#     x <- which(str_detect(rownames(x)," - ") == TRUE) #Identify rows that should be Duplicated
#     if(length(x) == 0) {NULL} else {dup.fw <- c(dup.fw,k)}
#   }
#   dup.fw <- dup.fw[-1]

#Duplication procedure
  #Duplicated rows
    #Matrix with duplicated rows
dupl_row <- function(x,y) { # x = matrix to duplicate taxon; y = taxon list from matrix x
      nb.name <- ncol(x)
      col.tx <- colnames(x)
      rownames(x) <- y
      mat.row <- matrix(ncol=nb.name,nrow=0) #Matrix to insert duplicated row values.
      colnames(mat.row) <- colnames(x) #Matrix to insert duplicated row values

      z <- which(str_detect(y," - ") == TRUE) #Identify rows that should be duplicated
      for(i in 1:length(z)){
        dup.row <- as.matrix(x[z[i],]) #Extract the values of each row to duplicate. as.matrix() important, otherwise when data.frame() imports columns as lists
        dup.name <- str_split(y[z[i]]," - ")[[1]] #Duplicated names to split
        nb.tx <-length(dup.name) #Number of taxa to split
        dup.row <- as.matrix(dup.row)
        dup.tx <- matrix(ncol=nb.name,nrow=nb.tx,data=rep(dup.row,nb.tx),byrow=TRUE,dimnames=list(dup.name,col.tx)) #duplicated values in a matrix
        mat.row <- rbind(mat.row,dup.tx) #rbind new rows
      }
    x <- rbind(x[-z,],mat.row) #Insert new rows to food web and remove duplicated strings
    return(x)
}

  #Duplicated columns
    #Matrix with duplicated rows
  dupl_col <- function(x,y) { # x = matrix to duplicate taxon; y = taxon list from matrix x
      nb.name <- nrow(x)
      col.tx <- rownames(x)
      colnames(x) <- y
      mat.col <- matrix(ncol=0,nrow=nb.name) #Matrix to insert duplicated column values
      rownames(mat.col) <- rownames(x) #Matrix to insert duplicated column values

      z <- which(str_detect(y," - ") == TRUE) #Identify columns that should be duplicated
      for(i in 1:length(z)){
        dup.col <- x[,z[i]] #Extract the values of each column to duplicate
        dup.name <- str_split(y[z[i]]," - ")[[1]] #Duplicated names to split
        nb.tx <-length(dup.name) #Number of taxa to split
        dup.tx <- matrix(ncol=nb.tx,nrow=nb.name,data=rep(dup.col,nb.tx),byrow=FALSE,dimnames=list(col.tx,dup.name)) #duplicated values in a matrix
        mat.col <- cbind(mat.col,dup.tx) #rbind new rows
      }
    x <- cbind(x[,-z],mat.col) #Insert new rows to food web and remove duplicated strings
    return(x)
}


# Data Prepocessing

# Importing the dataset
dataset = read.csv('Data.csv')
# dataset = dataset[, 2:3]

# Splitting the dataset into the Training set and Test set
# install.packages('caTools')
# library(caTools)

set.seed(123)
split = sample.split(dataset$Purchased, SplitRatio = 0.8)
training_set = subset(dataset, split == TRUE)
test_set = subset(dataset, split == FALSE)

# Feature Scaling

# training_set[, 2:3] = scale(training_set[, 2:3])
# test_set[, 2:3] = scale(test_set[, 2:3])


#=============================================================
# c:/1work/Modelling/QFC_workshop/examples/8_admb_r/admbUtils_demo.r
# Created: 12/04/13 5:44 PM
#
# DESCRIPTION:
#
# This scripts demonstrates how to use the basic functions in
# ADMButils to read and write files that can be read by/ or are
# produced by AD Model Builder.
#
#=============================================================

# LIBRARIES:
library(lattice)
library(ADMButils)

#=============================================================

#read in the same dataset we have been working with all day
mydata <- read.csv('whitefish.csv', header=TRUE)
head(mydata)

#===============
#  write.dat()

#write.dat takes a filename and named list of data elements and
#creates a dat file that can be read by admb.  Elemnts in the data
#list must match the order expected by admb.
fname <- "Von_Bert.dat"
data_list <- list(Linf_L=300, Linf_U=1200, nobs=nrow(mydata),
                  data=mydata)
write.dat(L=data_list,name=fname)

#write_dat() also recodes any character or factor variables and includes a
#key in dat file. Try
#write.dat(L=list(iris=iris),name='iris.dat')

#===============
#  write.pin()

#write.pin takes a filename and named list of parameters and their
#starting values and creates a dat file that can be read by admb.
#Elements in the parameter list must match the order that parameters
#are declared in the parameter section of your tpl.
fname <- "Von_Bert.pin"
pin_list <- list(Linf=max(mydata$FLEN), k=0.3, t0=0)
write.pin(L=pin_list, name=fname)

#===============
#  read.par()

# given the path to a fitted admb object, read.par() will read the parameter file and return its contents as a named list, including the gradient, objectitive function and parameter count.
# if reduced==TRUE, the parameter estimates will be omitted (see read.std())
fit <-  read.par("Von_Bert", reduce=FALSE)
fit
str(fit)
fit$par.cnt
fit$obj.fct
fit$gradient
fit$Linf

#===============
#  read.std()

# given the path to a fitted admb object, read.std() will read the std file and return its contents either as a dataframe or as a named list,
fit <-  read.std("Von_Bert")
fit
str(fit)

fit <-  read.std("Von_Bert", as.df=FALSE)
fit
str(fit)

#===============
#  read.fit()

# given the path to a fitted admb object, read.fit() will read the parameter and std files and return their contents as a named list, including the gradient, objectitive function and parameter count.
#read.fit() is actually just a wrapper for read.par() and read.std()
fit <-  read.fit("Von_Bert")
str(fit)
fit$est
fit$std
fit$cov
fit$cor

#===============
#read.mcmc()

#read.mcmc() will attempt to read in an mcmc file, parse it and return
#a coda object.  If the mcmc file is a cvs file with a header row, no
#additional arguments are needed.

# don't forget to create mcmc chain first;
# -mcmc 100000 -mcsave 50
# -mceval

mcmc <- read.mcmc(mcmc.file="mcmc.csv")
class(mcmc)
str(mcmc)
# because its already an mcmc object we can use some of R's canned
# plotting functions for mcmc's.
plot(mcmc)
xyplot(mcmc,  aspect="fill", layout=c(2,2))
densityplot(mcmc, aspect="fill", layout=c(2,2))
acfplot(mcmc, aspect="fill", layout=c(2,2))
qqmath(mcmc, aspect="fill", layout=c(2,2))

#===============
# readcxx()

# if you used admb2r to create an rdat file for additional model output, you can call readcxx() to get a named list that contain all of the values in par file, the std file and the contents of rdat.

fit <-  readcxx("Von_Bert")
str(fit)
fit$std

#scalars in vector list can be accessed with literal scripting:
fit$dims['nobs']
fit$dims$nobs    # Error - won't work for vectors
#scalars in info_list can be accessed as sublists
fit$dims2$nobs
fit$dims2['nobs']  #both work here.

plot(fit$residuals$Age,fit$residuals$resid)


if(!require(imbalance)){install.packages("imbalance");require(imbalance)}
### ROSE = Random Over-Sampling Examples
if(!require(ROSE)){install.packages("ROSE");require(ROSE)}
if(!require(partykit)){install.packages("partykit");require(partykit)}
if(!require(dplyr)) {install.packages("dplyr");require(dplyr)}
if(!require(ggplot2)) {install.packages("ggplot2");require(ggplot2)}
if(!require(DBI)){install.packages("DBI"); require(DBI)}
if(!require(RSQLite)){install.packages("RSQLite"); require(RSQLite)}

##############################################################################
##########                DATABASE FUNCTIONS                     #############
##############################################################################

#### Read function to import data from the SQL to a pandas dataframe.
readSQL <- function(query, db=DB_FILE) {
    require(DBI)
    require(RSQLite)
    con <- dbConnect(SQLite(), DB_FILE)
    df <- dbGetQuery(con, query)
    return(df)
}
#### Write a pandas dataframe into an SQL table. Use overwrite=True if you want to delete
#### first a pre-existent table with the same name. Use append=True if you want to append
#### the data in the dataframe to a pre-existent table.
writeSQL <- function(df,tablename,overwrite=FALSE, append=FALSE,db=DB_FILE) {
    require(DBI)
    require(RSQLite)
    con <- dbConnect(SQLite(), DB_FILE)
    dbWriteTable(con,tablename,df,overwrite,append)
}
####
listTables <- function(db=DB_FILE) {
    require(DBI)
    require(RSQLite)
    con <- dbConnect(SQLite(), DB_FILE)
    ### list the tables on the DB
    res <- dbListTables(con)
    return(res)
}

### load data
DB_FILE = (paste0(getwd(),"/Data/loans.db"))
listTables()
loansX = readSQL("SELECT * FROM X_train_scaled")
loansY = readSQL("SELECT [default] FROM Y_train")

train = cbind(loansX,loansY)

loansX = readSQL("SELECT * FROM X_dev_scaled")
loansY = readSQL("SELECT [default] FROM Y_dev")

dev = cbind(loansX,loansY)

train <- train%>%select(-one_of(c('index')))
dev <- dev%>%select(-one_of(c('index')))

table(train$default)
table(train$default)/nrow(train)*100

numPositive <- length(which(train$default == 1))
numNegative <- length(which(train$default == 0))
nInstances <- numNegative - numPositive
cbind(numPositive=numPositive,numNegative=numNegative,nInstances=nInstances)

mod1 <- ctree(default ~., data=train)
auc1 <- pROC::auc(dev$default, predict(mod1,newdata=dev,type="response"))
auc1

#under sampling
data_balanced_under <- ovun.sample(default ~ ., data = train, method = "under",N = numPositive*2)$data
table(data_balanced_under$default)

mod1 <- ctree(default ~., data=data_balanced_under)
auc1 <- pROC::auc(dev$default, predict(mod1,newdata=dev,type="response"))
auc1

#over sampling
data_balanced_over <- ovun.sample(default ~ ., data = train, method = "over",N = numNegative*2)$data
table(data_balanced_over$default)

mod1 <- ctree(default ~., data=data_balanced_over)
auc1 <- pROC::auc(dev$default, predict(mod1, newdata=dev,type="response"))
auc1

#over_under sampling
data_balanced_both <- ovun.sample(default ~ ., data = train, method = "both", p=0.5, seed = 1207)$data
table(data_balanced_both$default)

mod1 <- ctree(default ~., data=data_balanced_both)
auc1 <- pROC::auc(dev$default, predict(mod1, newdata=dev,type="response"))
auc1

# Rose:
data.rose <- ROSE(default ~ ., data = train, seed = 1207)$data
table(data.rose$default)

mod1 <- ctree(default ~., data=data.rose)
auc1 <- pROC::auc(dev$default, predict(mod1, newdata=dev,type="response"))
auc1


#!/usr/bin/env Rscript
# Aggregate and collapse model-based mapping data into relevant measurements.
# Eric Barefoot
# Sep 2019

# This set of routines takes data as mapped in Agisoft metashape and exported as
# .shp files, then puts it into a table format as expected for the rest of the
# analysis for this project (i.e. a tidy data frame with each entry being a measurement)
# this data frame is later appended to the field-based dataset

# first, require libraries

# require()

# now introduce and define necessary functions for collapsing data

# this function calculates the distance along the mapped linear feature.

barfaceDistFun = function(X, Y, Z)
{
	x = cbind(X,Y,Z)

	dists = dist(x)

	disc = (1 - 4 * -2 * length(dists))

	if (disc > 0)
	{
		size = (-1 + sqrt(disc)) / 2
	}
	else
	{
		error('no solutions!')
	}

	face = numeric(size)

	j = 0

	for (i in 1:size)
	{
		face[i] = i + j
		j = j + size - i
	}

	barface_length = sum(dists[face])

	return(barface_length)
}


# calculate_compensation_final_step.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

# Runs a calculation of compensation with autospill, creating figures and
# tables at the final step.
#
# Requires assigning proper values to the variables:
#     control.dir    directory with the set of single-color controls
#     control.def.file    csv file defining the names and channels of the
#         single-color controls

library( autospill )

# set parameters

asp <- get.autospill.param( "final.step" )

# read flow controls

control.dir <- "../fcs_control_data/"
control.def.file <- "../fcs_control_data/fcs_control.csv"

flow.control <- read.flow.control( control.dir, control.def.file, asp )

# gate events before calculating spillover

flow.gate <- gate.flow.data( flow.control, asp )

# get initial spillover matrices from untransformed and transformed data

marker.spillover.unco.untr <- get.marker.spillover( TRUE, flow.gate,
    flow.control, asp )
marker.spillover.unco.tran <- get.marker.spillover( FALSE, flow.gate,
    flow.control, asp )

# refine spillover matrix iteratively

refine.spillover.result <- refine.spillover( marker.spillover.unco.untr,
    marker.spillover.unco.tran, flow.gate, flow.control, asp )


library(magrittr)
library(tidyr)
library(ggplot2)
library(purrr)

data = read.csv("datasets/CardiacDataAdj.csv")
data.continous = keep(data, function(x) {!(all(x %in% c(0,1,0.5)))})
data.categorical = keep(data, function(x) {all(x %in% (c(0,1,1.5)))})

data.continous %>%
  gather() %>%                             # Convert to key-value pairs
  ggplot(aes(value)) +                     # Plot the values
  facet_wrap(~ key, scales = "free") +     # In separate panels
  geom_density() +                         # Density Plot
  theme(axis.text.x = element_text(angle = 90))


b <- c(1,3,7,5,3,2)
f <- sqrt(b)
plot(b,f)


#' @importFrom dplyr %>% select
#' @importFrom gtsummary tbl_summary
v_x_table <- function(d, x_term, y_term, by) {
  d %>%
    select(x_term, by) %>%
    tbl_summary(by = by, missing = "always", missing_text = "NA")
}

#' @importFrom ggstatsplot ggscatterstats grouped_ggscatterstats
v_scatter <- function(d, x_term, y_term, by) {
  if (!is.null(by)) {
    p <- ggscatterstats(
      d,
      x = !!sym(eval(x_term)),
      y = !!sym(eval(y_term)),
      results.subtitle = FALSE
    )
  } else {
    p <- grouped_ggscatterstats(
      d,
      x = !!sym(eval(x_term)),
      y = !!sym(eval(y_term)),
      grouping.var = !!sym(eval(by)),
      results.subtitle = FALSE
    )
  }
  p
}

#' @importFrom ggstatsplot ggbetweenstats grouped_ggbetweenstats
v_between_x_fac_y_num  <- function(d, x_term, y_term, by) {
  if (is.null(by)) {
    p <- ggbetweenstats(
      data = d,
      x = !!sym(eval(x_term)),
      y = !!sym(eval(y_term)),
      results.subtitle = FALSE
    )
  } else {
    p <- grouped_ggbetweenstats(
      data = d,
      x = !!sym(eval(x_term)),
      y = !!sym(eval(y_term)),
      grouping.var = !!sym(eval(by)),
      results.subtitle = FALSE
    )
  }
  p
}

#' @importFrom ggstatsplot ggbetweenstats grouped_ggbetweenstats
v_between_x_num_y_fac <- function(d, x_term, y_term, by) {
  if (is.null(by)) {
    p <- ggbetweenstats(
      data = d,
      x = !!sym(eval(y_term)),
      y = !!sym(eval(x_term)),
      results.subtitle = FALSE
    )
  } else {
    p <- grouped_ggbetweenstats(
      data = d,
      x = !!sym(eval(y_term)),
      y = !!sym(eval(x_term)),
      grouping.var = !!sym(eval(by)),
      results.subtitle = FALSE
    )
  }
  p
}

#' @importFrom ggstatsplot ggbarstats grouped_ggbarstats
v_barstats <- function(d, x_term, y_term, by) {
  if (is.null(by)) {
    p <- ggbarstats(
      data = d,
      x = !!sym(eval(x_term)),
      y = !!sym(eval(y_term)),
      results.subtitle = FALSE
    )
  } else {
    p <- grouped_ggbarstats(
      data = d,
      x = !!sym(eval(x_term)),
      y = !!sym(eval(y_term)),
      grouping.var = !!sym(eval(by)),
      results.subtitle = FALSE
    )
  }
  p
}

#' @importFrom survminer surv_fit ggsurvplot
v_survplot <- function(d, x_term, y_term, by) {
  form_str <- paste(y_term, "~", x_term)
  if (!is.null(by)) {
    if (!is.factor(d[[by]]) & !is.character(d[[by]])) {
      stop("By argument must be coersible into a factor.")
    }
    form_str <- paste(form_str, "+", by)
    nl <- length(levels(factor(paste(d[[x_term]], d[[by]]))))
  } else {
    nl <- length(levels(factor(paste(d[[x_term]]))))
  }
  conf_int <- TRUE
  risk_table = TRUE
  ncensor_plot = TRUE
  if (nl > 5) {
    conf_int <- FALSE
    risk_table = FALSE
    ncensor_plot = FALSE
  }

  form <- as.formula(form_str)
  fit <- surv_fit(form, data = d)
  ggsurvplot(
    fit,
    data = d,
    conf.int = conf_int,
    risk.table = risk_table,
    ncensor.plot = ncensor_plot
  )
}


source('~/project/main.r')
library('highcharter')
library('arules')
library('arulesViz')

row_assoc <-arrange(filter(row_refine,車種=='C03'))
row_assoc <-arrange(filter(row_assoc,當事者行動狀態==9))
row_assoc <- select(row_assoc, 道路類別意義, 道路型態意義,事故位置意義,事故類型及型態意義,
                  道路型態意義)

rules=apriori(row_assoc, parameter = list(supp=0.2,conf=0.2,minlen=2))
rules=sort(rules,by="lift")
inspect(rules[1:10])
plot(rules,method = "graph", control=list(type="itemsets"), main=NULL)

## 事故類型及型態意義=車與車-路口交岔撞
row_assoc <-arrange(filter(row_refine,車種=='C03'))
row_assoc <-arrange(filter(row_assoc,當事者行動狀態==9))
row_assoc <-arrange(filter(row_assoc, 事故類型及型態==13)) #事故類型及型態意義=車與車-路口交岔撞 - 15

row_assoc <- select(row_assoc,道路類別意義,
                    事故位置意義,主要肇因意義,
                    旅次目的意義,事故類別意義)

# rules=apriori(row_assoc, parameter = list(supp=0.2,conf=0.2,minlen=2))
# rules <- apriori (data=row_assoc, parameter=list (supp=0.2,conf=0.2,minlen=1),
                 # appearance = list (default="lhs",rhs="事故類別意義=爭(搶)道行駛"), control = list (verbose=F))

rules=sort(rules,by="lift")
inspect(rules[1:10])
plot(rules,method = "graph", control=list(type="itemsets"), main=NULL)


#dir <- "Desktop/tagging"
dir<- "~/../SkyDrive/Work/Papers_finished/Tagger_effects/iotc"
setwd(dir)
require(splines)
require(lme4)
require(pkpkg)
require(plotrix)
require(boot)
require(car)
require(MASS)
require(R4MFCL)
ddrive <- "D:/assessments/tagging/tagger_fx/TagFX_paper/"
#ddrive <- "P:/tagging/tagger_fx/TagFX_paper/"
dd_iotc <- ppath(ddrive,"iotc")

#"I:\assessments/tagging/Rep22_Q1_by_sch_simonh (02_12_2008).csv"

source("../R_scripts/load_iotc.r")
source("../R_scripts/prepare_data_both.r")
source("../R_scripts/output.r")
source("../R_scripts/support_functions.r")

infile <- "TAG_REC_AB3.txt"
iotags <- load_iotc(infile)
iotag_all <- prepare_data(iotags,maxprt=8000,xpf="TaggerExp.csv",reg="iotc")
dat <- iotagsub <- aggdata(dat=iotag_all,minTperSch=20,archival=T,xptype=F,tagger.tagtype=F,cond=F,cradle=T); str(iotagsub)
dat$cradle2[dat$cradle2=="ARC"] <- unique(dat$cradle2)[1]
dat$cradle2 <- as.factor(as.character(dat$cradle2))
levels(dat$cradle2)
tapply(iotagsub$wts,iotagsub$cradle2,sum,na.rm=T)
tapply(iotagsub$wts,iotagsub$OTC,sum,na.rm=T)
tapply(iotag_all$OTC,list(iotag_all$OTC,iotag_all$sp_id),length)
###################

AIClist <- vector()
mod_att <- glm(recap ~ tagger + ns(len5,df=4)*sp_id + Qual + Cond2 + OTC + tag_type + tag_sch_id + cradle2,data=dat,weights=wts,family=binomial("logit")) # originally mod_noa (wrong name)
summary(mod_att)
save(mod_att,file=ppath(ddrive,"iotc/iotc_mod2.RData"))

mod_noa_B <- glm(recap ~ tagger + ns(len5,df=4) + Qual + Cond2 + OTC + tag_type + tag_sch_id + cradle2,data=dat[dat$sp_id=="B",],weights=wts,family=binomial("logit"))
save(mod_noa_B,file=ppath(ddrive,"/iotc/iotc_mod2_B.RData")); rm(mod_noa_B); gc()
mod_noa_S <- glm(recap ~ tagger + ns(len5,df=4) + Qual + Cond2 + OTC + tag_type + tag_sch_id + cradle2,data=dat[dat$sp_id=="S",],weights=wts,family=binomial("logit"))
save(mod_noa_S,file=ppath(ddrive,"/iotc/iotc_mod2_S.RData")); rm(mod_noa_S); gc()
mod_noa_Y <- glm(recap ~ tagger + ns(len5,df=4) + Qual + Cond2 + OTC + tag_type + tag_sch_id + cradle2,data=dat[dat$sp_id=="Y",],weights=wts,family=binomial("logit"))
save(mod_noa_Y,file=ppath(ddrive,"/iotc/iotc_mod2_Y.RData")); rm(mod_noa_Y); gc()
load(ppath(ddrive,"/iotc/iotc_mod2_B.RData"))
load(ppath(ddrive,"/iotc/iotc_mod2_Y.RData"))
load(ppath(ddrive,"/iotc/iotc_mod2_S.RData"))
load(ppath(ddrive,"/iotc/iotc_mod2.RData"))
mod_noa_B$formula
mod_noa_Y$formula
mod_noa_S$formula
mod_att$formula
sum(AIC(mod_noa_S,mod_noa_B,mod_noa_Y))  # mod_noa has OTC but not cradle
AIC(mod_att)

# Load mod_att and the species-level mods with all tag types

# Plot figures for best model
load(ppath(ddrive,"/iotc/iotc_mod2.RData"))
output(dat=dat,                 res=mod_att,  pltagger=T,anon=T,pltagtype=T,pldiag=F,plxprt=F,plcradle=T,condor=F,pltagger.type=F,plOTC=T,plcond=T,plqual=T,plsize=T,plevent=T,do_ci=F,prefix_nm="iotc_att2",io_agg=T,pltype="pdf");graphics.off()
output(dat=dat[dat$sp_id=="B",],res=mod_noa_B,pltagger=T,anon=T,pltagtype=T,pldiag=F,plxprt=F,plcradle=T,condor=F,pltagger.type=F,plOTC=T,plcond=T,plqual=T,plsize=T,plevent=T,do_ci=T,prefix_nm="iotc_att2_B",io_agg=T,pltype="pdf");graphics.off()
output(dat=dat[dat$sp_id=="Y",],res=mod_noa_Y,pltagger=T,anon=T,pltagtype=T,pldiag=F,plxprt=F,plcradle=T,condor=F,pltagger.type=F,plOTC=T,plcond=T,plqual=T,plsize=T,plevent=T,do_ci=T,prefix_nm="iotc_att2_Y",io_agg=T,pltype="pdf");graphics.off()
output(dat=dat[dat$sp_id=="S",],res=mod_noa_S,pltagger=T,anon=T,pltagtype=T,pldiag=F,plxprt=F,plcradle=T,condor=F,pltagger.type=F,plOTC=T,plcond=T,plqual=T,plsize=T,plevent=T,do_ci=T,prefix_nm="iotc_att2_S",io_agg=T,pltype="pdf");graphics.off()

AIC_mod_att <- drop1(mod_att)
write.csv(AIC_mod_att,file="ioAIC_mod_att2.csv")

load(ppath(ddrive,"/iotc/iotc_mod2_B.RData"))
AIC_mod_noa_B <- drop1(mod_noa_B); rm(mod_noa_B)
save(AIC_mod_noa_B,file="ioAIC_mod2_B_noa.RData")  # Old version file="ioAIC_mod_noa.RData" lacked cradle2 and used Cond instead of cond2
load(ppath(ddrive,"/iotc/iotc_mod2_Y.RData"))
AIC_mod_noa_Y <- drop1(mod_noa_Y); rm(mod_noa_Y);gc()
save(AIC_mod_noa_Y,file="ioAIC_mod2_Y_noa.RData")  # Old version file="ioAIC_mod_noa.RData" lacked cradle2 and used Cond instead of cond2
load(ppath(ddrive,"/iotc/iotc_mod2_S.RData"))
AIC_mod_noa_S <- drop1(mod_noa_S); rm(mod_noa_S);gc()
save(AIC_mod_noa_S,file="ioAIC_mod2_S_noa.RData")  # Old version file="ioAIC_mod_noa.RData" lacked cradle2 and used Cond instead of cond2

write.csv(AIClist,file="AIClist.csv")

load(file=ppath(ddrive,"paper_xs/iotc/imod_noa.RData"))
AIC(mod_noa)
load(file="imod_noa_B.RData")
load(file="imod_noa_S.RData")
load(file="imod_noa_Y.RData")
sum(AIC(mod_noa_B,mod_noa_S,mod_noa_Y))

# Summarise for mod_att by species, with archival tags "recap ~ tagger.tagtype + ns(len5,df=4) + Qual + Cond + OTC + tag_sch_id"
load(file="ioAIC_mod2_B_noa.RData")
load(file="ioAIC_mod2_Y_noa.RData")
load(file="ioAIC_mod2_S_noa.RData")
#AIC_mod_NOAx <- read.csv(file="ioAIC_mod_noa.csv")
AIC_mod_NOAx <- read.csv(file="ioAIC_mod_att2.csv")
require(xtable)
rownms <- c("Full model","Tag type","Tagger","Tag placement quality","Tagging cradle","Fish condition","OTC","Length","Length:Species",                  "Tagging event")
lrows <- c("<none>",     "tag_type", "tagger","Qual",                "cradle2",       "Cond",          "OTC","ns(len5, df = 4)","ns(len5, df = 4):sp_id","tag_sch_id")
lrows2 <- c("<none>",     "tag_type", "tagger","Qual",                "cradle2",       "Cond2",          "OTC","ns(len5, df = 4)","ns(len5, df = 4):sp_id","tag_sch_id")
AICsummaryIO <- data.frame(mod=rownms,
            BET_YFT_SKJ= c(AIC_mod_NOAx[1,4],  AIC_mod_NOAx  [match(lrows2,AIC_mod_NOAx[,1]),4][-1] -         AIC_mod_NOAx[1,4]),
            BET=         c(AIC_mod_noa_B[1,3], AIC_mod_noa_B [match(lrows2,rownames( AIC_mod_noa_B)),3][-1] - AIC_mod_noa_B[1,3]),
            YFT=         c(AIC_mod_noa_Y[1,3], AIC_mod_noa_Y [match(lrows2,rownames( AIC_mod_noa_Y)),3][-1] - AIC_mod_noa_Y[1,3]),
            SKJ=         c(AIC_mod_noa_S[1,3], AIC_mod_noa_S [match(lrows2,rownames( AIC_mod_noa_S)),3][-1] - AIC_mod_noa_S[1,3]))
xtAICsummaryIO <- xtable(AICsummaryIO,digits=1)
print.xtable(xtAICsummaryIO,type="html",file="AICsummaryIO.html")
AICsummaryIO

# Table 3: Table of parameter estimates
# parameter estimates in the file
aBYS <- rbind(read.csv("iotc_att2_Qual_parests.csv"),read.csv("iotc_att2_cradle2_parests.csv"),read.csv("iotc_att2_OTC_parests.csv"))
aB <- rbind(read.csv("iotc_att2_B_Qual_parests.csv"),read.csv("iotc_att2_B_cradle2_parests.csv"),read.csv("iotc_att2_B_OTC_parests.csv"))
aS <- rbind(read.csv("iotc_att2_S_Qual_parests.csv"),read.csv("iotc_att2_S_cradle2_parests.csv"),read.csv("iotc_att2_S_OTC_parests.csv"))
aY <- rbind(read.csv("iotc_att2_Y_Qual_parests.csv"),read.csv("iotc_att2_Y_cradle2_parests.csv"),read.csv("iotc_att2_Y_OTC_parests.csv"))
cols <- c(6:8)
tab3 <- xtable(cbind(aBYS[,c(1,cols)],aB[,cols],aY[,cols],aS[,cols]),digits=2)
print.xtable(tab3,type="html",file="tab3.html")

AICsummaryALL <- data.frame(mod=AIC_mod_att[,1],deltaAIC_all=AIC_mod_att[,3]-AIC_mod_att[1,3])                           # Full model
AICsummarySPP <- data.frame(mod=rownames(AIC_mod_att_B_obj),deltaAIC_B=AIC_mod_att_B_obj[,3]-AIC_mod_att_B_obj[1,3],   #single sp models
deltaAIC_S=AIC_mod_att_S_obj[,3]-AIC_mod_att_S_obj[1,3],
deltaAIC_Y=AIC_mod_att_Y_obj[,3]-AIC_mod_att_Y_obj[1,3])
AICsummaryBY <- data.frame(mod=rownames(AIC_mod_att_BY_obj),deltaAIC_BY=AIC_mod_att_BY_obj[,3]-AIC_mod_att_BY_obj[1,3]) # BY model
AICsummary <- cbind(AICsummarySPP,deltaAIC_all=AICsummaryALL[c(1,2,1,3:8),2],deltaAIC_BY=AICsummaryBY[c(1,2,1,3:8),2])

# Table 2. estimate relative tag recovery
############### effective tags
# predict recoveries using existing model, then as if everyone was JPH and condition etc were good. Divide releases through by the ratio.
dir<- "C:/Users/simonh/Dropbox/Papers/Tagger_effects/iotc"
setwd(dir)
require(splines)
require(lme4)
require(pkpkg)
require(plotrix)
require(boot)
require(car)
require(MASS)
require(R4MFCL)
ddrive <- "D:/assessments/tagging/tagger_fx/TagFX_paper/"
dd_iotc <- ppath(ddrive,"iotc")
source("../R_scripts/load_iotc.r")
source("../R_scripts/prepare_data_both.r")
source("../R_scripts/output.r")
source("../R_scripts/support_functions.r")
infile <- "TAG_REC_AB3.txt"
iotags <- load_iotc(infile)
iotag_all <- prepare_data(iotags,maxprt=8000,xpf="TaggerExp.csv",reg="iotc")
dat <- iotagsub <- aggdata(dat=iotag_all,minTperSch=20,archival=T,xptype=F,tagger.tagtype=F,cond=F,cradle=T); str(iotagsub)
dat$cradle2[dat$cradle2=="ARC"] <- unique(dat$cradle2)[1]
dat$cradle2 <- as.factor(as.character(dat$cradle2))
levels(dat$cradle2)
##
load(ppath(ddrive,"/iotc/iotc_mod.RData"))
load(ppath(ddrive,"/iotc/iotc_mod2.RData"))
pfull <- predict.glm(mod_att,newdata=dat,type="response")
tag.pred <- dat
tag.pred$tagger <- dat$tagger[grep("JPH",dat$tagger)][1]
tag.pred$tag_type <- levels(dat$tag_type)[1]
tag.pred$cradle2 <- dat$cradle2[grep("Front",dat$cradle2)][1]
tag.pred$Cond <- levels(dat$Cond)[1]
tag.pred$Qual <- levels(dat$Qual)[1]
tag.pred$OTC <- levels(dat$OTC)[1]
ppred <- predict.glm(mod_att,newdata=tag.pred,type="response")
sum(dat$wts*pfull)/sum(dat$wts*ppred)
#for(ss in c("B","S","Y")) {
#  tag.ss <- iotagsub[iotagsub$sp_id == ss,]
#  pss <- cbind(tag.ss,pfull[iotagsub$sp_id == ss],ppred[iotagsub$sp_id == ss])
#  print(sum(pss$wts*pss[,14]) / sum(pss$wts*pss[,15]))
#  }
ntp=7
effectlist <- data.frame(tp=rep("x",ntp),ratio=rep(0,ntp),stringsAsFactors = F)
pfull <- predict.glm(mod_att,newdata=dat,type="response")
for(x in 1:ntp) {
  tag.pred <- dat
  if(x==1) { tag.pred$tagger <- dat$tagger[grep("JPH",dat$tagger)][1]; effectlist[x,]$tp <- "tagger" }
  if(x==2) { tag.pred$tag_type <- levels(dat$tag_type)[1]; effectlist[x,]$tp <- "tag_type" }
  if(x==3) { tag.pred$cradle2 <- dat$cradle2[grep("Front",dat$cradle2)][1]; effectlist[x,]$tp <- "cradle2" }
  if(x==4) { tag.pred$Cond <- levels(dat$Cond)[1]; effectlist[x,]$tp <- "Cond" }
  if(x==5) { tag.pred$Qual <- levels(dat$Qual)[1]; effectlist[x,]$tp <- "Qual" }
  if(x==6) { tag.pred$OTC <- levels(dat$OTC)[1]; effectlist[x,]$tp <- "OTC" }
  if(x==7) {
    tag.pred$tagger  <- dat$tagger[grep("JPH",dat$tagger)][1]
    tag.pred$OTC  <- levels(dat$OTC)[1]
    tag.pred$cradle2 <- dat$cradle2[grep("Front",dat$cradle2)][1]
    tag.pred$Cond <- levels(dat$Cond)[1]
    tag.pred$Qual <- levels(dat$Qual)[1]
    tag.pred$tag_type<- levels(dat$tag_type)[1]
    effectlist[x,]$tp <- "All"
    }
  ppred <- predict.glm(mod_att,newdata=tag.pred,type="response")
  tag.ss <- dat
  pss <- cbind(tag.ss,pfull,ppred)
  effectlist[x,]$ratio <- sum(pss$wts*pss$pfull) / sum(pss$wts*pss$ppred)
  }
effectlist
xteffectsIO <- xtable(effectlist,digits=3)
print.xtable(xteffectsIO,type="html",file="Tab2_IOeffects.html")

#### Table of values
a <- tapply(dat$wts,dat$tagger,sum);rbind(c("tagger",sum(a)),cbind(names(a),formatC(100*a/sum(a),digits=2,format="f")))
a <- tapply(dat$wts,dat$tag_type,sum);rbind(c("tag_type",sum(a)),cbind(names(a),formatC(100*a/sum(a),digits=2,format="f")))
a <- tapply(dat$wts,dat$cradle2,sum);rbind(c("cradle2",sum(a,na.rm=T)),cbind(names(a),formatC(100*a/sum(a,na.rm=T),digits=2,format="f")))
a <- tapply(dat$wts,dat$Cond,sum);rbind(c("Cond",sum(a,na.rm=T)),cbind(names(a),formatC(100*a/sum(a,na.rm=T),digits=2,format="f")))
a <- tapply(dat$wts,dat$Qual,sum);rbind(c("Qual",sum(a)),cbind(names(a),formatC(100*a/sum(a,na.rm=T),digits=2,format="f")))
a <- tapply(dat$wts,dat$OTC,sum);rbind(c("OTC",sum(a)),cbind(names(a),formatC(100*a/sum(a),digits=2,format="f")))

a <- tapply(dat$wts,dat$tagger,sum,na.rm=T)
names(a) <- seq(0,(length(a)-1),1)
barplot(a/sum(a),xlab="Tagger",ylab="Relative frequency", main="IO-RTTP")
savePlot("IO_Tagger_frequency_distribution",type="png")
savePlot("Figure_2_IO_Tagger_frequency_distribution",type="pdf")


library(rstan)
library(tidyverse)
library(lubridate)

load('cleanedData.RData')
dat$Site[dat$Site=='NA'] <- NA

dat <- dat%>%group_by(StudyId)%>%mutate(Site=ifelse(any(!is.na(Site)), Site[!is.na(Site)][1],NA))%>%ungroup()

dat <- dat%>%filter(!is.na(anxlevel)|!is.na(anyHard)|!is.na(cig3c)|!is.na(alcCat)|!is.na(cd4)|!is.na(Dep_total_G)|
                      !is.na(qol1_5_total),
  !is.na(Site),
  !is.na(Date))%>%
  group_by(StudyId)%>%mutate(ntimes=n())%>%filter(ntimes>1)%>%
arrange(Date)%>%
mutate(time=as.numeric(Date-min(Date))/100)%>%
  ungroup()%>%
  mutate(id=as.numeric(as.factor(StudyId)),
    dep=ifelse(Dep_total_G<3,Dep_total_G,3),
    qol=ifelse(qol1_5_total>10,qol1_5_total-10,1),
    anx=anxlevel,
    hard=anyHard,
    alc=alcCat,cig=cig3c)

## subject-level covariates

dat$race <- as.factor(dat$Race_R)

covDat <- dat%>%
  dplyr::select(id,age,gender,race,Hispanic_R,Site,ntimes)%>%
  filter(!is.na(Site))%>%
  group_by(id)%>%
  summarize_all(function(x) if(any(!is.na(x))) x[!is.na(x)][1] else NA)

## fill in missing values by assumption
covDat$race[is.na(covDat$race)] <- 1

covDat$Hispanic_R[is.na(covDat$Hispanic_R)] <- 2
covDat$hisp <- ifelse(covDat$Hispanic_R==1,1,0)

covDat$gender[is.na(covDat$gender)] <- 1

covDat$age[is.na(covDat$age)] <- mean(covDat$age,na.rm=TRUE)

X <- model.matrix(~age+gender+race+hisp+Site+ntimes,covDat)

stanDat <- list(
  p=ncol(X)-1,
  Npat=max(dat$id),
  X=scale(X[,-1])
)

capitalize <- function(x) paste0(toupper(substr(x,1,1)),tolower(substr(x,2,nchar(x))))

for(yy in c('anx','hard','alc','dep','cig','qol','cd4')){
  print(yy)
  ddd <- dat[!is.na(dat[[yy]]),]
  stanDat[[paste0('N',yy)]] <- nrow(ddd)
  stanDat[[paste0('pat',capitalize(yy))]] <- ddd$id
  stanDat[[paste0('time',capitalize(yy))]] <- ddd$time
  stanDat[[yy]] <- ddd[[yy]]
}

#mod <- stan('corMod.stan',data=stanDat,iter=100)

mod2 <- stan('corMod.stan',data=stanDat,iter=5000,cores=4,pars=c('psych','sub','alphaCd4','gammaCd4','alphaQol','gammaQol','trendCig','trendAlc','trendHard','subTot'), include=FALSE,thin=5)

save(mod2,file='corMod.RData')
## cd4Dat <- filter(dat,!is.na(cd4))%>%arrange(id)

## cd4Dat$cd4 <- scale(cd4Dat$cd4)

## begin <- vapply(unique(cd4Dat$id),function(id) which(cd4Dat$id==id)[1],1)

## nobs <- cd4Dat%>%group_by(id)%>%summarize(nobs=n())

## gpDat <- with(as.data.frame(cd4Dat),
##   list(
##     Npat=length(unique(id)),
##     N=nrow(cd4Dat),
##     Nobs=nobs$nobs,
##     begin=begin,
##     time=time,
##     cd4=cd4))
## gpDat$cd4 <- cd4Dat$cd4[,1]

## gp <- stan('cd4gp.stan')

## datAnx <- filter(dat,!is.na(anxlevel))
## datSub <- filter(dat,!is.na(anyHard))

## stanDat <- list(
##   Nanx=nrow(datAnx),
##   Nsubj=max(dat$id),
##   subjAnx=datAnx$id,
##   timeAnx=datAnx$time,
##   anx=datAnx$anxlevel,
##   Nsub=nrow(datSub),
##   subjSub=datSub$id,
##   timeSub=datSub$time,
##   sub=datSub$anyHard
##   )

## stanDat$X <- scale(X[,-1])

## stanDat$p <- ncol(X)-1

## mod <- stan('anxSub.stan',data=stanDat,chains=4,iter=1000,cores=10); save(mod,file='anxSub.RData')


#####################################
# Uses a genotype file and outputs PCs and PC plots
#
# Arguments: [1] id (i.e. wheat_599_CIMMYT)
#
# Plots include: - Percent of variance explained by the PCs
#                - Plots of PCs: PC vs PC (PC 1-5)
#                - Plot the G matrix diagonals (related to population structure)
#
# Written by: Christina Azodi
# Original: 4.24.17
# Modified by：Peipei Wang, 02/25/2021, to save the top 5 PCs as a matrix
# Modified by：Peipei Wang, 05/18/2021, to use fread to deal with large file
#####################################

# Removes all existing variables from the workspace
rm(list=ls())

# Compute PCs for descriptive stats and for later use in modeling
args = commandArgs(TRUE)

library(data.table)

# Input data
X_file <- args[1] # your genetic matrix, e.g., geno.csv
Y_file <- args[2] # your phenotypic matrix, e.g., pheno.csv

X <- as.matrix(fread(X_file),rownames=1)
Y <- read.csv(Y_file, row.names=1)

# Create output folder if not already present

#source('../parameters/parameters.r')
# get rid of markers with no variation among individuals
X_tem <- c()
col_names <- c()
for(i in 1:ncol(X)){
	if(length(unique(X[,i:i])) > 1){
		X_tem <- cbind(X_tem,as.matrix(X[,i:i]))
		col_names <- c(col_names,colnames(X)[i])
		}
	else{
		print(i)
		}
	if(i%%1000 == 0){
		print(i)
		}
	}
rownames(X_tem) <- rownames(X)
colnames(X_tem) <- col_names
X = X_tem

#### Calculate the G matrix
X=scale(X) # Centers (subtract the column means) and Scales (dividing the centered columns by their stdev)
G=tcrossprod(X) # Take the cross product X transpose
G=G/mean(diag(G))

#### Calculate eigenvalues
EVD=eigen(G)
rownames(EVD$vectors)=rownames(G)
save(EVD,file='EVD.RData')
write.csv(EVD$vectors,"PCA_matrix.csv",row.names=T,quote=F)
write.csv(EVD$vectors[,1:5],"PCA5_geno.csv",row.names=T,quote=F)
#### Plot proportion of variance explained ####
pdf('VarExplained.pdf')
var_exp <- (EVD$values)/nrow(X)
cum_exp <- list(var_exp[1])

for(i in 2:length(var_exp)){
  cum_exp[[i]] <- as.numeric(cum_exp[i-1]) + as.numeric(var_exp[i])
}

plot(1:nrow(X), cum_exp, xlab='# PCs', ylab='% Variance Explained')
abline(h= c(0.5, 0.9), col='blue')

dev.off()

#### Plot the G matrix diagonals ####
pdf('diag.pdf')
hist(diag(G), xlab = 'Diagonal Element (G-Matrix)',breaks=20)
dev.off()

#### Plots the PCs ####
pdf('PCs.pdf')

par(mfrow=c(3,4))
for(i in 1:4){
  for(j in (i+1):5){
    plot(x=EVD$vectors[,i],y=EVD$vectors[,j],
         main=paste0('PC-',i,' Vs. PC-',j),
         xlab=paste0('PC-',i),
         ylab=paste0('PC-',j),
         cex=.1 #,col=as.integer(factor(SUBJECTS$line))
    )
    #print(c(i,j))
  }
}
dev.off()

#### Export % X variance and Yi variance explained by the top 5 PCs ####

XY_var_exp <- cbind('X', sum(var_exp[0:5]))

for(i in 1:length(Y)){
  y=Y[, names(Y)[i]]
  fm = lm(y~EVD$vectors[,1:5])
  XY_var_exp <- rbind(XY_var_exp, cbind(names(Y)[i], summary(fm)$adj.r.squared))
}

write.table(XY_var_exp, 'VarExplained.csv', sep=',', row.names=FALSE, col.names=FALSE)

quit(save='no')


## for (file in list.files("../R", ".r$", full.names=T))
##     source(file)

library(dmrff)
library(parallel)

options(mc.cores=4)

source("functions.r")
source("bumphunter.r") ## just for the data simulation

## generate datasets
set.seed(20180220)
n.datasets <- 10
n.sites <- 1000
n.samples <- 100
manifest <- generate.manifest(n.sites)
datasets <- lapply(1:n.datasets, function(i) {
    dataset <- generate.dataset(n.samples, manifest)
    var <- generate.true.dmr.var(dataset$methylation, manifest$chr, manifest$pos,
                                 cluster.sites=20, dmr.sites=10, cluster.position=0.5,
                                 r=0.5, maxgap=500, cluster.number=1)
    dataset$data$variable <- var$var
    dataset
})

## run EWAS and create meta-analysis objects for each
for (i in 1:length(datasets)) {
    datasets[[i]]$ewas <- with(datasets[[i]], {
        ewas(methylation, data, "variable")
    })
    datasets[[i]]$pre <- with(datasets[[i]], {
        dmrff.pre(estimate=ewas$estimate, se=ewas$se,
                  methylation=methylation, chr=manifest$chr, pos=manifest$pos)
    })
}

## identify DMRs (there should be one)
ret <- dmrff.meta(lapply(datasets, function(dataset) dataset$pre),
                  maxgap=500, p.cutoff=0.05, verbose=T)
ret$dmrs[which(ret$dmrs$p.adjust < 0.05), ]
## > ret$dmrs[which(ret$dmrs$p.adjust < 0.05), ]
##   chr start  end n start.idx end.idx start.orig end.orig   z.orig       p.orig
## 1   1  6485 6627 2        31      32         28       38 4.652635 3.277197e-06
## 2   1  6452 6452 1        30      30         28       38 4.652635 3.277197e-06
## 3   1  6280 6280 1        29      29         28       38 4.652635 3.277197e-06
## 5   1  6683 7044 3        34      36         28       38 4.652635 3.277197e-06
## 6   1  6630 6630 1        33      33         28       38 4.652635 3.277197e-06
## 7   1  7133 7602 2        37      38         28       38 4.652635 3.277197e-06
##           z      p.value     p.adjust
## 1 11.159733 6.418373e-29 7.432475e-26
## 2  9.292509 1.506934e-20 1.745029e-17
## 3  6.173627 6.674092e-10 7.728598e-07
## 5 10.323678 5.507193e-25 6.377329e-22
## 6 10.295473 7.385555e-25 8.552473e-22
## 7  4.862225 1.160736e-06 1.344133e-03

ret$ewas$p.adjust <- p.adjust(ret$ewas$p.value, "bonferroni")
ret$ewas[with(ret$ewas, min(which(p.adjust < 0.05)):max(which(p.adjust < 0.05))),]
##       estimate           se         z      p.value chr  pos     p.adjust
## 29 0.004265129 0.0006742131  6.326085 2.514591e-10   1 6280 2.514591e-07
## 30 0.006215383 0.0006527400  9.521988 1.698969e-21   1 6452 1.698969e-18
## 31 0.005596188 0.0005731201  9.764424 1.600180e-22   1 6485 1.600180e-19
## 32 0.006125614 0.0006093820 10.052175 8.986206e-24   1 6627 8.986206e-21
## 33 0.005464965 0.0005180199 10.549721 5.094832e-26   1 6630 5.094832e-23
## 34 0.003130973 0.0003476549  9.005979 2.137506e-19   1 6683 2.137506e-16
## 35 0.003438597 0.0005115889  6.721408 1.799771e-11   1 6991 1.799771e-08
## 36 0.003072825 0.0004192734  7.328930 2.319973e-13   1 7044 2.319973e-10

########################### check meta-analysis
########################### by calculating everything 'by hand'

## meta-analyse EWAS statistics
library(metafor)
ewas.ma.stats <- do.call(rbind, mclapply(1:n.sites, function(i) {
    tryCatch({
        fit <- rma.uni(yi=sapply(datasets, function(dataset) dataset$pre$estimate[i]),
                       sei=sapply(datasets, function(dataset) dataset$pre$se[i]),
                       method="FE")
        c(estimate=unname(fit$b["intrcpt",1]),
          se=fit$se,
          z=fit$zval,
          p.value=fit$pval)
    }, error=function(e) {
        c(estimate=0,se=1,z=0,p.value=1)
    })
}))
ewas.ma.stats <- as.data.frame(ewas.ma.stats)

## identify candidate regions from meta-analyzed statistics
candidates <- dmrff.candidates(ewas.ma.stats$estimate, ewas.ma.stats$p.value,
                               manifest$chr, manifest$pos)
## generate all candidate sub-regions
candidates <- do.call(rbind, lapply(1:nrow(candidates), function(i) {
    idx <- candidates$start.idx[i]:candidates$end.idx[i]
    candidates <- cbind(start.idx=idx, end.idx=idx)
    if (length(idx) > 1)
        candidates <- rbind(candidates, t(combn(idx, 2)))
    candidates
}))
candidates <- data.frame(chr=manifest$chr[candidates[,"start.idx"]],
                         start=manifest$pos[candidates[,"start.idx"]],
                         end=manifest$pos[candidates[,"end.idx"]])

## calculate DMR stats for each candidate region in each dataset
dmr.stats <- lapply(datasets, function(dataset)
                    dmrff.stats(candidates, dataset$pre$estimate, dataset$pre$se,
                                dataset$methylation, manifest$chr, manifest$pos))

## meta-analyse candidate region statistics
dmr.ma.stats <- do.call(rbind, lapply(1:nrow(candidates), function(i) {
    fit <- rma.uni(yi=sapply(dmr.stats, function(stats)stats$estimate[i]),
                   sei=sapply(dmr.stats, function(stats) stats$se[i]),
                   method="FE")
    c(estimate=unname(fit$b["intrcpt",1]),
      se=fit$se,
      z=fit$zval,
      p.value=fit$pval)
}))
dmr.ma.stats <- cbind(candidates, dmr.ma.stats)
dmr.ma.stats$p.adjust <- p.adjust(dmr.ma.stats$p.value, "bonferroni")

## cover all candidate regions with the 'most significant' sub-regions
dmr.ma.stats <- dmr.ma.stats[order(dmr.ma.stats$p.value),]
rownames(dmr.ma.stats) <- 1:nrow(dmr.ma.stats)
dmr.ma.stats$best <- T
for (i in 1:nrow(dmr.ma.stats)) {
    if (dmr.ma.stats$best[i]) {
        idx <- with(dmr.ma.stats,
                    which(chr == chr[i]
                          & (start[i] <= start & start <= end[i]
                             | start[i] <= start & end <= end[i]
                             | start <= start[i] & start[i] <= end
                             | start <= end[i] & end[i] <= end)))
        idx <- idx[which(idx > i)]
        if (length(idx) > 0)
            dmr.ma.stats$best[idx] <- F
    }
}

## the same dmrs should be identified by both methods
x <- dmr.ma.stats[which(dmr.ma.stats$best & dmr.ma.stats$p.adjust < 0.05),
             c("chr","start","end","z")]
y <- ret$dmrs[which(ret$dmrs$p.adjust < 0.05),
               c("chr","start","end","z")]
stopifnot(all(sort(apply(x, 1, paste)) == sort(apply(y, 1, paste))))

## z-scores for the same regions should be identical
dmr.ma.stats <- dmr.ma.stats[match(with(ret$dmrs, paste(chr, start, end)),
                                   with(dmr.ma.stats, paste(chr, start, end))),]
stopifnot(diff(range(dmr.ma.stats$z - ret$dmrs$z)) < 1e-14)

###################################################
## test dmrff.cohort

dmrs1 <- with(datasets[[1]], dmrff(estimate=ewas$estimate,
                                   se=ewas$se,
                                   p.value=ewas$p.value,
                                   methylation=methylation,
                                   chr=pre$chr,
                                   pos=pre$pos))

dmrs2 <- dmrff.cohort(datasets[[1]]$pre)

## the exact set of candidates may not be exactly the same
## because p-values were calculated from estimate/se in 'pre'
dmrs1$id <- with(dmrs1, paste(chr, start, end))
dmrs2$id <- with(dmrs2, paste(chr, start, end))
common.candidates <- intersect(dmrs1$id, dmrs2$id)
length(common.candidates) ## 51
nrow(dmrs1) ## 51
nrow(dmrs2) ## 52
dmrs1 <- dmrs1[match(common.candidates, dmrs1$id),]
dmrs2 <- dmrs2[match(common.candidates, dmrs2$id),]
stopifnot(cor(dmrs1$estimate, dmrs2$estimate) >= 0.99)
stopifnot(cor(dmrs1$se, dmrs2$se) >= 0.99)
stopifnot(all((dmrs1$p.adjust < 0.05) == (dmrs2$p.adjust < 0.05)))


library(parallel)
library(caret)
library(MASS)
library(xgboost)

library(OptimalCutpoints)
library(pROC)
library(ROCR)

library(ggplot2)
library(cowplot)
library(gridExtra)
library(viridis)
library(gplots)

setwd("/media/yuri/Data/home1/GNI_data/infection/ModelsSciRep")
load('COVID_WGCNA_XGB.Rdat')
XGB_model_bst <- xgb.load('COVID_WGCNA_XGB.model')

# create xgb.DMatrix
dtrain0 <- xgb.DMatrix(data = as.matrix(trn_x[,-1]), label = trn_y)
dvalid  <- xgb.DMatrix(data = as.matrix(val_x[,-1]), label = val_y)

# predict discovery and validation cohorts (probs)
Ytrain_prob <- predict(XGB_model_bst, dtrain0, ntree = XGB_model_ntree, outputmargin=TRUE)
Yvalid_prob <- predict(XGB_model_bst, dvalid,  ntree = XGB_model_ntree, outputmargin=TRUE)

################################################################################
# Find optimal cutpoint from the ROC curve maximizing the product of Sensitivity and Specificity
p_cut <- optimal.cutpoints(y~x, status=trn_y, tag.healthy = 0, data= data.frame(y=Ytrain_prob, x = trn_y),
methods="MaxProdSpSe", ci.fit=TRUE, control = control.cutpoints(ci.SeSp = "AgrestiCoull", ci.PV = "AgrestiCoull") )
cutoff <- p_cut$MaxProdSpSe$Global$optimal.cutoff$cutoff[1]

# predict discovery and validation cohorts (classes)
p_train_class  <- factor(as.numeric(ifelse(Ytrain_prob <= cutoff, 0, 1)), levels = c(0,1))
p_valid_class  <- factor(as.numeric(ifelse(Yvalid_prob  <= cutoff, 0, 1)), levels = c(0,1))

# Model summary bACC - balanced accuracy, Sensitivity, Specificity
conf_train  <- confusionMatrix(p_train_class, factor(trn_y), "1")
conf_valid  <- confusionMatrix(p_valid_class, factor(val_y), "1")

conf_table <- data.frame( bACC = c( conf_train$byClass[[11]], conf_valid$byClass[[11]] ),
Sensitivity = c( conf_train$byClass[[1]], conf_valid$byClass[[1]] ),
Specificity = c( conf_train$byClass[[2]], conf_valid$byClass[[2]] )
)
conf_table <- t(conf_table)
colnames(conf_table) <- c("discovery", "validation")
conf_table <- round(conf_table, 3)

################################################################################
# Variable importance
var_imp <- xgb.importance(dimnames(dtrain0)[[2]], model = XGB_model_bst)
# var_imp <- var_imp[ order(as.numeric(gsub("x", "", var_imp$Feature))),]
# var_imp$Feature <- ids[as.numeric(gsub("x", "", var_imp$Feature))]
var_imp <- var_imp[order(var_imp$Gain, decreasing=F),]
var_imp <- as.data.frame(var_imp)
rownames(var_imp) <- gsub("ME", "", var_imp[,1])
var_imp <- var_imp[,-1]

colors <- rownames(var_imp)
colors[colors == "age"] <- "black"

################################################################################
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures/")
pdf("FigureS12C.pdf", width=4, height=9)

k <- which(colors == "grey")+1
m <- length(colors)
par(mar=c(4,16,1,0.5))
barplot(var_imp[k:m,1], horiz = T, names.arg = rownames(var_imp)[k:m], col = col2hex(colors)[k:m],
      xlab = "Gain", main = "variable importance",las=1, cex.axis=0.7, cex.names = 0.7)

dev.off()
################################################################################

Train_roc <- roc(trn_y, Ytrain_prob)
Train_auc <- lapply(pROC::ci(trn_y, Ytrain_prob), function(x) round(x, 3))

Valid_roc <- roc(val_y, Yvalid_prob)
Valid_auc <- lapply(pROC::ci(val_y, Yvalid_prob), function(x) round(x, 3))

All_roc <- roc(c(trn_y, val_y), c(Ytrain_prob, Yvalid_prob))
All_auc <- lapply(pROC::ci(c(trn_y, val_y), c(Ytrain_prob, Yvalid_prob)), function(x) round(x, 3))

pdf("FigureS12B.pdf", width=6, height=6)

plot(Train_roc, lty = 1, lwd = 2, col=4, type="s")
plot(Valid_roc, add=TRUE, lty = 1, lwd = 2, col=2, type="s")
plot(All_roc, add=TRUE, lty = 1, lwd = 2, col=1, type="s")
legend("bottomright", legend =
  c(paste("discovery cohort: AUC = ", Train_auc[[2]], " (", Train_auc[[1]], ", ", Train_auc[[3]], ")", sep=""),
    paste("validation cohort: AUC = ", Valid_auc[[2]], " (", Valid_auc[[1]], ", ", Valid_auc[[3]], ")", sep=""),
    paste("all cohort: AUC = ", All_auc[[2]], " (", All_auc[[1]], ", ", All_auc[[3]], ")", sep="")),
lty=1, lwd=2, col=c(2,4,1), bty="n")

dev.off()
################################################################################
# enrichment

setwd("/media/yuri/Data/home1/GNI_data/infection/DataSciRep/")
load("org.Hs.core_paths.Rdat")

names(kegg_path) <- paste0("kegg:", names(kegg_path))
names(corum_core) <- paste0("complex:", names(corum_core))
corum_core$`complex:mitochondrial respiratory chain complex I assembly` <- NULL
core_paths <- c(corum_core, kegg_path)

topME <- rev(colors)
topME <- topME[topME!="black"]

# For explanetion of gene set enrichment see
# http://pedagogix-tagc.univ-mrs.fr/courses/ASG1/practicals/go_statistics_td/go_statistics_td_2015.html
N <- length(unlist(core_paths)[!duplicated(unlist(core_paths))])
m <- sapply(core_paths, length)
n <- N-m

topME_ens <- lapply(topME, function(module) {

  k <- sum(GeneNames[dynamicColors %in% module] %in% unlist(core_paths)[!duplicated(unlist(core_paths))])
  x <- sapply(core_paths, function(x) sum(x %in% GeneNames[dynamicColors %in% module]) )

  sig <- phyper(q = x -1, m=m, n=n, k=k, lower.tail=FALSE)
  sig <- p.adjust(sig, "fdr")
  res <- sig[sig < 1e-03]

  if(length(res) > 0) {
    res <- data.frame(module = module, ensemble = names(res), fdr = -log10(res))
    res <- res[order(res$fdr, decreasing = T),]
    rownames(res) <- NULL
  } else {res <- NULL}

  res

})

topME_ens <- do.call(rbind, topME_ens)
topME_ens <- topME_ens[!duplicated(topME_ens$ensemble),]
topME_ens <- topME_ens[nrow(topME_ens):1,]
topME_ens$fdr[topME_ens$fdr > -log10(1e-10)] <- -log10(1e-10)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures/")
pdf("FigureS12D.pdf", width=4, height=9)
  k <- 26 # max(which(topME_ens[,'module'] == "grey"))+1
  m <- length(topME_ens[,'module'])
  par(mar=c(4,16,1,0.5))
  barplot(topME_ens[k:m,'fdr'], horiz = T, names.arg = topME_ens[k:m,'ensemble'], col = col2hex(topME_ens[k:m,'module']),
        xlab = "-log10(fdr)", main = "WGCNA enrichment (fdr < 0.01)",las=1, cex.axis=0.7, cex.names = 0.7)

dev.off()

################################################################################

trn_res <- data.frame(trueY = trn_y, Yhat = p_train_class, Yp = Ytrain_prob,
  Acc = as.numeric(trn_y == p_train_class), hfd = COVID_pheno$HFD45[train_idx],
  cohort = "discovery")
val_res <- data.frame(trueY = val_y, Yhat = p_valid_class, Yp = Yvalid_prob,
  Acc = as.numeric(val_y == p_valid_class), hfd = COVID_pheno$HFD45[test_idx],
  cohort = "validation")

plot_res <- rbind(trn_res, val_res)
plot_res$shape <- paste0(plot_res$cohort, plot_res$Acc)

p1 <- ggplot(plot_res, aes(y=Yp, x = as.factor(trueY) )) + geom_boxplot(aes(color = as.factor(trueY)), outlier.size=-1) +
geom_hline(yintercept=cutoff) +
geom_jitter(aes(color = as.factor(trueY), shape = shape), size=3, width = 0.1) +
scale_shape_manual(values = c(3,2,4,17)) +
scale_color_manual(values = c("#4591cc", "#21a883")) +
xlab("") + ylab("model score") +
theme_bw() +
theme(text = element_text(size=12),
        axis.text.y = element_text(size=12))

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures/")
ggsave("FigureS12Aright.pdf", p1, width=4, height=6)


#' norm
#'
#' Implementation of R's \code{norm()} function for shaq objects.
#'
#' @details
#' If \code{type == "O"} then the norm is calculated as the maximum of the
#' column sums.
#'
#' If \code{type == "I"} then the norm is calculated as the maximum absolute
#' value of the row sums.
#'
#' If \code{type == "F"} then the norm is calculated as the square root of the
#' sum of the square of the values of the matrix.
#'
#' If \code{type == "M"} then the norm is calculated as the max of the absolute
#' value of the values of the matrix.
#'
#' If \code{type == "2"} then the norm is calculated as the largest singular
#' value.
#'
#' @section Communication:
#' If \code{type == "O"} then the communication consists of an allreduce,
#' quadratic on the number of columns.
#'
#' If \code{type == "I"} then the communication conists of an allgather.
#'
#' If \code{type == "F"} then the communication is an allreduce, quadratic on
#' the number of columns.
#'
#' If \code{type == "M"} then the communication consists of an allgather.
#'
#' If \code{type == "2"} then the communication consists of the same as that of
#' an \code{svd()} call:  an allreduce, quadratic on the number of columns.
#'
#' @param x
#' A shaq
#' @param type
#' The type of norm: one, infinity, frobenius, max-modulus, and spectral.
#'
#' @return
#' A number (length 1 regular vector).
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' nm = norm(x)
#' comm.print(nm)
#'
#' finalize()
#' }
#'
#' @name norm
#' @rdname norm
NULL

norm.shaq = function(x, type = c("O", "I", "F", "M", "2"))
{
  type = toupper(type)

  if (type %in% c("O", "1"))
  {
    cs_abs = base::colSums(abs(DATA(x)))
    max(MPI_Allreduce(cs_abs))
  }
  else if (type == "I")
    comm.max(norm(DATA(x), type="I"))
  else if (type == "F")
  {
    tmp = norm(DATA(x), type="F")
    sqrt(MPI_Allreduce(tmp*tmp))
  }
  else if (type == "M")
    comm.max(max(abs(DATA(x))))
  else if (type == "2")
    svd(x, 0, 0)$d[1L]
  else
    comm.stop("")
}

#' @rdname norm
#' @export
setMethod("norm", signature(x="shaq"), norm.shaq)


# Supporting function for the analysis of the data from the Fear Generalization Task (FGT) in the SAM study
# Written by Milou Sep

FGT_LMER_Trialtype.Trial.Condition <- function(dataset){

  # Note, the Bobyaqa optimizer method was used for better model convergence (Note, this optimizer was also used for MCT analyses (https://github.com/mscsep/SAM_MCT).
  # Info on LMER convergence problems: https://rstudio-pubs-static.s3.amazonaws.com/33653_57fc7b8e5d484c909b615d8633c01d51.html
  # Info on optimizer checks http://svmiller.com/blog/2018/06/mixed-effects-models-optimizer-checks/
  # ?allFit() # Note: allFit() function doesn't work with Mids objects.

  FullModel <-with(expr=lmer(FPS~1+Condition*trialtype*trial+(1|pp),control=lmerControl(optimizer="bobyqa") ),data = dataset, REML=F)

  Full_NO_3way<-with(expr=lmer(FPS~1+Condition+trialtype+trial+ # Main effects
                                 Condition:trialtype+Condition:trial+trialtype:trial+ # 2 way interaction effects
                                 (1|pp) ,control=lmerControl(optimizer="bobyqa")),data = dataset,REML=F)  # Random effects term

  ### 2 Way interactions [compared to Full Model without 3Way] ###
  # Define Models
  Full_NO_Condition.trial<-with(expr=lmer(FPS~1+Condition+trialtype+trial+
                                            Condition:trialtype+trialtype:trial+
                                            (1|pp) ,control=lmerControl(optimizer="bobyqa") ),data = dataset, REML=F)

  Full_NO_trial.trialtype<-with(expr=lmer(FPS~1+Condition+trialtype+trial+
                                            Condition:trialtype+Condition:trial+
                                            (1|pp) ,control=lmerControl(optimizer="bobyqa") ),data = dataset, REML=F)

  Full_NO_Condition.trialtype<-with(expr=lmer(FPS~1+Condition+trialtype+trial+
                                                Condition:trial+trialtype:trial+
                                                (1|pp),control=lmerControl(optimizer="bobyqa") ),data = dataset, REML=F)

  # 3 way interaction
  Condition.trial.trialtype <-  pool.compare(FullModel,Full_NO_3way, method='wald') # To test if there is a 3way interaction, and the Log-Likelihood (and df) of the full model  # pool.compare(main, base, method='wald')

  # 2 way interactions
  Condition.trial <- pool.compare(Full_NO_3way,Full_NO_Condition.trial, method='wald')
  trial.trialtype <- pool.compare(Full_NO_3way,Full_NO_trial.trialtype, method='wald')
  Condition.trialtype <-  pool.compare(FullModel, Full_NO_Condition.trialtype, method='wald')

  ### Main effects ###
  # Define Models
  Main_NO_2ways<-with(expr=lmer(FPS~1+Condition+trialtype+trial+(1|pp)  ,control=lmerControl(optimizer="bobyqa")),data = dataset, REML=F)
  Main_Condition<-with(expr=lmer(FPS~1+trial+trialtype+(1|pp) ,control=lmerControl(optimizer="bobyqa") ),data = dataset, REML=F)
  Main_trial<-with(expr=lmer(FPS~1+Condition+trialtype+(1|pp) ,control=lmerControl(optimizer="bobyqa") ),data = dataset, REML=F)
  Main_trialtype<-with(expr=lmer(FPS~1+Condition+trial+(1|pp) ,control=lmerControl(optimizer="bobyqa") ),data = dataset, REML=F)

  # Compare Models
  Condition <- pool.compare(Main_NO_2ways,Main_Condition, method='wald')
  trial <- pool.compare(Main_NO_2ways,Main_trial, method='wald')
  trialtype <- pool.compare(Main_NO_2ways,Main_trialtype, method='wald')

  # Table of model comparisons (for publication) --------------------------------
  # Outcomes of pool.compare() (RG: export " Dm		rm		df1	df2		p " to table)
  #?pool.compare

  # Make vectors for data in each row
  threeway.C.T.T <- c("Condition x Trial x Trialtype", Condition.trial.trialtype$Dm, Condition.trial.trialtype$rm, Condition.trial.trialtype$df1, Condition.trial.trialtype$df2, Condition.trial.trialtype$pvalue)

  twoway.C.T <- c("Condition x Trial", Condition.trial$Dm, Condition.trial$rm, Condition.trial$df1, Condition.trial$df2, Condition.trial$pvalue)
  twoway.C.Tt <- c("Condition x Trialtype", Condition.trialtype$Dm, Condition.trialtype$rm, Condition.trialtype$df1, Condition.trialtype$df2, Condition.trialtype$pvalue)
  twoway.T.Tt <- c("Trial x Trialtype", trial.trialtype$Dm, trial.trialtype$rm, trial.trialtype$df1, trial.trialtype$df2, trial.trialtype$pvalue)

  Main.effect.Condition <- c("Condition", Condition$Dm, Condition$rm, Condition$df1, Condition$df2, Condition$pvalue)
  Main.effect.trialtype <- c("Trialtype", trialtype$Dm, trialtype$rm, trialtype$df1, trialtype$df2,  trialtype$pvalue)
  Main.effect.trial <- c("Trial", trial$Dm, trial$rm, trial$df1, trial$df2,  trial$pvalue)

  WORD.table.FGT <- data.frame(rbind(threeway.C.T.T ,
                                     twoway.C.T, twoway.C.Tt , twoway.T.Tt,
                                     Main.effect.Condition, Main.effect.trialtype, Main.effect.trial))
  colnames(WORD.table.FGT) <- c("Model", "Dm", "rm", "df1", "df2", "pvalue")

  # Data cells need to be changed to numeric (not factor), otherwise problems with flextable().
  # str(WORD.table.FGT)
  WORD.table.FGT[c(2,3,4,5,6)] <- sapply(WORD.table.FGT[c(2,3,4,5,6)], as.character) # First convert to character ..
  WORD.table.FGT[c(2,3,4,5,6)] <- sapply(WORD.table.FGT[c(2,3,4,5,6)], as.numeric) # .. then to numeric
  # sapply(WORD.table.FGT, class) # check data class of table.

  # Return function output --------------------------------------------------

  return(WORD.table.FGT)

}


#!/usr/bin/env Rscript

# either run with:
# Rscript mkplots.r <input-file>
#		or
# ./mkplots.r <input-file>

# load necessary libs
library(gridExtra)
library(ggplot2)
library(dplyr, warn.conflicts = FALSE)

# get name of file containing test results
args = commandArgs(trailingOnly=TRUE)
if (length(args) == 0)
	stop("usage: mkplots.r <input-file>.n", call.=FALSE)

# the following file format is expected (generated by the "perf" sample program)
# test      size    container  runtime       min        max       avg        var       dev
# emplace   1000    tuple         2007   1.82600   14.64000   2.00717    1.09070   1.04436
# emplace   1000    vector        6828   4.50000   26.77800   6.82821    3.29125   1.81418
# emplace   1000    map          44323  38.04700  126.24600  44.32317  202.59203  14.23348
# array     1000    vector         952   0.93900    1.26500   0.95235    0.00011   0.01070
# array     1000    tuple         1038   0.91300   42.53400   1.03869    2.46011   1.56847
# array     1000    map          33040  30.48500   66.82500  33.04009   12.10746   3.47958
# iterator  1000    tuple          652   0.62400   11.25200   0.65237    0.22584   0.47522
# iterator  1000    vector         684   0.62500   15.32300   0.68472    0.23855   0.48842
# iterator  1000    map           5908   5.72200   16.55800   5.90823    0.99323   0.99661
#   ...

# read test results into table
data <- read.table(args[1], header=TRUE, sep="\t")
# create runtime, min, max, avg, var, dev plots for each test and nicely arrange them into a 3x2 grid
for (t in unique(data$test)) {
	cat("generating",t,"plot...","\n")
	d <- data %>% filter(test == t)
	p1 <- ggplot(d, aes(x=size, y=log(runtime), colour=container)) + geom_line() + ggtitle("runtime")
	p2 <- ggplot(d, aes(x=size, y=log(min), colour=container)) + geom_line() + ggtitle("minimum")
	p3 <- ggplot(d, aes(x=size, y=log(max), colour=container)) + geom_line() + ggtitle("maximum")
	p4 <- ggplot(d, aes(x=size, y=log(avg), colour=container)) + geom_line() + ggtitle("mean")
	p5 <- ggplot(d, aes(x=size, y=log(var), colour=container)) + geom_line() + ggtitle("variance")
	p6 <- ggplot(d, aes(x=size, y=log(dev), colour=container)) + geom_line() + ggtitle("std-dev")
	png(paste(t, ".png", sep=""), width = 1200, height = 600);
	grid.arrange(p1, p2, p3, p4, p5, p6, ncol = 3);
}


# 4. faza: Analiza podatkov
source("lib/libraries.r", encoding="UTF-8")

#Grafi za leto 2018
Tabela_skupna$Drzava <- factor(Tabela_skupna$Drzava,levels=Tabela_skupna %>% arrange(Placa) %>% .$Drzava,
                              ordered = TRUE)  #razvrsti države glede na višino plače

#graf_starost <- ggplot(Tabela_skupna %>% select(Drzava, Placa), aes(x=Drzava, y=Placa))+
#  geom_point()

#graf povprečne starosti v odvisnosti od višine povprečne plače

graf_starost <- ggplot(Tabela_skupna, aes(x = Placa, y = Povprecna.starost)) +
  geom_point() +
  geom_smooth(method = loess) + #, fill="blue", colour="darkblue") +  #priredi krivuljo, ki se najbolje prilega podatkom; če bi želeli spremenit barvo
  xlab("Višina plače") + ylab("Povprečna starost")

#graf življenskih stroškov v odvisnosti od povprečne plače

graf_stroski <- ggplot(Tabela_skupna, aes(x = Placa, y = Zivljenski.stroski)) +
  geom_point() +
  geom_smooth(method = loess) +
  xlab("Višina plače") + ylab("Indeks življenskih stroškov")

#graf stopnje kriminala v odvisnosti od povprečne plače

graf_osamosvojitev <- ggplot(Tabela_skupna, aes(x = Placa, y = Leto.osamosvojitve)) +
  geom_point() +
  geom_smooth(method = loess) +  #to tu ni možno ker so podatki preveč razpršeni
  xlab("Višina plače") + ylab("Leto osamosvojitve")

#graf vrednosti BDP posamezne države v odvisnosti od povprečne plače

graf_BDP <- ggplot(Tabela_skupna, aes(x = Placa, y = BDP)) +
  geom_point() +
  geom_smooth(method = loess) +
  xlab("Višina plače") + ylab("BDP")

#graf velikosti držav v odvisnosti od povprečne plače

graf_povrsina <- ggplot(Tabela_skupna, aes(x = Placa, y = Povrsina)) +
  geom_point() +
  geom_smooth(method = loess) +
  xlab("Višina plače") + ylab("Površina v km^2")

#graf obdavčitve v odvisnosti od povprečne plače

graf_davki <- ggplot(Tabela_skupna, aes(x = Placa, y = Davki)) +
  geom_point() +
  geom_smooth(method = loess) +
  xlab("Višina plače") + ylab("Obdavčitev v %")

graf_kriminal <- ggplot(Tabela_skupna, aes(x = Placa, y = Stopnja.kriminala)) +
  geom_point() +
  geom_smooth(method = loess) +
  xlab("Višina plače") + ylab("Stopnja kriminala")


args = commandArgs(trailingOnly=TRUE)
if(length(args) == 0) {
  stop("Requires the input graph file path/name.")
}

if (!require('centiserve')) {
  print('centiserve package is required, currently missing.')
  print('install.packages("centiserve", repos="http://cran.rstudio.com")')
  stopifnot(require('centiserve'))
}
if (!require('igraph')) {
  print('IGRAPH package is required, currently missing.')
  print('install.packages("igraph")')
  stopifnot(require('igraph'))
}

library(igraph)
library(centiserve)

g <- read_graph(args[1])
result <- bottleneck(g)

print("#magic_code#")
print(result)
print("#magic_end#")


get_contrast_matrix_rows_as_list = function(
	data
	, formula
	, contrast_kind = NULL
){
	mm = get_contrast_matrix(data, formula, contrast_kind )
	mm_list = lapply(
		X = seq_len(nrow(mm))
		, FUN = function(i){
			array(
				mm[i,]
				, dim = c(1,ncol(mm))
				, dimnames = list(
					NULL
					, dimnames(mm)[[2]]
				)
			)
		}
	)
	return(mm_list)
}


unlink(".RData")
#REMOVE everything from the workspace
rm(list=ls(all=TRUE))
library("edgeR")

# =============================================
# Normalize gonad tissue
# =============================================
gonad_data <- read.csv("../count-extraction/2015-10-27-MF-GONAD-COUNTS-COMBINED.expr", header=T, row.names=1, stringsAsFactors=FALSE)
dim(gonad_data)
names(gonad_data)
# cor(data)
class(gonad_data[,1])
class(gonad_data[,2])
class(gonad_data[,3])
class(gonad_data[,4])
class(gonad_data[,5])
class(gonad_data[,6])
class(gonad_data[,7])
class(gonad_data[,8])
gonad_conditions <- factor(c("M","M","M","M","F","F","F","F"))
gonad_expr <- DGEList(counts=gonad_data, group=gonad_conditions)
#Default is TMM
# manual: The default method for computing these scale factors uses a
# trimmed mean of Mvalues (TMM) between each pair of samples [21]
gonad_expr <- calcNormFactors(gonad_expr)
# Calculate common and tagwise dispersion at the same time (recommended)
gonad_expr <- estimateDisp(gonad_expr)
# Print expression samples
gonad_expr$samples
# Compare Male - Female expression
# . Note
# that the first group listed in the pair is the baseline for the comparison—so if exactTest
# the pair is c("A","B") then the comparison is B - A, so genes with positive
# log-fold change are up-regulated in group B compared with group A (and vice
# versa for genes with negative log-fold change
gonad_de <- exactTest(gonad_expr, pair=c("M","F"))
#plotMDS(expr)
# Save all tags in this table. nrow(expr) makes sure that all genes are
# included. We need to select the $table, because topTags also contains other
# elements like comparison, test
gonad_detag_table <- topTags(gonad_de, n=nrow(gonad_expr))$table
write.table(gonad_detag_table, file="2015-10-27-MF-GONAD-detags-edgeR.csv",quote=F, sep=",")

# Export the cpm values for all genes
# prior.count=0.125 is the default for exactTest() and is needed here to make values comparable.
gonad_expr_norm <- cpm(gonad_expr, normalized.lib.sizes=TRUE, log=TRUE, prior.count=0.125)
write.table(gonad_expr_norm, file="2015-10-27-MF-GONAD-CPM-NORM-log2-edgeR.csv",quote=F, sep=",")

# RPKM calculation
# Gene length based on combined exonic length
#IMPORTANT: NEED TO REMOVE HEADER V1!
gene_length <- read.table("2015-10-29-Gallus_gallus.Galgal4.75.exonic.gene.length")
expressed_genes <- rownames(gonad_expr)
gene_length <- subset(gene_length, V1 %in% expressed_genes)
dim(gene_length)
# Reorder gene length vector to match order in expr object
gene_length_ordered <- gene_length[match(rownames(gonad_expr),gene_length$V1),]
# Check if reorder has worked ( should return TRUE)
all(gene_length_ordered$V1 == rownames(gonad_expr))
gonad_expr_norm_rpkm <- rpkm(gonad_expr, normalized.lib.sizes=TRUE, log=TRUE, prior.count=0.125, gene.length=gene_length_ordered$V2)
write.table(gonad_expr_norm_rpkm, file="2015-10-27-MF-GONAD-RPKM-NORM-log2-edgeR.csv",quote=F, sep=",")

# =============================================
# Normalize spleen tissue
# =============================================
spleen_data <- read.csv("../count-extraction/2015-10-27-MF-SPLEEN-COUNTS-COMBINED.expr", header=T, row.names=1, stringsAsFactors=FALSE)
dim(spleen_data)
names(spleen_data)
# cor(data)
class(spleen_data[,1])
class(spleen_data[,2])
class(spleen_data[,3])
class(spleen_data[,4])
class(spleen_data[,5])
class(spleen_data[,6])
class(spleen_data[,7])
class(spleen_data[,8])
spleen_conditions <- factor(c("M","M","M","M","F","F","F","F"))
spleen_expr <- DGEList(counts=spleen_data, group=spleen_conditions)
#Default is TMM
spleen_expr <- calcNormFactors(spleen_expr)
# Calculate common and tagwise dispersion at the same time (recommended)
spleen_expr <- estimateDisp(spleen_expr)
# Compare Male - Female expression
# Print expression samples
spleen_expr$samples
spleen_de <- exactTest(spleen_expr, pair=c("M","F"))
#plotMDS(expr)
# Save all tags in this table. nrow(expr) makes sure that all genes are
# included. We need to select the $table, because topTags also contains other
# elements like comparison, test
spleen_detag_table <- topTags(spleen_de, n=nrow(spleen_expr))$table
write.table(spleen_detag_table, file="2015-10-27-MF-SPLEEN-detags-edgeR.csv",quote=F, sep=",")

# Export the cpm values for all genes
# prior.count=0.125 is the default for exactTest() and is needed here to make values comparable.
spleen_expr_norm <- cpm(spleen_expr, normalized.lib.sizes=TRUE, log=TRUE, prior.count=0.125)
write.table(spleen_expr_norm, file="2015-10-27-MF-SPLEEN-CPM-NORM-log2-edgeR.csv",quote=F, sep=",")

# RPKM calculation
# Gene length based on combined exonic length
#IMPORTANT: NEED TO REMOVE HEADER V1!
gene_length <- read.table("2015-10-29-Gallus_gallus.Galgal4.75.exonic.gene.length")
expressed_genes <- rownames(spleen_expr)
gene_length <- subset(gene_length, V1 %in% expressed_genes)
dim(gene_length)
# Reorder gene length vector to match order in expr object
gene_length_ordered <- gene_length[match(rownames(spleen_expr),gene_length$V1),]
# Check if reorder has worked ( should return TRUE)
all(gene_length_ordered$V1 == rownames(spleen_expr))
spleen_expr_norm_rpkm <- rpkm(spleen_expr, normalized.lib.sizes=TRUE, log=TRUE, prior.count=0.125, gene.length=gene_length_ordered$V2)
write.table(spleen_expr_norm_rpkm, file="2015-10-27-MF-SPLEEN-RPKM-NORM-log2-edgeR.csv",quote=F, sep=",")

# =============================================
# Normalize heart tissue
# =============================================
heart_data <- read.csv("../count-extraction/2015-10-27-MF-HEART-COUNTS-COMBINED.expr", header=T, row.names=1, stringsAsFactors=FALSE)
dim(heart_data)
names(heart_data)
# cor(data)
class(heart_data[,1])
class(heart_data[,2])
class(heart_data[,3])
class(heart_data[,4])
class(heart_data[,5])
class(heart_data[,6])
class(heart_data[,7])
class(heart_data[,8])
heart_conditions <- factor(c("M","M","M","M","F","F","F","F"))
heart_expr <- DGEList(counts=heart_data, group=heart_conditions)
#Default is TMM
heart_expr <- calcNormFactors(heart_expr)
# Calculate common and tagwise dispersion at the same time (recommended)
heart_expr <- estimateDisp(heart_expr)
# Print expression samples
heart_expr$samples
# Compare Male - Female expression
# . Note
# that the first group listed in the pair is the baseline for the comparison—so if58 exactTest
# the pair is c("A","B") then the comparison is B - A, so genes with positive
# log-fold change are up-regulated in group B compared with group A (and vice
# versa for genes with negative log-fold change).
heart_de <- exactTest(heart_expr, pair=c("M","F"))
#plotMDS(expr)
# Save all tags in this table. nrow(expr) makes sure that all genes are
# included. We need to select the $table, because topTags also contains other
# elements like comparison, test
heart_detag_table <- topTags(heart_de, n=nrow(heart_expr))$table
write.table(heart_detag_table, file="2015-10-27-MF-HEART-detags-edgeR.csv",quote=F, sep=",")

# Export the cpm values for all genes
# prior.count=0.125 is the default for exactTest() and is needed here to make values comparable.
heart_expr_norm <- cpm(heart_expr, normalized.lib.sizes=TRUE, log=TRUE, prior.count=0.125)
write.table(heart_expr_norm, file="2015-10-27-MF-HEART-CPM-NORM-log2-edgeR.csv",quote=F, sep=",")

# RPKM calculation
# Gene length based on combined exonic length
#IMPORTANT: NEED TO REMOVE HEADER V1!
gene_length <- read.table("2015-10-29-Gallus_gallus.Galgal4.75.exonic.gene.length")
expressed_genes <- rownames(heart_expr)
gene_length <- subset(gene_length, V1 %in% expressed_genes)
dim(gene_length)
# Reorder gene length vector to match order in expr object
gene_length_ordered <- gene_length[match(rownames(heart_expr),gene_length$V1),]
# Check if reorder has worked ( should return TRUE)
all(gene_length_ordered$V1 == rownames(heart_expr))
heart_expr_norm_rpkm <- rpkm(heart_expr, normalized.lib.sizes=TRUE, log=TRUE, prior.count=0.125, gene.length=gene_length_ordered$V2)
write.table(heart_expr_norm_rpkm, file="2015-10-27-MF-HEART-RPKM-NORM-log2-edgeR.csv",quote=F, sep=",")
# =============================================
# Normalize liver tissue, excluded wonky female liver sample
# =============================================
liver_data <- read.csv("../count-extraction/2015-10-27-MF-LIVER-COUNTS-COMBINED.expr", header=T, row.names=1, stringsAsFactors=FALSE)
dim(liver_data)
names(liver_data)
# cor(data)
class(liver_data[,1])
class(liver_data[,2])
class(liver_data[,3])
class(liver_data[,4])
class(liver_data[,5])
class(liver_data[,6])
class(liver_data[,7])
liver_conditions <- factor(c("M","M","M","M","F","F","F"))
liver_expr <- DGEList(counts=liver_data, group=liver_conditions)
#Default is TMM
liver_expr <- calcNormFactors(liver_expr)
# Calculate common and tagwise dispersion at the same time (recommended)
liver_expr <- estimateDisp(liver_expr)
# Print expression samples
liver_expr$samples
# Compare Male - Female expression
liver_de <- exactTest(liver_expr, pair=c("M","F"))
#plotMDS(expr)
# Save all tags in this table. nrow(expr) makes sure that all genes are
# included. We need to select the $table, because topTags also contains other
# elements like comparison, test
liver_detag_table <- topTags(liver_de, n=nrow(liver_expr))$table
write.table(liver_detag_table, file="2015-10-27-MF-LIVER-detags-edgeR.csv",quote=F, sep=",")

# Export the cpm values for all genes
# prior.count=0.125 is the default for exactTest() and is needed here to make values comparable.
liver_expr_norm <- cpm(liver_expr, normalized.lib.sizes=TRUE, log=TRUE, prior.count=0.125)
write.table(liver_expr_norm, file="2015-10-27-MF-LIVER-CPM-NORM-log2-edgeR.csv",quote=F, sep=",")

# Gene length based on combined exonic length
#IMPORTANT: NEED TO REMOVE HEADER V1!
gene_length <- read.table("2015-10-29-Gallus_gallus.Galgal4.75.exonic.gene.length")
expressed_genes <- rownames(liver_expr)
gene_length <- subset(gene_length, V1 %in% expressed_genes)
dim(gene_length)
# Reorder gene length vector to match order in expr object
gene_length_ordered <- gene_length[match(rownames(liver_expr),gene_length$V1),]
class(gene_length_ordered$V2)
# Check if reorder has worked ( should return TRUE)
all(gene_length_ordered$V1 == rownames(liver_expr))
liver_expr_norm_rpkm <- rpkm(liver_expr, normalized.lib.sizes=TRUE, log=TRUE, prior.count=0.125, gene.length=gene_length_ordered$V2)
write.table(liver_expr_norm_rpkm, file="2015-10-27-MF-LIVER-RPKM-NORM-log2-edgeR.csv",quote=F, sep=",")


# Calculate area and fraction of each grid cell that is in a PA

library(sf)

# Read in gridded WDPA data
wdpagrid <- readRDS('temp/wdpa_by_grid0.05_intersect.rds'); gridsz <- 0.05
SPsf2 <- readRDS('temp/SPsf2.rds') # the analysis grid

# Calc fraction of each grid covered by any PA
	# Merge together wdpa pieces in the same grid cell
	out2 <- aggregate(x=wdpagrid[,'gridpolyID'], by=list(ID=wdpagrid$gridpolyID), FUN=unique, na.rm=TRUE) # do the merge by grid cell ID (=rowname in SP)

	# convert to equal-area projection
	out3 <- st_transform(out2, crs='+proj=aea +lat_1=20 +lat_2=60 +lat_0=40 +lon_0=-96 +x_0=0 +y_0=0 +ellps=GRS80 +datum=NAD83 +units=m +no_defs') # North America Albers Equal Area Conic from https://epsg.io/102008
    SPsf3 <- st_transform(SPsf2, crs=st_crs(out3))

	# Calculate area of the grid intersected by PAs
	SPsf3$area_grid <- st_area(SPsf3)
    out3$area_wdpa=st_area(out3) # area of all intersected wdpa pieces
    wdpaprop <- merge(st_drop_geometry(out3[,c('gridpolyID', 'area_wdpa')]), st_drop_geometry(SPsf3[,c('gridpolyID', 'lat', 'lon', 'area_grid')]), by='gridpolyID')
    wdpaprop$prop_wdpa = as.numeric(wdpaprop$area_wdpa/wdpaprop$area_grid) # turn to a proportion of the grid cell
        with(wdpaprop, sum(area_wdpa > area_grid)) # a few are too big
        max(wdpaprop$prop_wdpa)
    wdpaprop$prop_wdpa[wdpaprop$prop_wdpa>1] <- 1 # fix the cases that are slightly >1

	# add grid cells with 0 coverage
	missinggridpolyIDs = setdiff(SPsf3$gridpolyID, wdpaprop$gridpolyID) # all the rows in out grid (SP) that didn't find a matching protected area
	new = st_drop_geometry(SPsf3[SPsf3$gridpolyID %in% missinggridpolyIDs, c('gridpolyID', 'lat', 'lon', 'area_grid')])
    new$area_wdpa <- new$prop_wdpa <- 0 # add PA area and proportion
    units(new$area_wdpa) <- units(wdpaprop$area_wdpa) # set the units

	wdpacov = rbind(wdpaprop, new)
		dim(wdpacov)
		nrow(SPsf3) # should match
		hist(wdpacov$prop_wdpa, xlab='Proportion of grid cell covered by WDPA', main='') # basically all or nothing, since grid size so small
		hist(wdpacov$prop_wdpa[!(wdpacov$prop_wdpa %in% c(0,1))], xlab='Proportion of grid cell covered by WDPA', main='Not 0 or 1') # the rest

	# re-order
	wdpacov = wdpacov[order(wdpacov$gridpolyID),]

	# Write out
	#saveRDS(wdpacov, file=paste('output/grid', gridsz, '_cov_by_wdpa.rds', sep=''))
    write.csv(wdpacov, file=gzfile(paste('output/grid', gridsz, '_cov_by_wdpa.csv.gz', sep='')))

# Calculate the fraction of each PA in each grid cell
    # get area of each WDPA piece in each grid cell
	wdpagrid2 <- st_transform(wdpagrid, crs='+proj=aea +lat_1=20 +lat_2=60 +lat_0=40 +lon_0=-96 +x_0=0 +y_0=0 +ellps=GRS80 +datum=NAD83 +units=m +no_defs') # North America Albers Equal Area Conic from https://epsg.io/102008
	wdpagrid2$area_wdpa=st_area(wdpagrid2) # area of each intersected wdpa piece

	# get area of each WDPA PA and area of each grid cell
	wdpa = st_read('dataDL/WDPA/WDPA_Aug2019_marine-shapefile/WDPA_Aug2019_marine-shapefile-polygons.shp')
	wdpa2 <- st_transform(wdpa, crs='+proj=aea +lat_1=20 +lat_2=60 +lat_0=40 +lon_0=-96 +x_0=0 +y_0=0 +ellps=GRS80 +datum=NAD83 +units=m +no_defs') # North America Albers Equal Area Conic from https://epsg.io/102008
	wdpa2$area_fullwdpa <- st_area(wdpa2)
	wdpa.by.grid <- merge(st_drop_geometry(wdpagrid2), st_drop_geometry(wdpa2[,c('WDPA_PID', 'area_fullwdpa')]))
		dim(wdpa.by.grid)
		dim(wdpagrid2) # should match
		head(wdpa.by.grid)
	wdpa.by.grid <-	merge(wdpa.by.grid, st_drop_geometry(SPsf3[,c('gridpolyID', 'area_grid')]), by='gridpolyID') # merge in grid cell area (need SPsf3 from above)

	# fraction of each PA in each grid cell
	wdpa.by.grid$prop_grid <- as.numeric(wdpa.by.grid$area_wdpa/wdpa.by.grid$area_fullwdpa) # fraction of each PA that is in each grid cell
		summary(wdpa.by.grid$prop_grid) # max is very slightly above 1, which must be a mistake
	wdpa.by.grid$prop_grid[wdpa.by.grid$prop_grid>1] <- 1 # fix the cases that are slightly >1

	# fraction of each grid cell in each PA
	wdpa.by.grid$prop_wdpa <- as.numeric(wdpa.by.grid$area_wdpa/wdpa.by.grid$area_grid) # fraction of each PA that is in each grid cell
	summary(wdpa.by.grid$prop_wdpa) # max is very slightly above 1, which must be a mistake
	wdpa.by.grid$prop_wdpa[wdpa.by.grid$prop_wdpa>1] <- 1 # fix the cases that are slightly >1

	# re-order
	wdpa.by.grid <- wdpa.by.grid[order(wdpa.by.grid$WDPA_PID, wdpa.by.grid$gridpolyID),]
		head(wdpa.by.grid)

# write out
	# saveRDS(wdpa.by.grid, file=paste('output/wdpa_cov_by_grid', gridsz, '.rds', sep=''))
	write.csv(wdpa.by.grid, file=gzfile(paste0('output/wdpa_cov_by_grid', gridsz, '.csv.gz')))


# Include psych package

library(psych)

# Generate N number of trials ---------------------------------------------

n <- 150
not_useful <- 3
cases <- 2

# Generate randomized trials for N = 150 ----------------------------------

trials <-  block.random(n,c(not_useful, cases))
headTail(trials)
output <- data.frame(trials)
colnames(output) <- c("Block no.","to_be_discarded","Case")

# Write CSV file ----------------------------------------------------------

# Discarding second column which contains non-relevent data
write.csv(output[,-2],"Randomized_trials.csv")
pairs.panels(trials)
plot(trials,type = 'l')