# écriture de stochastic_model sans array
# avec output true

# endogènes -----------------
## qpib pib en volume
## vpib pib en valeur (mds euro)
## og écart de production
## ppib prix du pib
## inf  inflation
## imp_dep, imp_po, imp_int décompositon de l'impulsion budgétaire en trois composantes
##                           dépenses, recettes, et intérêt
## dette dette publique, en valeur (mds euro)
## tppdette dette publique en point de pib potentiel
## dettep dette publique en point de pib
## cha_int  charge d'intérêt en valeur (mds euro)
## tchaint  charge d'intérêt en point de pib potentiel
## r_app    taux d'intérêt souverain national apparent (1% = 0.01)
## r_inst   taux d'intérêt souverain instantané (moyen année) (1% = 0.01)
## gpot croissance potentielle en volume
## aide de odin https://mrc-ide.github.io/odin/
## tcho est le taux de chômage au sens du BIT
## tvnairu est le NAIRU de AMECO tandis que Nairu est le chômage d'équilibre

# exogènes --------------
## dep_prim dépenses primaires en valeur
## rec_po   recettes fiscales (et non fiscales) en valeur (mds euro)
## pibpot pib potentiel en volume

# écart de production -------------------
og <- lagog + dog
dog <- og_lag * (lagog - lag2og) +
  - og_mce * (lagog - 0) +
  og_dep * ib_dep +
  og_po * ib_po +
  og_cin * ib_cin +
  og_noise +
  - og_ddpot * ((pibpot/lagpibpot-1)-(lagpibpot/lag2pibpot-1)) +
  - pot_r*(r_inst-lagr_inst)
# on retarde de cette façon, cela permet de passer une condition initiale
update(lagog) <- og
update(lag2og) <- lagog
update(og_noise) <- ogn_ar * og_noise + rnorm(0, ogn_sigma)

# Taux de chômage -------------------
tcho <- lagtcho - tcho_okun * dog - tcho_mce * (lagtcho+lagog-lagtvnairu)
update(lagtcho) <- tcho
update(lag2tcho) <- lagtcho

# Dynamique du NAIRU -------------------
tvnairu <- lagtvnairu - tvnairu_mce * (lagtvnairu - nairu)
update(lagtvnairu) <- tvnairu

# prix du pib -------------------
txppib <- lagtxppib + inf_lag * (lagtxppib - lag2txppib) - inf_mce * (lagtxppib - infstar + inf_tcho * (lagtcho - lagtvnairu))
ppib <- (1 + txppib)*lagppib
update(lagppib) <- ppib
update(lag2ppib) <- lagppib
update(lag3ppib) <- lag2ppib
lagtxppib <- lagppib/lag2ppib-1
lag2txppib <- lag2ppib/lag3ppib-1

# pib volume&valeur&potentiel -----------
pibpot <- lagpibpot*(1+(gpot[step]-1*((tvnairu-lagtvnairu)/(1-(tvnairu-i_lagtvnairu)))))
update(lagpibpot) <- pibpot
update(lag2pibpot) <- lagpibpot
qpib <- (1 + og) * pibpot
vpib <- qpib * ppib
lagvpib <- lagqpib * lagppib
lag2vpib <- lag2qpib * lag2ppib
update(lagqpib) <- qpib
update(lag2qpib) <- lagqpib
gpib <- qpib/lagqpib-1
update(laggpib) <- gpib
gpot_v <- pibpot/lagpibpot-1

# dette ------------
# dette au 31 décembre
dette <- lagdette + ddette + dette_oneoff[step]
update(lagdette) <- dette
update(lag2dette) <- lagdette
lagdettep <- lagdette/lagvpib
lag2dettep <- lag2dette/lag2vpib
ddette <- - rec_po + dep_prim + cin - taut[step] * vpib

# taux d'intérêt ---------------
#r_inst <- gpot[step] + lagtxppib + ecart_c + r_dette * (lagdettep - dstarr)
r_inst <- gpot_v + infstar + ecart_c + r_dette * (lagdettep - dstarr)
r_app <- (1-1/r_mat) * lagr_app +  1/r_mat * r_inst
update(lagr_app) <- r_app
ecart_c <- lagecart_c + decart_c
decart_c <- -ec_mce * (lagecart_c - ecstar)
update(lagecart_c) <- ecart_c
update(lagr_inst) <- r_inst

# impulsion --------------
# l'impulsion sur les dépenses est définie comme la variation du taux des dépenses par rapport au potentiel
dep_prim <- tdeppp * ppib_dep * pibpot_dep

ppib_dep <- lagppib_dep*(1+ infdep_star*txppib + (1-infdep_star)*lagtxppib_dep - infdep_mce*(lagppib_dep/lagppib-1))
pibpot_dep <- lagpibpot_dep*(1+ potdep_star*gpot_v + (1-potdep_star)*lagtxpibpot_dep - potdep_mce*(lagpibpot_dep/lagpibpot-1))

#pibpot_dep <- lagpibpot_dep*(1+(-((lag2pibpot_dep-lagpibpot_dep)/lag2pibpot_dep)-potdep_mce*(lagpibpot_dep/lagpibpot-1)))
lagtxppib_dep <- (lagppib_dep-lag2ppib_dep)/lag2ppib_dep
lagtxpibpot_dep <- (lagpibpot_dep-lag2pibpot_dep)/lag2pibpot_dep

update(lagppib_dep) <- ppib_dep
update(lag2ppib_dep) <- lagppib_dep
update(lagpibpot_dep) <- pibpot_dep
update(lag2pibpot_dep) <- lagpibpot_dep
update(lagtdeppp) <- tdeppp
update(lag2tdeppp) <- lagtdeppp

tdepp_e <- dep_prim/pibpot/ppib
update(lagtdepp_e) <- tdepp_e

# l'impulsion sur les recettes est définie comme la variation du tpo
rec_po <- tpo * vpib
update(lagtpo) <- tpo

# l'impulsion sur les intérêts (le multiplicateur est suceptible d'être nul (og_int))
# charge d'intérêts nette de la part BC
cin  <- r_app * lagdette - dettebc * lagdette * r_bc
cinp <- cin / vpib
update(lagcinp) <- cinp
update(lag2cinp) <- lagcinp

ib_cin <- lagcinp - lag2cinp

# règle budgétaire --------------
spp <- (rec_po - dep_prim)/vpib + taut[step]
update(lagspp) <- spp
update(lag2spp) <- lagspp
spstar <- (ecart_c+r_dette*(dstar-dstarr))/(1+gpot_v+infstar) * dstar

ib_fr <- tpo_sstar * (lagspp - spstar) + tpo_1sstar * (lagspp - lag2spp) + tpo_sstar2 * (lagspp - spstar)^2 +
         tpo_dstar * (lagdettep - dstar) + tpo_1dstar * (lagdettep - lag2dettep) + tpo_dstar2 * (lagdettep - dstar)^2 +
         tpo_og*(lagog) + tpo_og2*(lagog)^2 + tpo_1og*(lagog - lag2og) +
         tpo_ec*(ecart_c - ecstar) +
         tpo_inf*(lagtxppib- infstar) +
         phi[step]

ib_sup <- max(min(ib_fr, ibcap), -ibcap)

ib_spont_dep <- tx_deriv_dep[step] * lagtdeppp +
  lagtdeppp * (lagppib_dep*lagpibpot_dep / lagpibpot / lagppib - lag2ppib_dep * lag2pibpot_dep/ lag2pibpot / lag2ppib)
ib_dep <- ib_spont_dep + (1-pcpo) * ib_sup
tdeppp <- lagtdeppp + ib_dep

ib_spont_po <-  - tx_deriv_po[step] * lagtpo
ib_po <- ib_spont_po + pcpo * ib_sup
tpo <- lagtpo - ib_po

# fonction de perte ----------------------
# utilisée pour la partie optimisation
update(loss_d_only) <- loss_d_only + loss_d * (step >= loss_t)*(lagdettep - dstar)^2
initial(loss_d_only) <- 0
update(loss_no_d) <- loss_no_d + og^2/(1+loss_df)^(step-1) + loss_dog * (og-lagog)^2 + loss_ib * (ib_sup)^2
initial(loss_no_d) <- 0

# sorties ------
# dans dust c'est un peu capilotracté
# sans output, on est obligé de faire un update()
# et de définir une CI nulle
# on pense ensuite à décaler les variables pour les utilisations
#
update(dettep_o) <- dette / vpib
update(og_o) <- og
update(txppib_o) <- ppib/lagppib-1
update(gpib_o) <- qpib/lagqpib-1
update(gpot_o) <- gpot_v
update(spp_o) <- spp
update(ci_o) <- cinp
update(tpo_o) <- tpo
update(tdep_o) <- tdepp_e * pibpot/qpib
update(tdeppp_o) <- tdepp_e
update(ib_dep_o) <- ib_dep
update(ib_po_o) <- ib_po
update(ib_o) <- ib_po + ib_dep
update(qpib_o) <- qpib
update(ppib_o) <- ppib
update(tcho_o) <- tcho
update(tvnairu_o) <- tvnairu
update(spstar_o) <- spstar
update(r_app_o) <- r_app
update(loss_o) <- loss_no_d + loss_d_only
update(loss_nd_o) <- loss_no_d

initial(txppib_o) <- 0
initial(gpib_o) <- 0
initial(gpot_o) <- 0
initial(spp_o) <- 0
initial(og_o) <- 0
initial(dettep_o) <- 0
initial(ci_o) <- 0
initial(tpo_o) <- 0
initial(tdep_o) <- 0
initial(ib_dep_o) <- 0
initial(ib_o) <- 0
initial(ib_po_o) <- 0
initial(qpib_o) <- 0
initial(ppib_o) <- 0
initial(tcho_o) <- 0
initial(tvnairu_o) <- 0
initial(tdeppp_o) <- 0
initial(spstar_o) <- 0
initial(r_app_o) <- 0
initial(loss_o) <- 0
initial(loss_nd_o) <- 0

# init ----------------
i_lagog <- user(0)
i_lagtcho <- user(0)
i_lag2tcho <- user(0)
i_lagtvnairu <- user(0)
i_lag2og <- user(0)
i_lagqpib <- user(1)
i_lag2qpib <- user(1)
i_lag3qpib <- user(1)
i_lagppib <- user(1)
i_lag2ppib <- user(1)
i_lag3ppib <- user(1)
i_lagpibpot <- user(1)
i_lag2pibpot <- user(1)
i_lagtpo <- user(0.5)
i_lagtdeppp <- user(0.5)
i_lagr_app <- user(0.04)
i_lagr_inst <- user(0.04)
i_lagdette <- user(1)
i_lagspp <- user(0.0)
i_lag2spp <- user(0.0)
i_lagecart_c <- user(0.0)
i_ogn <- user(0) # rnorm(0, ogn_sigma)+ogn*(rnorm(0, ogn_sigma) + ogn*(rnorm(0, ogn_sigma)+ogn*rnorm(0, ogn_sigma)))
i_lagcip <- user(0.02)
i_lag2cip <- user(0.02)
i_lag2dette <- user(1)
i_lag2tdeppp <- user(0.5)

## Initial conditions
# initial(og) <- init_og
initial(lagog) <- i_lagog
initial(lag2og) <- i_lag2og
initial(lagtcho) <- i_lagtcho
initial(lag2tcho) <- i_lag2tcho
initial(lagtvnairu) <- i_lagtvnairu
initial(og_noise) <- i_ogn
initial(lagppib) <- i_lagppib
initial(lag2ppib) <- i_lag2ppib
initial(lag3ppib) <- i_lag3ppib
initial(lagppib_dep) <- i_lagppib
initial(lag2ppib_dep) <- i_lag2ppib
initial(lagqpib) <- i_lagqpib
initial(lag2qpib) <- i_lag2qpib
initial(laggpib) <- i_lag2qpib/i_lag3qpib - 1
initial(lagpibpot) <- i_lagpibpot
initial(lagpibpot_dep) <- i_lagpibpot
initial(lag2pibpot_dep) <- i_lag2pibpot
initial(lag2pibpot) <- i_lag2pibpot
initial(lagtpo) <- i_lagtpo
initial(lagtdepp_e) <- i_lagtdeppp
initial(lagtdeppp) <- i_lagtdeppp
initial(lag2tdeppp) <- i_lag2tdeppp
initial(lagr_app) <- i_lagr_app
initial(lagr_inst) <- i_lagr_inst
initial(lagdette) <- i_lagdette
initial(lag2dette) <- i_lag2dette
initial(lagspp) <- i_lagspp
initial(lag2spp) <- i_lag2spp
initial(lagcinp) <- i_lagcip
initial(lag2cinp) <- i_lag2cip
initial(lagecart_c) <- i_lagecart_c

# params -------------
periods <- user(50)

## parameters
og_lag   <- user(0)
og_mce   <- user(0.29)
og_ddpot   <- user(0.29)
tvnairu_mce   <- user(0.13)
tcho_okun   <- user(0.33)
tcho_mce   <- user(0.27)
inf_tcho <- user(0.1)
inf_lag <- user(0.0)
inf_mce <- user(0.68)
infdep_mce <- user(0.5)
infdep_star <- user(0.5)
potdep_star <- user(0.5)
potdep_mce <- user(0.5)
pot_r   <- user(0.15)
og_dep  <- user(0.7)
og_po  <-  user(0.7)
og_cin  <- user(0)
infstar <- user(0.0175)
r_mat   <- user(8)
dstar <- user(0.6)
dstarr <- user(0.6)
nairu <- user(0.07)
tpo_sstar <- user(0.4)
tpo_dstar <- user(0.1)
tpo_sstar2 <- user(0)
tpo_1sstar <- user(0)
tpo_dstar2 <- user(0)
tpo_1dstar <- user(0)
tpo_1og <- user(0)
tpo_og <- user(0)
tpo_og2 <- user(0)
tpo_ec <- user(0)
tpo_inf <- user(0)
pcpo <- user(1)
loss_df <- user(0.02)
loss_ib <- user(0)
ogn_ar <- user(0)
ogn_sigma <- user(0.005)
r_dette <- user(0.01)
ibcap <- user(0.01)
ecstar <- user(-0.015)
ec_mce <- user(0.1)
dettebc <- user(0)
r_bc <- user(0)

# loss
loss_dog <- user(0)
loss_d <- user(0.5)
loss_t <- user(20)

# controls&exogenes -----------
dette_oneoff[] <- user(0)
phi[] <- user(0)
taut[] <- user(0)
gpot[] <- user(0)
tx_deriv_dep[] <- user(0)
tx_deriv_po[] <- user(0)

dim(dette_oneoff) <- periods
dim(phi) <- periods
dim(gpot) <- periods
dim(taut) <- periods
dim(tx_deriv_dep) <- periods
dim(tx_deriv_po) <- periods


library(rbenchmark)
suppressPackageStartupMessages(library(pbdML))

### non-mpi test only
m <- 1000
n <- 100
x <- rnorm(m*n)
dim(x) <- c(m, n)

benchmark(rpca(x, k=1))


#==============================================
#  functions
#----------------------------------------------
#  reworked function to speed up the bootstrap analysis

#----------------------------------------------------
#  Make Tables with specified categoriges
#  Enables fixed format output and zero entries
#----------------------------------------------------

Table <- function(x,Labels){
  #=c("D614","G614") ){
  xx <- rep(0, length(Labels) )
  names(xx) <- Labels
  xx.t <- table( x )
  xx[ names(xx.t) ] <- xx.t
  return(xx)
}

#=================================================================
#  Compute isotonic logistic regression, using the pava rountine
#  from Iso
#  Input:  yy     matrix of successes, failures, ordered in time
#          decreasing = F
#          theta  initial value, default is zero
#          err    L1 error on estimated probs.  Recommended 10e-5
#          eps    numerical stability for prob going to 0 or 1
IsoLog <- function(Y,decreasing=F,theta=0,err=1e-5,min.w=1e-6){
  G <- 1
  theta0 <- theta
  pp <- exp(theta0)/(1+exp(theta0))

  yy   <- Y[,1]
  nn   <- apply(Y,1,sum)

  while ( G > err ){
    ww <- nn*pmax( pp*(1-pp), min.w )  # ensure the weights are always larger than eps
    zz <- theta0 + (yy-nn*pp)/ww
    theta1 <- pava(zz,ww,decreasing=decreasing)
    p1 <- exp(theta1)/(1+exp(theta1))
    G <- sum( abs(p1-pp) )
    #
    theta0 <- theta1
    pp <- p1
  }
  return(theta1)
}

#===================================================================================
#  fit a Ashaped
Ashape <- function(Y,lmode,theta=0,err=1e-5,min.w=1e-6){
  G <- 1
  theta0 <- theta
  pp <- exp( theta0)/( 1+exp(theta0) )

  yy <- Y[,1]
  nn <- apply(Y,1,sum)
  iidx <- (1:length(yy)) < (lmode+1)

  while ( G > err ){
    ww <- nn*pmax( pp*(1-pp), min.w )  # ensure the weights are always larger than eps
    zz <- theta0 + (yy-nn*pp)/ww
    theta1 <- pava(zz[iidx],ww[iidx],decreasing=F)
    theta2 <- pava(zz[!iidx],ww[!iidx],decreasing=T)
    ttheta <- c(theta1,theta2)
    p1 <- exp(ttheta)/(1+exp(ttheta))
    G <- sum( abs(p1-pp) )
    #
    theta0 <- ttheta
    pp <- p1
  }
  loglik <- sum(yy*log(pp) + (nn-yy)*log(1-pp))
  return( list( theta=theta0,p=pp,loglik=loglik ) )
}

Ashape2 <- function(Y,Lmode=c(1,dim(Y)[1]),theta=0,err=1e-6,min.w=1e-6){
  lmode <- Lmode[1]:Lmode[2]
  Ffit <- vector("list",length = length(lmode))
  Ffit[[1]] <- Ashape(Y,lmode[1],theta)
  for ( k in 2:length(lmode) ){
    Ffit[[k]] <- Ashape(Y,lmode=lmode[k],Ffit[[k-1]]$theta)
  }
  iidx <- which.max(sapply(Ffit, FUN=function(x) x$loglik))
  return( list( theta=Ffit[[iidx]]$theta,
                p=Ffit[[iidx]]$p,
                loglik=Ffit[[iidx]]$loglik,
                mode = lmode[iidx] ) )
}

#===================================================================
#  Function to compute from one bootstrap sample
#  To be used in parallel
#  input: empty vector, needed to get it to run in parallel
#         y vector of 0-1
#         ddate: vector of dates
#         p0: probability under the null distribution
#         Decreasing: test decresing? T=yes, F=no
#         Labels: vector of labels to be used in Table
#===================================================================
Boot.Pval <- function(zz,yy,ddates,p0,Decreasing=F,Labels=c("M","W")){

    y.b <- sample(yy, replace = F)  # permutation of strain labels
    ddt.b <- split(y.b,ddates) # split by date
    BB.b <- t( sapply( ddt.b , Table, Labels=Labels ) )

    ffit.b <- IsoLog( as.matrix( BB.b ), decreasing=Decreasing)
    p.b <- exp(ffit.b)/(1+exp(ffit.b))

    # calculate relative loglikelihood
    LL <- sum( BB.b[,1]*log(p.b/p0) + BB.b[,2]*log((1-p.b)/(1-p0)) )

    return(LL)

  }


#DEPRECATED
##############################################################################
# Plot correlation comparing per-bin counts
##############################################################################
names(agg_5bp_100k_common)[4]<-"common_obs"
bincts<-merge(agg_5bp_100k, agg_5bp_100k_common, by=c("CHR", "BIN", "Category2"))

bincts %>% group_by(Category2) %>% summarise(cor=cor(obs, common_obs))

ggplot(data=bincts,
		aes(x=obs, y=common_obs, colour=Category2, group=Category2))+
	geom_point(alpha=0.4)+
	geom_smooth(method=lm, se=FALSE, colour="black")+
	scale_colour_manual(values=rbg)+
	xlab("Singletons")+
	ylab("Polymorphisms (MAC>10)")+
	theme_bw()+
	theme(legend.position="none")+
	facet_wrap(~Category2, scales="free")
ggsave(paste0(parentdir, "/images/sing_com_corr.png"), width=6.2, height=4.2)

##############################################################################
# Simulate correlations
##############################################################################
output<-data.frame()
for(i in 1:50){
	cat("running simulation", i, "of 50...\n")
	simdat1<-dat_5bp_100k$summ[sample(nrow(dat_5bp_100k$summ), 24176074),]
	simdat1$gp<-sample(0:1, nrow(simdat1), replace=T)

	simdat<-simdat1 %>%
		group_by(CHR, BIN, Category2, gp) %>%
		summarise(count=n())

	simdat$gp<-ifelse(simdat$gp==0,"gp1", "gp2")
	simdat2<-simdat %>% spread(gp, count)
	simdat2<-simdat2[complete.cases(simdat2),]

	simcor<-simdat2 %>% group_by(Category2) %>% summarise(cor=cor(gp1, gp2))
	output<-rbind(output, simcor)
}

simcor<-output %>%
	group_by(Category2) %>%
	summarise(corsim=mean(cor)) %>%
	mutate(gp="sim")

obscor<-bincts %>%
	group_by(Category2) %>%
	summarise(corobs=cor(obs, common_obs)) %>%
	mutate(gp="obs")

tmp<-r.test(2897, simcor$corsim, obscor$corobs)$z

corcomb<-cbind(merge(simcor, obscor, by="Category2"), tmp) %>%
	mutate(cor.p=-2*pnorm(-abs(tmp), log.p=T))

names(simcor)[2]<-"cor"
names(obscor)[2]<-"cor"
corplot<-rbind(simcor, obscor)

corplot$Category2<-factor(corplot$Category2, levels=orderedcats)
corplot$gp<-as.factor(corplot$gp)
corplot$gp<-relevel(corplot$gp, "sim")
corplot<-corplot %>%
	group_by(Category2) %>%
	mutate(cormax=max(cor)) %>%
	arrange(Category2)

corplot$xst<-seq(0.75,9.25,0.5)
corplot$xend<-rep(1:9,each=2)

corplot2<-merge(corplot, corcomb)
corplot2$cor.p<-round(corplot2$cor.p, 1)

ggplot(corplot2, aes(x=Category2, y=cor, fill=gp))+
	geom_bar(position="dodge", stat="identity")+
	geom_segment(data=corplot2, aes(x=xst, xend=xst, yend=cormax+0.1))+
	geom_segment(data=corplot2, aes(x=xst, xend=xend, y=cormax+0.1, yend=cormax+0.1))+
	geom_text(data=corplot2, aes(y=cormax+0.2, label=cor.p))+
	scale_fill_manual("Correlation", values=myPaletteCat(4)[1:2], labels=c("Simulated", "Observed"))+
	scale_y_continuous(breaks=c(0, 0.25, 0.5, 0.75, 1))+
	# geom_errorbar(limits, position="dodge", width=1)+
	theme_classic()+
	theme(legend.title=element_blank(),
		  legend.text=element_text(size=16),
		  axis.title.x=element_text(size=20),
		  axis.title.y=element_text(size=20),
		axis.text.x=element_text(size=14, angle=45, hjust=1, vjust=1),
		  axis.text.y=element_text(size=16))+
	xlab("Category")+
	ylab("Correlation")
ggsave(paste0(parentdir, "/images/sing_com_cor_bars.png"), width=9.6, height=4.8)

##############################################################################
# Test for heteroscedasticity
##############################################################################
orderedcats<-c("AT_CG", "AT_GC", "AT_TA",
	"GC_AT", "GC_CG", "GC_TA",
	"cpg_GC_AT", "cpg_GC_CG", "cpg_GC_TA")

dat<-data.frame()
for(i in orderedcats2){
  r5m1 <- r5m %>% filter(Category2==i)
  r5m2 <- r5m1 %>% filter(num.x>=100 & num.y>=100)
  p1 <- lm(rel_prop~common_rel_prop+num.x+num.y, data=r5m1)
  p2 <- lm(rel_prop~common_rel_prop+num.x+num.y, data=r5m2)
  t1 <- bptest(p1)
  t2 <- bptest(p2)
  fullcor <- cor(r5m1$rel_prop, r5m1$common_rel_prop, method="spearman")
  subcor <- cor(r5m2$rel_prop, r5m2$common_rel_prop, method="spearman")

  fullcor <- cor(r5m1$rel_prop, r5m1$common_rel_prop)
  subcor <- cor(r5m2$rel_prop, r5m2$common_rel_prop)

  newrow1 <- data.frame(Category=i, Data="full", Cor=fullcor, Dim=nrow(r5m1), pval=t1$p.value)
  newrow2 <- data.frame(Category=i, Data="sub", Cor=subcor, Dim=nrow(r5m2), pval=t2$p.value)
  dat<-rbind(dat, newrow1)
  dat<-rbind(dat, newrow2)
}

r5m$Category2<-factor(r5m$Category2, levels=orderedcats)

nsing<-sum(r5m$num.x)
ncommon<-sum(r5m$num.y)
pvals<-rep(0, nrow(r5m))
for(i in 1:nrow(r5m)){
	row<-r5m[i,]

	test<-prop.test(c(ceiling(row$num.x/3.073), row$num.y), c(ceiling(nsing/3.073), ncommon))
	pvals[i]<-test$p.value
}
r5m$pval<-pvals


# Start point bias plots
    # Set overlap values
    overlaps <- seq(0,1.5,0.025)
    # Run RRW based on overlaps and bias
    # Unbiased start point
    unbiased <- getMomentsOfRRWoverlap(overlaps,boundary=10, startValue=0, loops = 500,noiseSD = 2)
    #Positive start point bias
    posbias1 <- getMomentsOfRRWoverlap(overlaps,boundary=10, startValue=0.25, loops = 500,noiseSD = 2)
    posbias2 <- getMomentsOfRRWoverlap(overlaps,boundary=10, startValue=0.50, loops = 500,noiseSD = 2)
    # Negative start point bias
    negbias1 <- getMomentsOfRRWoverlap(overlaps,boundary=10, startValue= -0.25, loops = 500,noiseSD = 2)
    negbias2 <- getMomentsOfRRWoverlap(overlaps,boundary=10, startValue= -0.50, loops = 500,noiseSD = 2)

    # Generate plot found in paper
     with(unbiased[unbiased$correct==T,],plot(pCross ~ overlap, pch=16, col="black",frame.plot=F,xlab="Overlap",ylab="pHO",ylim=c(0,1),las=1,cex=0.75,xaxt='n'))
       abline(0.5,0,lty=2)
       abline(v=1,lty=2)
       axis(1, at = seq(0, 1.5, by = .1), las=2)
       with(posbias1[posbias1$correct==T,],points(pCross ~ overlap, pch=16, col="sky blue",cex=0.75))
       with(posbias2[posbias2$correct==T,],points(pCross ~ overlap, pch=16, col="blue",cex=0.75))
       with(negbias1[negbias1$correct==T,],points(pCross ~ overlap, pch=16, col="light pink",cex=0.75))
       with(negbias2[negbias2$correct==T,],points(pCross ~ overlap, pch=16, col="red",cex=0.75))
       legend(0.2,0.4, legend=c("0.50","0.25","0 (unbiased)","-0.25","-0.50"),title="Start Point",col=c("blue", "skyblue","black","light pink","red"),pch=16,cex=0.75)
       # Write to a pdf
       dev.copy(pdf,"pHVOxOverlapVal.pdf")
       dev.off()


context("Fortify")
library(sp)

test_that("Spatial polygons have correct ordering", {
  make_square <- function(x = 0, y = 0, height = 1, width = 1){
    delx <- width/2
    dely <- height/2
    Polygon(matrix(c(x + delx, x - delx,x - delx,x + delx,x + delx ,
        y - dely,y - dely,y + dely,y + dely,y - dely), ncol = 2))
  }

  make_hole <- function(x = 0, y = 0, height = .5, width = .5){
    p <- make_square(x = x, y = y, height = height, width = width)
    p@hole <- TRUE
    p
  }

  fake_data <- data.frame(ids = 1:5, region = c(1,1,2,3,4))
  rownames(fake_data) <- 1:5
  polys <- list(Polygons(list(make_square(), make_hole()), 1),
                Polygons(list(make_square(1,0), make_square(2, 0)), 2),
                Polygons(list(make_square(1,1)), 3),
                Polygons(list(make_square(0,1)), 4),
                Polygons(list(make_square(0,3)), 5))

  polys_sp <- SpatialPolygons(polys)
  fake_sp <- SpatialPolygonsDataFrame(polys_sp, fake_data)

  # now reorder regions
  polys2 <- rev(polys)
  polys2_sp <- SpatialPolygons(polys2)
  fake_sp2 <- SpatialPolygonsDataFrame(polys2_sp, fake_data)

  expect_equivalent(fortify(fake_sp), arrange(fortify(fake_sp2), id, order))

})


#' Biological ternary plot from three rows of the matrix
#'
#' This is a wrapper of ggern function in ggtern package. The wrapper makes it easier to plot matrix data with grouping information.
#' See the details for more information, and run the example for a sample plot to have a look at what a ternary plot look like
#'
#'
#' @param data_matrix a two dimentional data matrix, with rows as annation/function/taxon, while columns are samples
#' @param data_meta a dataframe with sample-group matching
#' @param three_points could be "top3", or a vector of row index, or a vector of row names. If vector, the length must be 3. see examples
#'
#' @return a data.frame of matrix_selected and ggplot2 object of ternary.plot
#'
#' @seealso \code{\link{ggtern}}
#'
#' @examples

#'
#'
#' @export

ternary_plot_matrix <- function(data_matrix, data_meta, three_points){

  suppressMessages(install.packages.auto(ggtern))

  mode(data_matrix) <-"numeric" # in case mode is character

  if(length(three_points) ==1 && three_points == "top3"){
    three_points = rownames(data_matrix)[1:3]
  } else if(is.numeric(three_points)){
    # check if some of the location out of boundary(nrow)
    if(any(unlist((lapply(three_points, function(x) x>20))))){
      stop("out of boundary")
    }else{
      three_points = rownames(data_matrix)[three_points]
    }
  }else if(is.character(three_points)){
    index <- match(three_points, rownames(data_matrix))
    if( any(unlist(lapply(index, is.na))) ) {
      stop("item_name Not found, please input the right one")
    }
  }

  select_3 <- as.data.frame(t(data_matrix[which(rownames(data_matrix) %in% three_points),]))
  # select_3 <- as.data.frame(scale(select_3), scale = FALSE) # rescale

  # reorder the data_meta, in case there is mis-match of the column names
  data_meta_Reorder <- data_meta[match(rownames(select_3), data_meta[,1]),]

  select_3$Group <- data_meta_Reorder[,2]

  colnames(select_3)<-c("x","y","z", "Group")
  p <- ggtern(data=select_3,aes(x,y,z,color=Group)) + geom_point() + labs(x=three_points[1],y=three_points[2],z=three_points[3],title="Ternary Plot")

  return(list(ternary.plot = p,
              matrix_selected = select_3
  ))

}

# #data preparation
#
#  matrix_test <- matrix(runif(2000), nrow = 20)
#  rownames(matrix_test) <- paste("COG", 1:20, sep = "_")
#  colnames(matrix_test) <- paste("sample", 1:100, sep = "_")
#  factor_test <- sample(LETTERS[1:3], 100, replace = TRUE)
#  meta_test <- data.frame(samplename = colnames(matrix_test), grouping = factor_test)
#
# #Plot in three ways
#
# t <- ternary_plot_matrix(data_matrix = matrix_test, data_meta = meta_test, three_points = c("COG_1", "COG_2", "COG_3"))
# t$ternary.plot
# t <- ternary_plot_matrix(data_matrix = matrix_test, data_meta = meta_test, three_points = "top3")
# t$ternary.plot
# t <- ternary_plot_matrix(data_matrix = matrix_test, data_meta = meta_test, three_points = c(2,4,5))
# t$ternary.plot


#########################################################
#install.packages("argparse")
library(argparse)
library(mdatools)
parser <- ArgumentParser()

parser$add_argument("--file", type="character", default= "no_input_return_error",
    help="file containing variant frequencies")
parser$add_argument("--plot_bool", type="logical", default= FALSE,
    help="determines whether pdf plot approx_plot.pdf is produced or not")
parser$add_argument("--var_calling_threshold", type="double", default= 0.03,
    help="variant calling threshold")
parser$add_argument("--Nb_min", type="integer", default= 1,
    help="Minimum bottleneck value considered")
parser$add_argument("--Nb_max", type="integer", default= 200,
    help="Maximum bottleneck value considered")
parser$add_argument("--confidence_level", type="double", default= .95,
    help="Confidence level (determines bounds of confidence interval)")
args <- parser$parse_args()
if (args$file == "no_input_return_error" ) { stop("file with lists of donor and recipient frequencies is a required argument.", call.=FALSE)}

plot_bool  <- args$plot_bool
var_calling_threshold  <- args$var_calling_threshold
Nb_min <- args$Nb_min # Minimum bottleneck size we consider.
Nb_max <-  args$Nb_max
confidence_level <- args$confidence_level
donor_and_recip_freqs_observed <- read.table(args$file) #donor_freqs_observed <- read.table(args[1])
donor_freqs_observed <- as.data.frame(donor_and_recip_freqs_observed[, 1]) # We read in and save the list of donor frequencies
recipient_freqs_observed <- as.data.frame(donor_and_recip_freqs_observed[, 2]) # We read in and save the list of recipient frequencies
n_variants <- nrow(donor_and_recip_freqs_observed)#nrow(donor_freqs_observed) # number of variants

#######################################################
#######################################################
generate_log_likelihood_function_approx <- function(donor_freqs_observed, recipient_freqs_observed, Nb_min, Nb_max, var_calling_threshold, confidence_level)
{

    num_NB_values <- Nb_max -Nb_min + 1
likelihood_matrix <- matrix( 0, n_variants, num_NB_values)#This matrix stores the likelihood values for each variant frequency and bottleneck size.
log_likelihood_matrix <- matrix( 0, n_variants, num_NB_values)#This matrix stores the log likelihood values for each variant frequency and bottleneck size.  We can sum the log likelihoods of all the variant alleles to get the total log likelihood.
log_likelihood_function <- matrix( 0, Nb_max )

for (i in 1:n_variants) {for (j in 1:num_NB_values) {
  Nb_val <- (j - 1 + Nb_min)
    nu_donor <- donor_freqs_observed[i, 1]
    nu_recipient <- recipient_freqs_observed[i, 1]
    if (recipient_freqs_observed[i, 1] >= var_calling_threshold)
        { # implement variant calling threshold

for (k in 0:Nb_val){
      likelihood_matrix[i, j] <- likelihood_matrix[i, j] +
  (dbeta(nu_recipient, k, (Nb_val - k))*dbinom(k, size=Nb_val, prob= nu_donor))
        }
  log_likelihood_matrix[i,j] = log(likelihood_matrix[i, j])
   }
 if (recipient_freqs_observed[i, 1] < var_calling_threshold)
        { # implement variant calling threshold

   likelihood_matrix[i, j] = 0
   log_likelihood_matrix[i,j] = 0
   for (k in 0:Nb_val){   likelihood_matrix[i, j] <- likelihood_matrix[i, j] +
               (pbeta(var_calling_threshold, k, (Nb_val - k))*dbinom(k, size=Nb_val, prob= nu_donor))
                      }
log_likelihood_matrix[i,j] = log(likelihood_matrix[i, j])
            }
# Now we sum over log likelihoods of the variants at different loci to get the total log likelihood for each value of Nb
log_likelihood_function[ Nb_val] <- log_likelihood_function[ Nb_val] + log_likelihood_matrix[i,j]
# Shifting entries of log_likelihood function to ensure plot begins at proper point on x axis
}}

return(log_likelihood_function)

}
#################################################################
#################################################################
restrict_log_likelihood <- function(log_likelihood_function, Nb_min, Nb_max) # restricts log likelihood to the interval of interst
{
for (h in 1:(Nb_min )){
    if(h< Nb_min)
    {log_likelihood_function[h] = - 999999999}        # kludge for ensuring that these values less than Nb_min don't interfere with our search for the max of log likelihood in the interval of Nb_min to Nb_max
    }

return(log_likelihood_function)
#print(erfinv(percent_confidence_interval)*sqrt(2))
}

return_bottleneck_size <- function(log_likelihood_function, Nb_min, Nb_max)
{ max_log_likelihood = which(log_likelihood_function == max(log_likelihood_function))

    return(max_log_likelihood)
}

return_CI_lower <- function(log_likelihood_function, Nb_min, Nb_max) ## returns lower bound of confidence interval
  { max_log_likelihood = which(log_likelihood_function == max(log_likelihood_function))  ## This is the point on the x-axis (bottleneck size) at which log likelihood is maximized
max_val =  max(log_likelihood_function)  ## This is the maximum value of the log likelihood function, found when the index is our bottleneck estimate
CI_height = max_val - erfinv(confidence_level)*sqrt(2)  # This value (  height on y axis) determines the confidence intervals using the likelihood ratio test

    CI_index_lower = Nb_min
  CI_index_upper = max_log_likelihood
for (h in 1:Nb_min){
    if(h< Nb_min)
    {log_likelihood_function[h] = NA}   #  Removing parameter values less than Nb_min from plot
        }
## above loop just enforces our minimum bottleneck cutoff
for (h in Nb_min:max_log_likelihood){
    test1 = (log_likelihood_function[CI_index_lower] - CI_height) * (log_likelihood_function[CI_index_lower] - CI_height)
    test2 = (log_likelihood_function[h] - CI_height) * (log_likelihood_function[h] - CI_height)
        if( test2 < test1){  CI_index_lower = h  }
}
if(  (log_likelihood_function[CI_index_lower] - CI_height) > 0  ){CI_index_lower = CI_index_lower - 1   }
# above loops use likelihood ratio test to find lower confidence interval
for (h in max_log_likelihood:Nb_max)
{       test1 = (log_likelihood_function[CI_index_upper] - CI_height) * (log_likelihood_function[CI_index_upper] - CI_height)
      test2 = (log_likelihood_function[h] - CI_height) * (log_likelihood_function[h] - CI_height)
        if( test2 < test1  ){CI_index_upper = h   }
}
if(  (log_likelihood_function[CI_index_upper] - CI_height) > 0  ){CI_index_upper = CI_index_upper + 1   }

  return(CI_index_lower)

  }

return_CI_upper <- function(log_likelihood_function,  Nb_min, Nb_max) ## returns upper bound of confidence interval
  { max_log_likelihood = which(log_likelihood_function == max(log_likelihood_function))  ## This is the point on the x-axis (bottleneck size) at which log likelihood is maximized
   max_val =  max(log_likelihood_function)  ## This is the maximum value of the log likelihood function, found when the index is our bottleneck estimate
   CI_height = max_val - erfinv(confidence_level)*sqrt(2)  # This value (  height on y axis) determines the confidence intervals using the likelihood ratio test

    CI_index_lower = Nb_min
  CI_index_upper = max_log_likelihood
for (h in 1:Nb_min){
    if(h< Nb_min)
    {log_likelihood_function[h] = NA}   #  Removing parameter values less than Nb_min from plot
        }
## above loop just enforces our minimum bottleneck cutoff
for (h in Nb_min:max_log_likelihood){
    test1 = (log_likelihood_function[CI_index_lower] - CI_height) * (log_likelihood_function[CI_index_lower] - CI_height)
    test2 = (log_likelihood_function[h] - CI_height) * (log_likelihood_function[h] - CI_height)
        if( test2 < test1){  CI_index_lower = h  }
}
if(  (log_likelihood_function[CI_index_lower] - CI_height) > 0  ){CI_index_lower = CI_index_lower - 1   }
# above loops use likelihood ratio test to find lower confidence interval
for (h in max_log_likelihood:Nb_max)
{       test1 = (log_likelihood_function[CI_index_upper] - CI_height) * (log_likelihood_function[CI_index_upper] - CI_height)
      test2 = (log_likelihood_function[h] - CI_height) * (log_likelihood_function[h] - CI_height)
        if( test2 < test1  ){CI_index_upper = h   }
}
if(  (log_likelihood_function[CI_index_upper] - CI_height) > 0  ){CI_index_upper = CI_index_upper + 1   }

  return(CI_index_upper)

  }

log_likelihood_function <- generate_log_likelihood_function_approx(donor_freqs_observed, recipient_freqs_observed, Nb_min, Nb_max, var_calling_threshold, confidence_level)
log_likelihood_function <- restrict_log_likelihood(log_likelihood_function, Nb_min, Nb_max)
bottleneck_size <- return_bottleneck_size(log_likelihood_function,  Nb_min, Nb_max)
CI_index_lower <- return_CI_lower(log_likelihood_function,  Nb_min, Nb_max)
CI_index_upper <- return_CI_upper(log_likelihood_function,  Nb_min, Nb_max)

        ##########################
##############################################################################################  ABOVE THIS LINE DETERMINES PEAK LOG LIKELIHOOD AND CONFIDENCE INTERVALS
 # Npw we plot the result
if(plot_bool == TRUE)
{pdf(file="approx_plot.pdf")
plot(log_likelihood_function)
abline(v = bottleneck_size, col="black" )  # Draws a verticle line at Nb value for which log likelihood is maximized
abline(v = CI_index_lower, col="green" ) # confidence intervals
abline(v = CI_index_upper, col="green" )
dev.off()
}

print("Bottleneck size")
print(bottleneck_size)
print("confidence interval left bound")
print(CI_index_lower)
print("confidence interval right bound")
print(CI_index_upper)


# 4_fit_models.r
# 20201207

# %%
fit_asd <- glm(converted ~
    sex_male +
    rescale(age) +
    race_black +
    race_asian +
    race_multi +
    ethnicity_latinx +
    psych_hx_first_degree +
    asd_dx +
    childhood_soc_sx +
    childhood_rep_sx +
    hypersensitivity_light +
    hypersensitivity_sound +
    hypersensitivity_touch,
    family = binomial(link = 'logit'),
    data = frame)

fit_asd_summary <- summary(fit_asd)
fit_asd_frame <- tidy(fit_asd, exponentiate=TRUE)

# %% [markdown]
# # ADHD symptoms as predictors of conversion

# %%
fit_adhd <- glm(converted ~
    sex_male +
    rescale(age) +
    race_black +
    race_asian +
    race_multi +
    ethnicity_latinx +
    psych_hx_first_degree +
    adhd_dx +
    childhood_att_sx,
    family = binomial(link = 'logit'),
    data = frame)

fit_adhd_summary <- summary(fit_adhd)
fit_adhd_frame <- tidy(fit_adhd, exponentiate=TRUE)

# %% [markdown]
# # Neurodevelopmental symptoms as predictors of conversion

# %%
fit_developmental <- glm(converted ~
    sex_male +
    rescale(age) +
    race_black +
    race_asian +
    race_multi +
    ethnicity_latinx +
    psych_hx_first_degree +
    asd_dx +
    adhd_dx +
    childhood_att_sx +
    childhood_soc_sx +
    childhood_rep_sx +
    hypersensitivity_light +
    hypersensitivity_sound +
    hypersensitivity_touch,
    family = binomial(link = 'logit'),
    data = frame)

fit_asd_df <-
    tidy(fit_asd, exponentiate=TRUE, conf.int=TRUE) %>%
    arrange(desc(estimate)) %>%
    write_excel_csv(here("r", "output", "models", "asd.csv"))

fit_adhd_df <-
    tidy(fit_adhd, exponentiate=TRUE, conf.int=TRUE) %>%
    arrange(desc(estimate)) %>%
    write_excel_csv(here("r", "output", "models", "adhd.csv"))

fit_developmental_df <-
    tidy(fit_developmental, exponentiate=TRUE, conf.int=TRUE) %>%
    arrange(desc(estimate)) %>%
    write_excel_csv(here("r", "output", "models", "developmental.csv"))


require(caret)
a <- read.csv("/Users/tom/projects-workspace/set-game/data/train-out-shape.csv", header = FALSE, col.names = c("label", "v1", "v2"))
a$label <- as.factor(a$label)
set.seed(1)
aFit <- train(label ~ ., data = a, method = "svmRadial", preProc = c("center", "scale"),
              tuneLength = 10,
              tr = trainControl(method = "repeatedcv", repeats = 5, classProbs = TRUE))
aFit

aFitKnn <- train(label ~ ., data = a, method = "knn", preProc = c("center", "scale"))
aFitKnn

# Try using the model to predict test data labels
testData <- read.csv("/Users/tom/projects-workspace/set-game/data/test-out-shape.csv", col.names = c("label", "v1", "v2"))
testData$label <- as.factor(testData$label)
testDataNoLabel <- testData[-c(1)]

predictions <- predict(aFitKnn, newdata = testDataNoLabel)
predictions

print(postResample(pred=predictions, obs=as.factor(testData$label)))

# Plot data
qplot(v1, v2, colour = label, data = a)


library(matrixTests)
case_sum<-psmelt(bac_pseq)%>%
  select(Sample,OTU,case,Abundance)%>%
  group_by(OTU,case)%>%
  pivot_wider(id_cols = c(Sample,case), names_from = OTU,values_from = Abundance)

dim(case_sum)
mat<-case_sum[,3:13848]
krus_case<-col_kruskalwallis(x =mat,g = case_sum$case)
welch_case<-col_oneway_welch(x=mat, g=case_sum$case)
krus_case_sig<-krus_case%>%filter(pvalue<0.01)%>%arrange(pvalue)
welch_case_sig<-welch_case%>%filter(pvalue<0.01)%>%arrange(pvalue)
dim(krus_case_sig)
dim(welch_case_sig)
write.table(krus_case,"krus_case.tsv",sep = "\t")
write.table(welch_case,"welch_case.tsv",sep = "\t")

#########################################
dmn_sum<-psmelt(bac_pseq)%>%
  select(Sample,OTU,dmn,Abundance)%>%
  group_by(OTU,dmn)%>%
  pivot_wider(id_cols = c(Sample,dmn), names_from = OTU,values_from = Abundance)

mat<-dmn_sum[,3:856]
krus_dmn<-col_kruskalwallis(x =mat,g = dmn_sum$dmn)
welc_dmnh<-col_oneway_welch(x=mat, g=dmn_sum$dmn)

krus_dmn_sig<-krus_dmn%>%filter(pvalue<0.01)%>%arrange(pvalue)
welch_dmn_sig<-welch_dmn%>%filter(pvalue<0.01)%>%arrange(pvalue)
welch_sig
dim(krus_dmn_sig)
dim(welch_dmn_sig)
krus_sig
write.table(krus,"krus_dmn.tsv",sep = "\t")

colnames(krus_sig)
colnames(krus_sig)
krus_sig_names<-intersect(rownames(krus_case_sig), rownames(krus_dmn_sig))
welch_sig_names<-intersect(rownames(welch_case_sig), rownames(welch_dmn_sig))
sig_names<-intersect(krus_sig_names,welch_sig_names)
#sig_names<-as_tibble(sig_names)
#colnames(sig_names)<-"names"

# library(matrixTests)
#
#
# case_sum<-psmelt(bac_pseq_prune_deeper2)%>%
#   select(Sample,OTU,case,Abundance)%>%
#   group_by(OTU,case)%>%
#   pivot_wider(id_cols = c(Sample,case), names_from = OTU,values_from = Abundance)
#
#
# mat<-case_sum[,3:856]
# krus_case<-col_kruskalwallis(x =mat,g = case_sum$case)
# welch_case<-col_oneway_welch(x=mat, g=case_sum$case)
# krus_case_sig<-krus_case%>%filter(pvalue<0.01)%>%arrange(pvalue)
# welch_case_sig<-welch_case%>%filter(pvalue<0.01)%>%arrange(pvalue)
# dim(krus_case_sig)
# dim(welch_case_sig)
# write.table(krus,"krus_case.tsv",sep = "\t")
#
#
# #########################################
# dmn_sum<-psmelt(bac_pseq_prune_deeper2)%>%
#   select(Sample,OTU,dmn,Abundance)%>%
#   group_by(OTU,dmn)%>%
#   pivot_wider(id_cols = c(Sample,dmn), names_from = OTU,values_from = Abundance)
#
#
# mat<-dmn_sum[,3:856]
# krus_dmn<-col_kruskalwallis(x =mat,g = dmn_sum$dmn)
# welc_dmnh<-col_oneway_welch(x=mat, g=dmn_sum$dmn)
#
# krus_dmn_sig<-krus_dmn%>%filter(pvalue<0.01)%>%arrange(pvalue)
# welch_dmn_sig<-welch_dmn%>%filter(pvalue<0.01)%>%arrange(pvalue)
# welch_sig
# dim(krus_dmn_sig)
# dim(welch_dmn_sig)
# krus_sig
# write.table(krus,"krus_dmn.tsv",sep = "\t")
#
# colnames(krus_sig)
# colnames(krus_sig)
# krus_sig_names<-intersect(rownames(krus_case_sig), rownames(krus_dmn_sig))
# welch_sig_names<-intersect(rownames(welch_case_sig), rownames(welch_dmn_sig))
# sig_names<-intersect(krus_sig_names,welch_sig_names)
# #sig_names<-as_tibble(sig_names)
# #colnames(sig_names)<-"names"
#
#
#
#
#
#
#
#
#
#
# library(dplyr)
# sig_bac_pseq_prune_deeper2<-prune_taxa(taxa = sig_names,x = bac_pseq_prune_deeper2)
# sig_bac_pseq_prune_deeper2
# count<-abundances(sig_bac_pseq_prune_deeper2)
# select <- order(rowMeans(count),decreasing=TRUE)
# select2<-sqrt((count)[select,])
# tmp<-rownames(select2)
# #select2$mol<-tmp
# select3<-as.table(select2)
# test<-t.test(select3)
# test
# library(matrixTests)
# library(genefilter)
# select3<-as_tibble(select2)%>%summarise(std=rowFtests(select2))%>% arrange(desc(std))
# select3
# select2
# select2$mol<-tmp
#
#
# select2
# select2<-as_tibble(select2)
# select2
# select2$mean<-rowMeans(select2)
# select3
# select2<-filter(.data = select2,rowMeans(select2)<10)
#
# sam<-data.frame(sample_data(sig_bac_pseq_prune_deeper2))
# df<-as.data.frame(sample_data(sig_bac_pseq_prune_deeper2))
# df<-as_tibble(df)
# df<-df%>%select(dmn, publication, sample_type,case)#,dmn,body_site)
# df
# df<-as.data.frame(df)
# df
#
# select2<-sqrt((count)[select,])
# dim(select2)
# colnames(select2) <- colnames(otu_table(bac_pseq_prune_deep))
# length(rownames(select2))
# length(row.names(df))
# row.names(df) <- colnames(select2)
#
#
# library(ggsci)
# mypal <- pal_aaas("default", alpha = 1)(10)
# mypal
# library("scales")
# library(RColorBrewer)
# library(viridis)
# library(pheatmap)
# df_row<-as.data.frame(fitted(best))
# df<-data.frame(df)
# df
# colnames(df)<-c("dmm_cluster", "Publication","Sample_Type","Case")
# # Specify colors
# ann_colors = list(
#   dmm_cluster=c("1"="#3B4992FF","2"="#EE0000FF","3"="#008B45FF","4"="#631879FF","5"="#008280FF"),
#   Publication=c("Xiong"="#008280FF", "Shen"="#631879FF","Michalovich"="#BB0021FF","Chen"="#3B4992FF","Wu"="#EE0000FF","Zhou"="orange","Ren"="#111111"),
#   Sample_Type =c("COVID_19"="firebrick","Healthy"="forestgreen","Community_acquired_pneumonia"="dodgerblue4",
#                  "Obese_Asthma"="goldenrod3",
#                  "Obese_Smoker"="goldenrod4",
#                  "Obese"="goldenrod1",
#                  "Asthma"= "darkorange2",
#                  "Asthma_Smoker"="darkorange4",
#                  "Asthma_Ex_smoker"="darkorange3",
#                  "Smoker"="gray27",
#                  "Obese_Asthma_Smoker"="black"),
#   Case=c("COVID19"="firebrick", "Control_Healthy"="forestgreen","Control_Sick"="dodgerblue4"))
#
#
# xx <- pheatmap(mat = select2,
#                color = colorRampPalette(rev(brewer.pal(n = 7, name ="RdYlBu")))(1000),
#                annotation_col=df,
#                annotation_colors = ann_colors,
#                clustering_distance_rows = "euclidean",
#                clustering_distance_cols = "euclidean",
#                annotation_row = df_row)
# dim(select2)


#' @title
#' Reduced-rank ridge regression with rank and tuning parameter selected by cross validation
#'
#' @description
#' This function performs reduced-rank ridge regression with the rank and the
#' tuning parameter selected by cross validation.
#'
#' @usage
#' RRS.cv(Y, X, nfold = 10, rankmax = min(dim(Y), dim(X)), nlam = 100,
#'         lambda = seq(0, 100, length = nlam), norder = NULL,
#'         nest.tune = FALSE, fold.drop = 0)
#'
#' @param Y response matrix.
#' @param X design matrix.
#' @param nfold the number of folds used in cross validation. Default is 10.
#' @param rankmax the maximum rank allowed.
#' @param nlam the number of tuning parameter candidates. Default is 100.
#' @param lambda the tuning sequence of length \code{nlam}.
#' @param norder a vector of length n that assigns samples to multiple folds
#'               for cross validation. Default is NULL and then \code{norder} will be
#'               generated randomly.
#' @param nest.tune a logical value to specify whether to tune the rank and lambda
#'                  in a nested way. Default is FALSE.
#' @param fold.drop the number of folds to drop. Default is 0.
#'
#'
#' @return The function returns a list:
#'   \item{cr_path}{a matrix displays the path of model selection.}
#'   \item{C}{the estimated low-rank coefficient matrix.}
#'   \item{rank}{the selected rank.}
#'   \item{lam}{the selected tuning parameter for ridge penalty.}
#'
#' @references Mukherjee, A., & Zhu, J. (2011).
#' Reduced Rank Ridge Regression and Its Kernel Extensions.
#' Statistical analysis and data mining,
#' 4(6), 612–622.
#'
# @importFrom rrpack rrs.fit
#' @export
RRS.cv<-function(Y, X, nfold = 10, rankmax = min(dim(Y), dim(X)), nlam = 100,
                     lambda = seq(0, 100, length = nlam), norder = NULL, nest.tune = FALSE,
                     fold.drop = 0)
{
  p <- ncol(X)
  q <- ncol(Y)
  n <- nrow(Y)
  ndel <- round(n/nfold)
  if (is.null(norder)) {
    norder <- sample(1:n, n)
  }
  cr_path <- array(dim = c(nlam, rankmax + 1, nfold), NA)
  for (f in 1:nfold) {
    if (f != nfold) {
      iddel <- norder[(1 + ndel * (f - 1)):(ndel * f)]
    }
    else {
      iddel <- norder[(1 + ndel * (f - 1)):n]
    }
    ndel <- length(iddel)
    nf <- n - ndel
    Xf <- X[-iddel, ]
    Xfdel <- X[iddel, ]
    Yf <- Y[-iddel, ]
    Yfdel <- Y[iddel, ]
    for (ll in 1:nlam) {
      ini <- rrs.fit(Yf, Xf, lambda = lambda[ll], nrank = rankmax)
      C_ls <- ini$coef.ls
      A <- ini$A
      tempFit <- Xfdel %*% C_ls
      tempC <- matrix(nrow = nrow(A), ncol = nrow(A), 0)
      for (i in 1:rankmax) {
        tempC <- tempC + A[, i] %*% t(A[, i])
        cr_path[ll, i + 1, f] <- sum((Yfdel - tempFit %*%
                                        tempC)^2)
      }
      cr_path[ll, 1, f] <- sum(Yfdel^2)
    }
  }
  index <- order(apply(cr_path, 3, sum))[1:ifelse(nfold > 5,
                                                  nfold - fold.drop, nfold)]
  crerr <- apply(cr_path[, , index], c(1, 2), sum)/length(index) *
    nfold
  minid <- which.min(crerr)
  minid2 <- ceiling(minid/nlam)
  rankest <- minid2 - 1
  minid1 <- minid - nlam * (minid2 - 1)
  if (nest.tune == TRUE) {
    lambda <- exp(seq(log(lambda[max(minid1 - 1, 1)] + 1e-04),
                      log(lambda[min(minid1 + 1, nlam)]), length = nlam))
    cr_path <- array(dim = c(nlam, rankmax + 1, nfold), NA)
    ndel <- round(n/nfold)
    for (f in 1:nfold) {
      if (f != nfold) {
        iddel <- norder[(1 + ndel * (f - 1)):(ndel *
                                                f)]
      }
      else {
        iddel <- norder[(1 + ndel * (f - 1)):n]
        ndel <- length(iddel)
      }
      nf <- n - ndel
      Xf <- X[-iddel, ]
      Xfdel <- X[iddel, ]
      Yf <- Y[-iddel, ]
      Yfdel <- Y[iddel, ]
      for (ll in 1:nlam) {
        ini <- rrs.fit(Yf, Xf, lambda = lambda[ll], nrank = rankmax)
        C_ls <- ini$coef.ls
        A <- ini$A
        tempFit <- Xfdel %*% C_ls
        tempC <- matrix(nrow = nrow(A), ncol = nrow(A),
                        0)
        for (i in 1:rankmax) {
          tempC <- tempC + A[, i] %*% t(A[, i])
          cr_path[ll, i + 1, f] <- sum((Yfdel - tempFit %*%
                                          tempC)^2)
        }
        cr_path[ll, 1, f] <- sum(Yfdel^2)
      }
    }
    index <- order(apply(cr_path, 3, sum))[1:ifelse(nfold >
                                                      5, nfold - fold.drop, nfold)]
    crerr <- apply(cr_path[, , index], c(1, 2), sum)/length(index) *
      nfold
    minid <- which.min(crerr)
    minid2 <- ceiling(minid/nlam)
    rankest <- minid2 - 1
    minid1 <- minid - nlam * (minid2 - 1)
  }
  if (rankest == 0) {
    list(cr_path = cr_path, CRE = crerr, norder = norder,
         C = matrix(nrow = p, ncol = q, 0), rank = 0)
  }
  else {
    fit <- rrs.fit(Y, X, lambda = lambda[minid1], nrank = rankmax)
    C_lslam <- fit$coef.ls
    A <- fit$A
    list(cr_path = cr_path, CRE = crerr, ID = c(minid1, minid2),
         norder = norder, C = C_lslam %*% A[, 1:rankest] %*%
           t(A[, 1:rankest]), rank = rankest, lam = lambda[minid1])
  }
}


>reversalGame()
Welcome to the Number Reversal Game!
Sort the numbers into ascending order by repeatedly
reversing the first n digits, where you specify n.

Trial 01  #  4 3 2 1 7 9 8 5 6  #  Flip how many? 7
Trial 02  #  8 9 7 1 2 3 4 5 6  #  Flip how many? 2
Trial 03  #  9 8 7 1 2 3 4 5 6  #  Flip how many? 9
Trial 04  #  6 5 4 3 2 1 7 8 9  #  Flip how many? 6
Well done.  You needed 4 flips.


# Demo 1, Part I
# Basics of R
# Solutions to exercises
# Heini Saarimäki, 18.9.2014

# -----

# 1. Very basics

# Question 1
10+1
# 11

# Question 2
10-1
10*2
5/2
# these work as expected

# Question 3
10+1/2	# 10.5
(10+1)/2	# 5.5
# arithmetic operations performed from left to right, * and / first, then + -
# change this order with brackets

# Question 4
x <- 1
x
# output is the value assigned to the variable

# Question 5
y <- (20/5)+100
z <- x+y
z		# 105

# Question 6
100 -> a
a
# direction of the arrow matters
# does not apply with = :
100 = a	# error!

# -----

# 2. Data types

# Question 7
c(10,20,30)+1
# results in a vector with values 11 21 31

# Question 8
my.vector <- c(10,20,30)+1
my.vector

# Question 9
40:100

# -----

# 3. Data structures

# Question 10
vector1 <- seq(1,20,by=0.5)
vector1
vector2 <- seq(1,20,length=5)
vector2
# adding the named argument "by" creates a sequence with steps increasing based on the value given
# adding "length" creates a sequence with the length based on the value given

# Question 11
rep(1:5, times=2)
rep(1:5, times=c(3,1,1,5,2))
rep(1:5, each=3)
#argument "times" with scalar input repeats the sequence 1:5
#argument "times" with vector input defines how many times each element of the sequence 1:5 is repeated
#argument "each" repeats each element of the sequence

# Question 12
"a":"b"			# error! : cannot be used with characters
c("a", "b")			# c works
seq("a", "b", by=10)	# error! seq cannot be used
rep(c("a","b"), each=3)	# rep works

# Question 13
m <- 1:10
n <- seq(2,20, by=2)
matrix(m, nrow=2, ncol=5)
matrix(m, nrow=2, ncol=5, byrow=TRUE)
cbind(m,n)
rbind(m,n)
# "matrix" creates a matrix from a given set of values, columnwise by default
# "cbind" and "rbind" bind vectors together as columns and rows, respectively

# Question 14
AgeWeight <- read.csv("http://becs.aalto.fi/~heikkih3/age_weight.csv")
head(AgeWeight)
# MALE is coded as 0's and 1's

# Question 15
head(AgeWeight)
# 59 years

# Question 16
tail(AgeWeight)
# tail shows the last rows of the data

# Question 17
?head
head(AgeWeight, 10)

# Question 18
dim(AgeWeight)	# 100, 6
ncol(AgeWeight)	# 6
nrow(AgeWeight)	# 100
# dim returns rows first, then columns

# Question 19
AgeWeight$AGE
class(AgeWeight$AGE)
# age is a numeric variable (integer)

# Question 20
?tolower
tolower("CAR")						# example
ageweight <- AgeWeight					# copy data to a new data frame
names(ageweight) <- tolower(names(AgeWeight)) 	# change variable names to lower case
names(ageweight)						# check the results

# Question 21
summary(AgeWeight)

# -----

# Question 22
m <- c(48,32,78,22,16,60)
m[2:5]
m[c(2,3,4,5)]

# Question 23
m[length(m)-1]

# Question 24
AgeWeight[c(2,10,21),]

# Question 25
AgeWeight[c(1,2,30:45),]

# Question 26
AgeWeight[,c(3:4)]

# Question 27
AgeWeight[54,3]

# Question 28
AgeWeight[, c("WEIGHT", "AGE")]

# Question 29
AgeWeight[c(91:100), c("MALE", "AGE")]

# Question 30
100 + 35/(23*3) > 110 - 16/5.5
# FALSE

# Question 31
which(AgeWeight["AGE"] > 60)		# list the participants
AgeWeight[AgeWeight$AGE > 60,]	# separate the rows for these participants

# Question 32
AgeWeight[10,7]		# impossible, only 6 columns!
AgeWeight[10,6]		# access the 10th row in the 6th column instead
AgeWeight[4:5,2:3]	# rows 4:5, columns 2:3
AgeWeight[4:5,]		# rows 4:5, all columns
AgeWeight[c(4,6),c(1,3)]# rows 4 and 6, columns 1 and 3
AgeWeight[-(4:5),1]	# all rows except for 4 and 5, column 1

# Question 33
names(AgeWeight)				# cannot access 7th column
AgeWeight[10,"SMOKE2"]			# access the 10th row, 6th column instead
AgeWeight[4:5, c("AGE", "WEIGHT")]	# rows 4:5, columns 2:3
AgeWeight[c(4,6), c("MALE", "WEIGHT")] # rows 4 and 6, columns 1 and 3

# Question 34
AgeWeight[AgeWeight$MALE == 1,]		# test it works
age_weight.male <- AgeWeight[AgeWeight$MALE == 1,]	# stores the results in a new data frame
summary(age_weight.male)		# check the new data frame

# -----

# Question 35
x <- c(0,2,4,6,8,10)
y <- c(1,3,5,7,9,11)
x+y

# Question 36
AgeWeight$BMI <- (AgeWeight$WEIGHT)/((AgeWeight$HEIGHT)^2)
head(AgeWeight)

# Question 37
sum(x)			# test by using the newly created x (above)
sum(AgeWeight$WEIGHT)	# or using a variable
# the result is a sum of all the elements in the vector (or variable)

# Question 38
# lots of them: c, rep, seq, matrix, head, tail, summary, names, class, dim, ...
ls()

# Question 39
?sort
# sorts the elements of a vector in ascending or descending order

# Question 40
# packages are collections of ready-made functions
# usage of packages is two-folded:
# 1. you need to install the package
install.package('psych')
# 2. you need to load the package for the use of your current R session
library('psych')

# Question 41
range.size <- function(X) {
	F = max(X) - min(X)
	return(F) }

# Question 42
AgeWeight$SMOKE1 == "yes"
AgeWeight[which(AgeWeight$SMOKE1=="no" & AgeWeight$MALE == 1),]
AgeWeight[, "WEIGHT"]
range.size(AgeWeight[which(AgeWeight$SMOKE1=="no" & AgeWeight$MALE==1), "WEIGHT"])
# answer: range is 126.19 kg

# Question 43
range.size(c(1,5,10)) == 9			# TRUE
range.size(-234:119) == 353			# TRUE
range.size(c(14.3, 5.6, 22.1)) == 16.5	# TRUE
# yes! my function works.

# Question 44
diff.height <- range.size(AgeWeight$HEIGHT)
diff.weight <- range.size(AgeWeight$WEIGHT)
diff.bmi <- range.size(AgeWeight$BMI)
data.frame(diff.height, diff.weight, diff.bmi)

# Question 45
AgeWeightDifferences <- data.frame(diff.height, diff.weight, diff.bmi)	# store results
?write.csv
write.csv(AgeWeightDifferences, "age_weight_differences.csv")		# saves the data frame in a .csv file


# <-- encoding UTF-8 -->
# Empirical study on NHSS dataset (county level)
# -------------------------------------
## DOC STRING
#
#
# Tianhao Zhao (GitHub: Clpr)
# Dec 2018
# -------------------------------------

# -------------------------------------
## SECTION 0: ENVIRONMENT
library(sqldf)  # sql enquiry
library(openxlsx)  # easy xlsx IO
source("./src/mathtools.r")  # math tools, e.g. Lorenz, Theil, descriptive stats
source("./src/mapplots.r")  # tools of map plots, using ggplot2
# environment par dict
envNHSS$Output <- "./output/proc_2_NHSS/"  # alter output directory

# -------------------------------------
## SECTION 1: GENERAL DESCRIPTIVE STATISTICS
cat("\nGeneral descriptive statistics of NHSS dataset:\n")
cat("(please note: the income now is the residuals of income ~ edu)\n")
cat("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!")
cat("PLEASE NOTE: because we have normalized PCA components, we only do descriptive statistics for income & edu!!!!!!")
cat("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!")
# --------------
li_Descript_NHSS <- list()  # a list of descriptive statistics
for(tmpYname in envNHSS$Ynames){
    # 1.1 get a namelist of all numeric variables, both Y and Xcore
    tmp <- c( tmpYname, envNHSS$Xcore )
    li_Descript_NHSS[[tmpYname]] <- func_DescrStat( li_Dat_NHSS[[tmpYname]][,tmp] )
    # 1.2 print
    print(li_Descript_NHSS[[tmpYname]]); cat("-----------------------------------------\n")
}
# output to xlsx
openxlsx::write.xlsx(li_Descript_NHSS, paste(sep="",envNHSS$Output,"Descript_NHSS.xlsx")  )

# -------------------------------------
## SECTION 2: COUNTY-LEVEL LORENZ CURVE & GINI COEF
# NOTE: in this section, we use counties as units/individuals to plot Lorenz curves in every year (98,03,08),
#       meanwhile, Gini coefficients in the three years are calculated;
#       later, in following sections, we will add other inequlity indices

# 2.0 prepare a df for Gini coefs
df_Gini_NHSS <- data.frame(
    year = c(1998, 2003, 2008),   # years
    counties = c( sum(df_NHSS$year == 1998),sum(df_NHSS$year == 2003),sum(df_NHSS$year == 2008)  ),  # number of counties in every year's data
    illnessratio = NA, # prevalence
    illnessday = NA,
    chronicratio = NA
)

# 2.1 use functions in mathtools.r to compute Lorenz Curve & Gini coefficients
# NOTE: please refer to mathtools.r for how we calculated the both
#       and, if you want to see the plotting of Lorenz Curve, you may DIY (using tmp$LorenzX and tmp$LorenzY)
for(tmpYear in df_Gini_NHSS$year){
    for(tmpYname in envNHSS$Ynames){
        # 2.1.1 compute Lorenz Curve & Gini in specific year
        # eval(parse(text=paste(sep="",
        #     "tmp <- LorenzCurve( df_NHSS$",tmpYname,"[df_NHSS$",envNHSS$flagT," == ",tmpYear,"] )"
        # )))
        tmp <- li_Dat_NHSS[[tmpYname]]
        tmp <- LorenzCurve( tmp[ tmp[,envNHSS$flagT] == tmpYear ,tmpYname] )
        # 2.1.2 save Gini coef
        df_Gini_NHSS[,tmpYname][df_Gini_NHSS$year == tmpYear] <- tmp$GiniIdx
    }
}
# print & output to xlsx
print(df_Gini_NHSS)

# NOTE: the results will be output to a csv file with other kinds of indices, later

# -------------------------------------
## SECTION 3: COUNTY-LEVEL THEIL I & II INDEXES
# NOTE: in this section, we use counties as units/individuals to calculate Theil-I & Theil-II indexes.
#       meanwhile, indices in the three years are calculated;
#       later, in following sections, we will add other inequlity indices

# 3.0 prepare two df
df_Theil1_NHSS <- data.frame(
    year = c(1998, 2003, 2008),   # years
    counties = c( sum(df_NHSS$year == 1998),sum(df_NHSS$year == 2003),sum(df_NHSS$year == 2008)  ),  # number of counties in every year's data
    illnessratio = NA, # prevalence
    illnessday = NA,
    chronicratio = NA
)
df_Theil2_NHSS <- df_Theil1_NHSS

# 3.1 use functions in mathtools.r to do computing
for(tmpYear in df_Gini_NHSS$year){  # loop on years
    for(tmpYname in envNHSS$Ynames){  # loop on health outcomes
        # slice a temp dataset
        tmpdf <- li_Dat_NHSS[[tmpYname]]
        # 3.1.1 compute Theil-I & Theil-II in a specific year
        tmp <- Theil( tmpdf[,tmpYname][tmpdf[,envNHSS$flagT] == tmpYear], Type = "T" )
        df_Theil1_NHSS[,tmpYname][ df_Theil1_NHSS$year == tmpYear ] <- tmp
        tmp <- Theil( tmpdf[,tmpYname][tmpdf[,envNHSS$flagT] == tmpYear], Type = "L" )
        df_Theil2_NHSS[,tmpYname][ df_Theil2_NHSS$year == tmpYear ] <- tmp
    }
}

# 3.2 print info
cat("\nThe county-level Theil-I type index in every year of NHSS dataset are:\n")
print(df_Theil1_NHSS)
cat("\nThe county-level Theil-II type index in every year of NHSS dataset are:\n")
print(df_Theil2_NHSS)

# NOTE: the results will be output to a csv file with other kinds of indices, later

# -------------------------------------
## SECTION 4: COUNTY-LEVEL COEF OF VARIANCE (C.V.) & VARIANCE
# NOTE: in this section, we use counties as units/individuals to calculate C.V. & variances
#       meanwhile, indices in the three years are calculated;

# 4.0 prepare two df
df_CoefVar_NHSS <- data.frame(
    year = c(1998, 2003, 2008),   # years
    counties = c( sum(df_NHSS$year == 1998),sum(df_NHSS$year == 2003),sum(df_NHSS$year == 2008)  ),  # number of counties in every year's data
    illnessratio = NA, # prevalence
    illnessday = NA,
    chronicratio = NA
)
df_Variance_NHSS <- df_CoefVar_NHSS

# 4.1 calculation
for(tmpYear in df_Gini_NHSS$year){  # loop on years
    for(tmpYname in envNHSS$Ynames){  # loop on health outcomes
        # slice a temp dataset
        tmpdf <- li_Dat_NHSS[[tmpYname]]
        # 4.1.1 get data vector
        tmp <- tmpdf[,tmpYname][ tmpdf[,envNHSS$flagT] == tmpYear ]
        df_Variance_NHSS[,tmpYname][df_Variance_NHSS$year == tmpYear] <- var(tmp)
        df_CoefVar_NHSS[,tmpYname][df_CoefVar_NHSS$year == tmpYear] <- sd(tmp) / mean(tmp)
    }
}

# 4.2 print info
cat("\nThe county-level coef of variance in every year of NHSS dataset are:\n")
print(df_CoefVar_NHSS)
cat("\nThe county-level variances in every year of NHSS dataset are:\n")
print(df_Variance_NHSS)

# -------------------------------------
## SECTION 5: COLLECT INEQUALITY INDICES & OUTPUT TO CSV
# NOTE: in this section, we firstly bind all kinds of inequality indices to a single dframe,
#       then, output the large dframe to a csv file

# 5.1 table joining
df_InequalIdx_NHSS <- data.frame( Index = rep(c("Gini","Theil-I","Theil-II","Variance","Coef of Variance"), each = 3) )
df_InequalIdx_NHSS <- cbind(
    df_InequalIdx_NHSS, rbind( df_Gini_NHSS, df_Theil1_NHSS, df_Theil2_NHSS, df_Variance_NHSS, df_CoefVar_NHSS )
)
# 5.2 garbage recycling
rm( df_Gini_NHSS, df_Theil1_NHSS, df_Theil2_NHSS, df_Variance_NHSS, df_CoefVar_NHSS )
rm( tmpYear, tmpYname, tmpdf )
# 5.3 output to csv
write.csv( df_InequalIdx_NHSS, file = paste(sep="",envNHSS$Output,"InequalityIdx_NHSS.csv") )

# -------------------------------------
## INTERVAL: MATCH CITY GIS DATA WITH NHSS DATASET
# NOTE: in this section, we merge the China city/County GIS data with df_NHSS;
#       the data have been preloaded by mapplots.r, and named as MapGIScity;
#       in the next section, the dataset will be used to plot
# NOTE: we do not plot PCs -> health outcomes, therefore, just use df_NHSS!
tmpdf <- plyr::join( df_NHSS, MapGIScity[,c("ID","long","lat")], by = "ID" )  # we use GB (country standard) codes of city/county to match by
tmpdf <- na.omit(tmpdf)

cat("\nPlotting ...\n")
# -------------------------------------
## SECTION 6: COLORED MAPS OF HEALTH OUTCOMES
# NOTE: in this section, we plot colored maps for every health outcomes,
#       where every health outcome (in three years) are seen as a pool data,
#       to see the (geographic) distribution (descriptively, intuitively) of the outcomes;
#       using ggplot2, and tools in mapplots.r
#       finally, we output these maps/figures to PDF figures
# NOTE: please refer to mapplots.r for more information & technical details
# NOTE: in final plots, the size of circle indicates the values of independents, where the color indicates the values of health outcomes
#       the plots work to display the relationship between X & Y
# --------
# 6.1 colored maps
# 1998,2003,2008 data are now seen as a pool dataset
for(tmpYname in envNHSS$Ynames){
    # 6.1.1 temp slice: pooled health outcome & province tags
    tmp <- tmpdf[,c(tmpYname,envNHSS$flagProv, "ID", "long", "lat" )]
        # # 6.1.2 averaging by procinve tags (weighted by sample size/population of each county)
        # tmp <- sqldf::sqldf(paste(sep="",
        #       "SELECT DISTINCT SUM(",envNHSS$flagSampleSize," * ",tmpYname,") / SUM(",envNHSS$flagSampleSize,") AS ",tmpYname,
        #       ", ",envNHSS$flagProv," FROM tmp GROUP BY ",envNHSS$flagProv
        # ))
        # 6.1.3 using mapplots.r to get an instance of current map figure
        # eval(parse(text=paste(sep="",
        #     "tmpfig <- func_MapProv( tmp$",tmpYname,", tmp$",envNHSS$flagProv,", vecName = \"",tmpYname,"\" )"
        # )))
    # income -> health outcome
    tmpfig1 <- func_MapCityXY( tmpdf$income, tmpdf[,tmpYname], tmpdf$lat, tmpdf$long,
                               Xname = "income", Yname = tmpYname , FontSize = 5,
                               ColorScale = c("skyblue","red"), CircleScale = c(2,15) )
    # edu -> health outcome
    tmpfig2 <- func_MapCityXY( tmpdf$edu, tmpdf[,tmpYname], tmpdf$lat, tmpdf$long,
                               Xname = "edu", Yname = tmpYname , FontSize = 5,
                               ColorScale = c("skyblue","red"), CircleScale = c(2,15) )
    # output figures
    eval(parse(text=paste(sep="",
       "func_SaveMap2PDF( tmpfig1, \"",envNHSS$Output,"Map_income_2_",tmpYname,".pdf\" ) "
    )))
    eval(parse(text=paste(sep="",
       "func_SaveMap2PDF( tmpfig2, \"",envNHSS$Output,"Map_edu_2_",tmpYname,".pdf\" ) "
    )))
}

# 6.2 print info
cat("\n We have created colored maps for health outcomes and output them to the assigned output directory as PDF figures\n")

# --------------------------------------
# GARBAGE COLLECTION
rm( tmp, tmpfig1, tmpfig2, tmpYname, tmpdf )

#
# # -------------------------------------
# ## SECTION 7: COLORED MAPS OF CORE INDEPENDENTS (INCOME & EDU)
# # NOTE: please refer to mapplots.r for more information & technical details
#
# # 7.1 colored maps
# # 1998,2003,2008 data are now seen as a pool dataset
# for(tmpXname in envNHSS$Xcore){
#     # 7.1.1 temp slice: pooled health outcome & province tags
#     tmp <- df_NHSS[,c(tmpXname,envNHSS$flagProv,envNHSS$flagSampleSize)]
#     # 7.1.2 averaging by procinve tags
#     tmp <- sqldf::sqldf(paste(sep="",
#                               "SELECT DISTINCT SUM(",envNHSS$flagSampleSize," * ",tmpXname,") / SUM(",envNHSS$flagSampleSize,") AS ",tmpXname,
#                               ", ",envNHSS$flagProv," FROM tmp GROUP BY ",envNHSS$flagProv
#     ))
#     # 7.1.3 using mapplots.r to get an instance of current map figure
#     eval(parse(text=paste(sep="",
#                           "tmpfig <- func_MapProv( tmp$",tmpXname,", tmp$",envNHSS$flagProv,", vecName = \"",tmpXname,"\" )"
#     )))
#     # 7.1.4 output figures
#     eval(parse(text=paste(sep="",
#                           "func_SaveMap2PDF( tmpfig, \"",envNHSS$Output,"Map_",tmpXname,".pdf\" ) "
#     )))
# }
#
# # 7.2 print info
# cat("\nWe have created colored maps for core independents (income & edu) and output them to the assigned output directory as PDF figures\n")


library(scatterplot3d)
dat <- read.csv("Screen.csv")
Fig <- scatterplot3d(dat$x,
              dat$y,
              dat$z,
              main="Screen",
              color=dat$Color, pch=20, cex.symbols=0.7, # filled blue circles
              #type="h", lty.hplot=3,       # lines to the horizontal plane
              scale.y=.5,
              xlab="VCR- Rel. Viab. ( Norm. to miR-NC)",
              ylab="VCR+ Rel. Viab. ( Norm. to miR-NC+VCR)",
              zlab="VCR+ Rel. Viab. ( Norm. to VCR-)",
              cex.lab=0.7, cex.axis = 0.7, box = 0)


source("scRNA_func.r")

library(Seurat)
library(ggplot2)
library(ggpubr)
library(scales)

finalList<-readRDS(parFile1)

obj<-finalList$obj

groups_tbl<-read.table(parSampleFile2, sep="\t", stringsAsFactors = F)
groups=split(groups_tbl$V2, groups_tbl$V1)
obj$group = unlist(groups[obj$orig.ident])

ngroup=length(unique(groups_tbl$V2))

genes_tbl<-read.table(parSampleFile1, sep="\t", stringsAsFactors = F)
gene=genes_tbl$V1[1]
for (gene in genes_tbl$V1){
  gene_list<-unlist(strsplit(gene, '/'))
  if(length(gene_list) != 2){
    stop(paste0(gene, " is not valid for gene ratio localization map."))
  }

  gene1 = gene_list[[1]]
  gene2 = gene_list[[2]]

  gdata<-FetchData(object = obj, gene_list)
  gdata$ratio = gdata[,gene1] - gdata[,gene2]
  coords<-data.frame(obj@reductions$umap@cell.embeddings)
  gdata<-cbind(coords, data.frame(group=obj$group), gdata)
  gdata1<-subset(gdata, gdata$ratio == 0)
  gdata2<-subset(gdata, gdata$ratio < 0)
  gdata3<-subset(gdata, gdata$ratio > 0)
  gdata_sort_1<-rbind(gdata1, gdata2, gdata3)
  gdata_sort_2<-rbind(gdata1, gdata3, gdata2)

  png(filename=paste0(gene1, "_vs_", gene2, ".feature_plot.1.all.png"), width= 2400, height=2000, res=300)
  g<-ggplot(gdata_sort_1, aes(UMAP_1, UMAP_2, col=ratio)) +
    geom_point(shape=1) +
    scale_color_gradient2(midpoint = 0, low = "green", mid = "gray",
                        high = "red", space = "Lab", limits=c(min(gdata$ratio), max(gdata$ratio))) +
    theme_bw() +
    theme(strip.background=element_rect(fill="white"),
      panel.grid.major = element_blank(),
      panel.grid.minor = element_blank()
    ) + labs(color=paste0("log(", gene, ")"))
  print(g)
  dev.off()

  png(filename=paste0(gene1, "_vs_", gene2, ".feature_plot.1.group.png"), width= ngroup * 2000 + 400, height=2000, res=300)
  g<-g + facet_grid(~group)
  print(g)
  dev.off()

  png(filename=paste0(gene1, "_vs_", gene2, ".feature_plot.2.all.png"), width= 2400, height=2000, res=300)
  g<-ggplot(gdata_sort_2, aes(UMAP_1, UMAP_2, col=ratio)) +
    geom_point(shape=1) +
    scale_color_gradient2(midpoint = 0, low = "green", mid = "gray",
                          high = "red", space = "Lab", limits=c(min(gdata$ratio), max(gdata$ratio))) +
    theme_bw() +
    theme(strip.background=element_rect(fill="white"),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank()
    ) + labs(color=paste0("log(", gene, ")"))
  print(g)
  dev.off()

  png(filename=paste0(gene1, "_vs_", gene2, ".feature_plot.2.group.png"), width= ngroup * 2000 + 400, height=2000, res=300)
  g<-g + facet_grid(~group)
  print(g)
  dev.off()
}


#locs <- read.csv("data/radiosonde_bigf_locs.csv", stringsAsFactors=FALSE)
#locs <- subsmbr

locs <- get_radiosonde_matches()

locs$n <- rep(NA, nrow(locs))
locs$rmse <- rep(NA, nrow(locs))
locs$corr <- rep(NA, nrow(locs))
locs$m <- rep(NA, nrow(locs))
#locs$c <- rep(NA, nrow(locs))
locs$r2 <- rep(NA, nrow(locs))
locs$e_mean <- rep(NA, nrow(locs))
locs$e_sd <- rep(NA, nrow(locs))
locs$perc_e_mean <- rep(NA, nrow(locs))
locs$perc_e_sd <- rep(NA, nrow(locs))

#locs <- locs[locs$run == 1,]

mlist.radiosonde = list()

for (i in 1:nrow(locs))
{
  l <- locs[i,]
  #bigf_names <- strsplit(l$bigf_names, ", ")[[1]]

  print(paste("###### Running validation for", l$radiosonde, "and", l$bigf))
  m.temp <- radiosonde_bigf_merge(l$radiosonde, tolower(l$bigf))

  if (is.na(m.temp[1]) && length(m.temp) == 1)
  {
    locs[i,]$rmse <- NA
    locs[i,]$m <- NA
    #locs[i,]$c <- NA
    locs[i,]$corr <- NA
    locs[i,]$r2 <- NA
    locs[i,]$n <- NA
    locs[i,]$e_mean <- NA
    locs[i,]$e_sd <- NA
    locs[i,]$perc_e_mean <- NA
    locs[i,]$perc_e_sd <- NA

  }
  else
  {
    # Calculate percentage error
    m.temp$perc_e <- (m.temp$error / m.temp$pwc) * 100

    locs[i,]$rmse <- rmse(m.temp$error)
    model <- lm(m.temp$pwc ~ m.temp$iwv + 0)
    locs[i,]$m <- model$coefficients[1]
    #locs[i,]$c <- model$coefficients[1]
    locs[i,]$r2 <- summary(model)$r.squared
    locs[i,]$e_mean <- mean(m.temp$error)
    locs[i,]$e_sd <- sd(m.temp$error)
    locs[i,]$perc_e_mean <- mean(m.temp$perc_e)
    locs[i,]$perc_e_sd <- sd(m.temp$perc_e)

    locs[i,]$corr <- cor(m.temp$pwc, m.temp$iwv)

    locs[i,]$n <- nrow(m.temp)

    # Old code from before 1st Sept
    #mlist.radiosonde[[bigf_names[1]]] = m.temp
    mlist.radiosonde[[l$bigf]] = m.temp
  }

}

# Remove the src_id column, not needed any more
val.radiosonde <- na.omit(locs)
val.radiosonde$src_id <- NULL
val.radiosonde$bigf <- tolower(val.radiosonde$bigf)
val.radiosonde$radiosonde <- tolower(val.radiosonde$radiosonde)

#val.radiosonde <- val.radiosonde[!is.na(val.radiosonde$rmse),]

l <- lapply(mlist.radiosonde, coredata)
m.radiosonde <- do.call('rbind', l)
m.radiosonde <- as.data.frame(m.radiosonde)

cache('val.radiosonde')
cache('m.radiosonde')
cache('mlist.radiosonde')


#!/usr/bin/env Rscript --vanilla --slave
# Plot site discrepancy

# get the input VCF tabular format, assert that sites must have AC > 0
vcf <- subset(read.table(pipe('cat /dev/stdin'), header=T), AC > 0)

filename <- commandArgs(TRUE)[1]
tag <- commandArgs(TRUE)[2]

tag.has_variant <- paste(tag, '.has_variant', sep='')

vcf.numberOfSites <- length(vcf$AC)
vcf.sitesTruePositive <- mean(vcf[, tag.has_variant])

# false detection count
x <- cbind(by(vcf$AC, vcf$AC, function(i) length(i)))

byac <- data.frame(ac=as.numeric(rownames(x)), sites=as.vector(x))

# count true positive sites
byac$site_tpc <- as.vector(cbind(by(vcf[, tag.has_variant], vcf$AC, function(i) sum(i))))
# fpc == false detection count
byac$site_fpc <- byac$sites - byac$site_tpc
# site detection fpr is 1 - true positive rate
byac$site_fpr <- 1 - ( byac$site_tpc / byac$sites )

#byac$site_fprlt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) mean(subset(byac, ac <= i, select=site_fpr)))))
byac$site_fprlt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
    s <- subset(byac, ac <= i, select=c(site_fpc, sites))
    return(sum(s$site_fpc) / sum(s$sites))
})))

#byac$site_fprgt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) mean(subset(byac, ac >= i, select=site_fpr)))))
byac$site_fprgt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
    s <- subset(byac, ac >= i, select=c(site_fpc, sites))
    return(sum(s$site_fpc) / sum(s$sites))
})))

byac$cfs <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) sum(subset(byac, ac <= i, select=sites)) / length(vcf$AC))))

pdf(paste(filename, '.', tag, '.site_FDR.vs.AC.smooth.pdf', sep=''))
par(cex=0.75)
par(mar=c(5,4,4,5) + 0.1)
plot(byac$cfs, ylim=c(0,1.0),
    xlab='alternate allele count (AC)', xaxt='n',
    ylab='false discovery rate (FDR)', yaxt='n', type='l', col='red')
axis(2, at=seq(0,1,0.1), labels=seq(0,1,0.1))
axis(1, at=seq(0,max(byac$ac),10), labels=seq(0,max(byac$ac),10), cex=0.75)
grid(lty=5)
par(new=T)
title(paste(filename, 'putative site false discovery rate versus', tag, '(smoothed)'))
par(new=T)
countTicks <- seq(0,1,0.1) * vcf.numberOfSites
axis(4, at=seq(0,1,0.1), labels=round(countTicks))
par(col='red')
mtext("number of sites", side=4, line=3, cex=0.75)
par(col='black')
par(new=T)
plot(byac$site_fpr, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n')
par(new=T)
lines(byac$ac, predict(loess(byac$site_fpr ~ byac$ac, span=0.5)), col="blue")
par(new=T, cex=0.65)
mtext(paste("site FDR: ", round(1 - vcf.sitesTruePositive, digits=4), sep=''))
par(new=T, cex=0.65)
legend('topleft', c('cumulative sites', 'site FDR (loess smoothed)', 'FDR at AC'),
    fill=c('red', 'blue', 'black'))
garbage <- dev.off()

pdf(paste(filename, '.', tag, '.site_FDR.vs.AC.cumulative.pdf', sep=''))
par(cex=0.75)
par(mar=c(5,4,4,5) + 0.1)
plot(byac$cfs, ylim=c(0,1.0),
    xlab='alternate allele count (AC)', xaxt='n',
    ylab='false discovery rate (FDR)', yaxt='n', type='l', col='red')
axis(2, at=seq(0,1,0.1), labels=seq(0,1,0.1))
axis(1, at=seq(0,max(byac$ac),10), labels=seq(0,max(byac$ac),10), cex=0.75)
grid(lty=5)
par(new=T)
title(paste(filename, 'putative false discovery rate versus', tag, '(cumulative)'))
par(new=T)
countTicks <- seq(0,1,0.1) * vcf.numberOfSites
axis(4, at=seq(0,1,0.1), labels=round(countTicks))
par(col='red')
mtext("number of sites", side=4, line=3, cex=0.75)
par(col='black')
par(new=T)
plot(byac$site_fpr, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n')
par(new=T)
plot(byac$site_fprgt, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='green')
par(new=T)
plot(byac$site_fprlt, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='blue')
par(new=T, cex=0.65)
mtext(paste("site FDR: ", round(1 - vcf.sitesTruePositive, digits=4), sep=''))
par(new=T, cex=0.65)
legend('topleft', c('cumulative sites', 'site FDR <= AC', 'site FDR >= AC', 'FDR at AC'),
    fill=c('red', 'blue', 'green', 'black'))
garbage <- dev.off()


library("seewave")
library("tuneR")

args <- commandArgs(trailingOnly = TRUE)
# directory is the first (only) argument
dir = args[1]
print(sprintf("processing files in directory %s", dir))

File_list = list.files(dir, pattern="\\.wav$", full.names = TRUE)
show(File_list)

# WARNING: this assumes that all files are 180 mins!
Tot_mins = 180
Chunck_size = 30
N = Tot_mins/ Chunck_size
print(sprintf("number of chunks of %d mins to process in a file of %d mins is set to: %d", Chunck_size, Tot_mins, N))

# process each file in the specified directory
for (j in File_list) {
    dout <- vector()
    show(j)
    dout <- c(dout, j)
    for (i in 1:N) {
        Deagon_Dec<-readWave(j, from = (i-1)* Chunck_size + 1, to = i*Chunck_size, units = "minutes")
        val <- H(Deagon_Dec)
        show(val)
        dout <- c(dout, val)
    }

    write(dout, paste(c(dir,"entropy.csv"), collapse="/"), length(dout), append=TRUE, sep=",")
}


sum_of_total_number <- function (first,second){
  first <-  as.numeric(first)
  second <-  as.numeric(second)
  return (first + second )
}

main <- function(a,b){
  { a <- readline("Input value a: "); b <- readline("INput value b: ")}
  print(sum_of_total_number(a,b))
}

main()


library(rrBLUP)
library(data.table)
set.seed(42)
args = commandArgs(trailingOnly=TRUE)
X_file <- args[1] # your genetic matrix, e.g., geno.csv
Y_file <- args[2] # your phenotypic matrix, e.g., pheno.csv
feat_file <- args[3] # selected features or "all" for all the markers in the genetic matrix
trait <- args[4] # the column name of your target trait, or "all" for all the traits in the pheno matrix
test_file <- args[5] # file with individuals in test set
cv <- as.numeric(args[6]) # the fold number of the cross-validation scheme
number <- as.numeric(args[7]) # how many times your want to repeat the cross-validation scheme
cvs_file <- args[8] # the CVs file
save_name <- args[9]

Y <- read.csv(Y_file, row.names=1)
Test <- scan(test_file, what='character')

# Subset X if feat_file is not all
if (feat_file != 'all'){
  print('Pulling features to use...')
  FEAT <- scan(feat_file, what='character')
  X <- fread(X_file,select=c('ID',FEAT))
  fwrite(X,paste('geno',feat_file,'.csv',sep=''),sep = ",",quote=FALSE)
  feat_method <- tail(unlist(strsplit(feat_file, '/')), n=1)
  X <- read.csv(paste('geno',feat_file,'.csv',sep=''), row.names=1)
} else{
	X <- as.matrix(fread(X_file),rownames=1)
	}

# 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,paste("PCA_matrix_",X_file,".csv",sep=""),row.names=T,quote=F)
write.csv(EVD$vectors[,1:5],paste("PCA5_",X_file,".csv",sep=""),row.names=T,quote=F)

X = EVD$vectors[,1:5]

cvs <- read.csv(cvs_file, row.names=1)
cvs_all <- merge(Y,cvs,by="row.names",all.x=TRUE)
rownames(cvs_all) <- cvs_all$Row.names
cvs_all <- cvs_all[,(dim(Y)[2]+2):ncol(cvs_all)]
cvs_all[is.na(cvs_all)] = 0

# make sure X and Y have the same order of rows
X <- X[rownames(cvs_all),]
Y <- Y[rownames(cvs_all),]

if (trait == 'all') {
  print('Modeling all traits')
} else {
  Y <- Y[trait]
}

R2_cv <- c()
R2_test <- c()
Predict_validation <- c()
Predict_test <- c()
for(i in 1:length(Y)){
	print(names(Y)[i])
	Accuracy_CV <- c()
	Accuracy_test <- c()
	Coef <- c()
	for(k in 1:number){
		print(k)
		tst = cvs_all[,k]
		Coeff <- c()
		y_test <- c()
		yhat <- data.frame(cbind(Y, yhat = 0))
		yhat$yhat <- as.numeric(yhat$yhat)
		row.names(yhat) <- row.names(Y)
		for(j in 1:cv){
			validation <- which(tst==j)
			training <- which(tst!=j & tst!=0)
			test <- which(tst==0)
			yNA <- Y[,i]
			yNA[validation] <- NA # Mask yields for validation set
			yNA[test] <- NA # Mask yields for test set
			# Build rrBLUP model and save yhat for the masked values
			# predict marker effects
			coeff <- mixed.solve(y=Y[training,i], Z=X[training,], K=NULL, method='ML', SE=FALSE, return.Hinv=FALSE)
			Coeff <- rbind(Coeff,coeff$u)
			effect_size <- as.matrix(coeff$u)
			# predict breeding
			# rrblup <- mixed.solve(y=yNA, K=A.mat(X))
			# yhat$yhat[validation] <- rrblup$u[validation]
			yhat$yhat[validation] <- (as.matrix(X[validation,]) %*% effect_size)[,1] + c(coeff$beta)
			# yhat$yhat[test] <- rrblup$u[test]
			yhat$yhat[test] <- (as.matrix(X[test,]) %*% effect_size)[,1] + c(coeff$beta)
			y_test <- cbind(y_test,yhat$yhat)
			}
		accuracy_CV <- cor(yhat[which(tst!=0),i], yhat$yhat[which(tst!=0)])
		Accuracy_CV <- c(Accuracy_CV,accuracy_CV^2)
		y_test <- cbind(y_test,rowMeans(y_test))
		accuracy_test <- cor(yhat[which(tst==0),i], y_test[which(tst==0),ncol(y_test)])
		Accuracy_test <- c(Accuracy_test,accuracy_test^2)
		Coef <- rbind(Coef,colMeans(Coeff))
		pred_val <- cbind(pred_val,yhat$yhat[which(tst!=0)])
		pred_test <- cbind(pred_test,y_test[which(tst==0),ncol(y_test)])
		}
	R2_cv <- cbind(R2_cv,Accuracy_CV)
	R2_test <- cbind(R2_test,Accuracy_test)
	write.csv(Coef,paste('Coef_',save_name,'_',names(Y)[i],'.csv',sep=''),row.names=F,quote=F)
	colnames(pred_val) <- paste(names(Y)[i],'_',1:number,sep='')
	Predict_validation <- cbind(Predict_validation,pred_val)
	colnames(pred_test) <- paste(names(Y)[i],'_',1:number,sep='')
	Predict_test <- cbind(Predict_test,pred_test)
	}
colnames(R2_cv) <- names(Y)
write.csv(R2_cv,paste('R2_cv_results_',save_name,'.csv',sep=''),row.names=F,quote=F)
colnames(R2_test) <- names(Y)
write.csv(R2_test,paste('R2_test_results_',save_name,'.csv',sep=''),row.names=F,quote=F)
rownames(Predict_validation) <- rownames(X)[which(tst!=0)]
write.csv(Predict_validation,paste('Predict_value_cv_',save_name,'.csv',sep=''),row.names=T,quote=F)
rownames(Predict_test) <- rownames(X)[test]
write.csv(Predict_test,paste('Predict_value_test_',save_name,'.csv',sep=''),row.names=T,quote=F)


#' Indices 4 panel plots
#'
#' Shows observed and predicted indices regular and log scale, residuals over time, and resid histogram.
#' @param asap name of the variable that read in the asap.rdat file
#' @param index.names names of indices
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @export

PlotIndices4Panel <- function(asap,index.names,save.plots,od,plotf,liz.palette){
  par(mar=c(4,4,3,2), oma=c(1,1,1,1), mfrow=c(2,2)  )

  for (i in 1:asap$parms$nindices) {
    index.year <- unlist(asap$index.year[i])
    index.obs <- unlist(asap$index.obs[i])
    index.pred <- unlist(asap$index.pred[i])
    index.std.resid <- unlist(asap$index.std.resid[i])

    plot(index.year, index.obs, type='p', col=liz.palette[i], pch=1,
         xlab="Year", ylab="Index Value", xlim=c(asap$parms$styr,asap$parms$endyr),
         ylim=c(0, 1.1*max(index.obs)) )
    lines(index.year, index.pred, col=liz.palette[i], lwd=2)

    log.ob.min <- log(index.obs)-1.96*unlist(asap$index.sigma[i])
    log.ob.max <- log(index.obs)+1.96*unlist(asap$index.sigma[i])
    plot(index.year, log(index.obs), type='p', col=liz.palette[i], pch=1,
         xlab="Year", ylab="Ln(Index)", xlim=c(asap$parms$styr,asap$parms$endyr),
         ylim=c(min(log.ob.min,log(index.obs)), 1.1*max(log.ob.max,log(index.pred))) )
    lines(index.year, log(index.pred), col=liz.palette[i], lwd=2)
    arrows(index.year, log.ob.min, index.year, log.ob.max, length=0)
    title (paste0("Index ", i, " (", index.names[i], ")"), outer=T, line=-1 )

    plot(index.year, index.std.resid, type='h', lwd=2, col=liz.palette[i],
         xlab="Year", ylab="Log-scale Std. Residual", xlim=c(asap$parms$styr,asap$parms$endyr))
    abline(h=0)

    hist(index.std.resid, plot=T, xlab="Std. Residual", ylab="Probability Density", freq=F, main=NULL)
    if (save.plots) savePlot(paste0(od, "Index.4panel.",i,".",plotf), type=plotf)
  }   # end i-loop over nindices

  par(mfrow=c(1,1))
  return()
}


#' @title calcShipCategory
#'
#' @description
#' Assigns EPA regulatory ship category from engine displacement
#'
#' @param mainEngineBore Diameter of the main engine cylinder (mm) (vector of
#' numericals)
#' @param mainEngineStroke Main engine stroke length, the distance travelled by
#' the piston in each cycle (mm) (vector of numericals)
#'
#'@details
#'For more information, see Section 3.3.2.1 of the Port Emissions Inventory
#'Guidance.
#'
#' @return \code{shipCategory} (vector of ints). Valid values are: \itemize{
#' \item 1
#' \item 2
#' \item 3
#' }
#'
#' @references
#'\href{https://nepis.epa.gov/Exe/ZyPURL.cgi?Dockey=P1005ZGH.TXT}{EPA. 2009.
#'"Regulatory impact analysis: Control of emissions air pollution from category
#'3 marine diesel engines." Ann Arbor, MI: Office of Transportation and Air
#'Quality. US Environmental Protection Agency.}
#'
#'\href{https://nepis.epa.gov/Exe/ZyPDF.cgi/?Dockey=P10024CN.PDF}{EPA. 2008.
#'"Regulatory impact analysis: Control of emissions of air pollution from
#'locomotive engines and marine compression ignition engines less than 30 liters
#'per cylinder." Ann Arbor, MI: Office of Transportation and Air
#'Quality. US Environmental Protection Agency.}
#'
#' \href{https://nepis.epa.gov/Exe/ZyPDF.cgi?Dockey=P10102U0.pdf}{EPA. 2020.
#' "Port Emissions Inventory Guidance: Methodologies for Estimating
#' Port-Related and Goods Movement Mobile Source Emissions." Ann Arbor, MI:
#' Office of Transportation and Air Quality. US Environmental Protection Agency.}
#'
#' @examples
#' calcShipCategory(400, 240)
#'
#' @export

calcShipCategory<- function(mainEngineBore, mainEngineStroke){

# Calculate displacement in L/cyl
  main.engine.displacement <- ((pi / 4) * (mainEngineBore/10) ^ 2 *
                                    (mainEngineStroke / 10)) / 1000

# Categorize Ships (C1/C2/C3)
shipCategory <- ifelse(main.engine.displacement>= 30, 3,
                                  ifelse(main.engine.displacement >= 7, 2,
                                         ifelse(main.engine.displacement > 0 , 1,
                                                NA)))
return(shipCategory)
}