library(RColorBrewer)
library(rgdal)
library(raster)
library(sp)
library(ggplot2)
load("test/clim.Rdata")

#pj<-"+proj=laea +lat_0=52   +lon_0=10      +x_0=3 210 000    +y_0=4 321 000 "
pj<-"+proj=robin"
map2<-map
myPalette <- colorRampPalette(rev(brewer.pal(11, "Spectral")), space="Lab")

theme_opts <- list(theme(
			panel.grid.minor = element_blank(),
                        panel.grid.major = element_blank(),
                        #panel.background=element_blank(),
                        panel.background = element_rect(color = "black",fill=NA,  size = 0.4, linetype = "solid"),
                        #panel.border=element_rect(color = "black",fill=NA,  size = 0.4, linetype = "solid"),
                        plot.background = element_blank(),
                        #plot.background=element_blank(),
                        #panel.border = element_blank(),
                        axis.line = element_blank(),
                        axis.text.x = element_blank(),
                        axis.text.y = element_blank(),
                        axis.ticks = element_blank(),
                        #panel.margin = unit(5,"lines"),
                        #axis.title.x = element_blank(),
                        #axis.title.y = element_blank(),
                        plot.title = element_text()))

#==========
#(a) ggplot without projection
#==========
wmap <- readOGR(dsn="data/ne_110m_land", layer="ne_110m_land")
wmap_gg<-fortify(wmap)
grat <- readOGR("data/ne_110m_graticules_all", layer="ne_110m_graticules_15")
grat_df <- fortify(grat)
bbox <- readOGR("data/ne_110m_graticules_all", layer="ne_110m_wgs84_bounding_box")
bbox_df<- fortify(bbox)
countries <- readOGR("data/ne_110m_admin_0_countries", layer="ne_110m_admin_0_countries")

a<-ggplot(data=map2,aes(x=lon,y=lat))+
geom_tile(aes(fill=val))+
geom_polygon(data=wmap_gg,aes(long,lat,group=group),fill=NA,color="black")+
geom_path(data=bbox_df,aes(long,lat,group=group,fill=NULL),color="black")+
geom_path(data=grat_df,aes(long,lat,group=group),fill=NA,color="black")+xlim(-25,50)+ylim(20,55)

#==========
#(a) ggplot with  projection without boarder
#==========
wmap_robin <- spTransform(wmap, CRS(pj))
wmap_df_robin <- fortify(wmap_robin)
grat_robin <- spTransform(grat, CRS(pj))  # reproject graticule
grat_df_robin <- fortify(grat_robin)
countries_robin <- spTransform(countries, CRS(pj))
countries_robin_df<-fortify(countries_robin)
coordinates(map)=~lon+lat
map_<-as.data.frame(map)
map_<-as.data.frame(map_[,3])
names(map_)<-"val"
map_pixel<-SpatialPixelsDataFrame(data=map_,points=map,tolerance=0.007)
map_raster<-raster(map_pixel)
projection(map_raster)<-CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0")
raster_proj<-projectRaster(map_raster,crs=pj)
point_proj<-as.data.frame(rasterToPoints(raster_proj))

#
# Rsp<-SpatialPointsDataFrame(coordinates(map),data=as.data.frame(map),
# 			    proj4string=(CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0")))
#

projection(map)<-CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0")
kk<-coordinates(map)
pp<-as.data.frame(map)
Rsp<-SpatialPointsDataFrame(kk,data=pp,proj4string=(CRS("+init=epsg:4326")))
# tt<-spTransform(Rsp,CRS("+init=epsg:"))

Grid_wgs84<-gridat(Rsp)
line_wgs84<-gridlines(Rsp)

line_prj<-spTransform(line_wgs84,CRS(pj))
grid_prj<-spTransform(Grid_wgs84,CRS(pj))
label_prj<-as.data.frame(coordinates(grid_prj))
label<-as.character(grid_prj$labels)

label_prj<-cbind(label_prj,label)
names(label_prj)<-c("x","y","label")
# label_prj$x<-label_prj$x-max(point_proj$x)*0.1
# label_prj$y<-label_prj$y-max(point_proj$y)*0.1
cline<-coordinates(line_prj)
k<-1
df<-NULL
for(i in 1:2){
	for(j in 1:length(cline[[i]])){
		d<-cline[[i]][[j]]
		group<-rep(k,length.out=length(d[,1]))
		d<-cbind(d,group)
		df<-rbind(df,d)
		k<-k+1
		}
	}
	df<-as.data.frame(df)
	names(df)<-c("x", "y","group")

	plot.title = "General Circulation Models Climate Data Output"
 plot.subtitle = 'created by GCM runs'

f<-ggplot(point_proj,aes(x,y))+geom_tile(aes(fill=val))+
geom_path(data=countries_robin_df,aes(long,lat,group=group),color="black",size=0.2)+
xlim(min(point_proj$x)*1.01,max(point_proj$x))+
ylim(min(point_proj$y)*1.01,max(point_proj$y))+
geom_line(data=df,aes(x=x,y=y,group=group,fill=NULL),size=0.2,color="black",linetype="dashed")+
geom_text(data=label_prj,aes(x,y,label=label),parse=TRUE,size=3.5)+
theme_opts+
coord_equal()+
 labs(title="World map (robinson)",x="",y="") +
scale_fill_gradientn(colours = myPalette(100),breaks=c(-15,-10, -5,10,5, 0,5,15),
		     guide= guide_colorbar(title=expression(degree~C), title.position="top",
			 #    barwidth = 25, barheight = 1,nbin=100,
			     draw.ulim = FALSE, draw.llim = FALSE ))+
ggtitle(bquote(atop(.(plot.title), atop(italic(.(plot.subtitle)), ""))))
ggsave("map11.png",width=12.5,height=6.5,dpi=72)
#
#
#
#
# Rsp<-SpatialPointsDataFrame(Rc,Rd,proj4string=(CRS("+init=epsg:3035"))) /////
#
#
#
# R1<-raster("sinan11.tif")
#
# > proj4string(R1)
# [1] "+proj=laea +lat_0=52 +lon_0=10 +x_0=4321000 +y_0=3210000 +ellps=GRS80 +units=m +no_defs"
#
#
# > library(rgdal)
#
#
# > Rc<-coordinates(R1)
# > Rd<-as.data.frame(R1)
# > Rsp<-SpatialPointsDataFrame(Rc,Rd,proj4string=(CRS("+init=epsg:3035"))) ///// raster to SpatialPointsDataFrame
#
# >  grid1<-gridlines(Rsp) //// GRID creation
#
# > plot(grid1)
#
# > proj4string(grid1)
# [1] "+init=epsg:3035 +proj=laea +lat_0=52 +lon_0=10 +x_0=4321000 +y_0=3210000 +ellps=GRS80 +units=m +no_defs"
#
#
# > C84<-spTransform(Rsp, CRS("+init=epsg:4326"))
#
# > GridA<-gridat(C84)  //// points and labels in WGS84
#
#
# > GridB<-spTransform(GridA,CRS("+init=epsg:3035")) //// CREATE points in ETRS 89 WITH LABELS FROM WGS84
#
#
#
# > plot(GridB)
#
#
# > GridB
#          coordinates          labels pos offset
# 1 (4194850, 2023090)  8.5 *degree *E   1    0.5
# 2 (4236900, 2022390)    9 *degree *E   1    0.5
# 3 (4278950, 2021980)  9.5 *degree *E   1    0.5
# 4 (4171720, 2046030) 41.5 *degree *N   2    0.5
# 5 (4172940, 2101340)   42 *degree *N   2    0.5
# 6 (4174150, 2156680) 42.5 *degree *N   2    0.5
# 7 (4175380, 2212040)   43 *degree *N   2    0.5
#
# > text(coordinates(GridB), labels=parse(text=GridB$labels))   /// PLOT LABELS WGS 84 WITH ETRS89 points
#
# > plot(R1, add=TRUE)
#
#
#
#
# /////// AJOUT GRID 84 projected in 89
#
#
#
# > grid84<-gridlines(C84)
# > grid84_89<-spTransform(grid84,CRS("+init=epsg:3035"))
# > plot(grid84_89, add=TRUE)
# > plot(R1)
# > plot(grid84_89, add=TRUE)
# > labels=parse(text=GridB$labels)
# > text(coordinates(GridB), labels=parse(text=GridB$labels))


# * Stock Market Performance (Black Listing)

# * Clear Global Env
rm(list = ls())
setwd("~/Downloads/stock/code")

# *  Import libraries
library(ggplot2)
library(stargazer)
library(quantmod)

df <- read.csv("../../data/green_land.csv")
stargazer(
    df,
    type = "text"
)

df$Date <- as.Date(df$Date)

# * plot1 Greenland Holding Corporation Limited
ggplot(
    data = df, aes(x = Date, y = Close)
) +
    geom_line(color = "blue") +
    labs(
        x = "Date",
        y = "Daily Close Price",
        title = "Overview: Green_Land Holding Corporation Limited",
        subtitle = "Trading Code: 600606",
        captions = "Source: yahoo finance"
    ) +
    scale_x_date(date_labels = "%b %y", date_break = "3 month") +
    theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))


tmm_norm = function(path, out_path, bFilter){
  pacman::p_load(edgeR)

  raw_count = read.csv(path, check.names = F, header = TRUE, row.names = 1)

  dgList = DGEList(counts = raw_count,
                    genes = rownames(raw_count))

  if(bFilter){
    drop <- which(apply(cpm(dgList), 1, max) < 1)

    dgList = dgList[-drop,]
  }

  dgList <- calcNormFactors(dgList, method = "TMM")

  Analysis <- estimateDisp(dgList, robust = TRUE)
  Analysis$common.dispersion
  dgList <- estimateCommonDisp(dgList)
  dgList <- estimateTagwiseDisp(dgList)
  norm_counts.table <- voom(dgList)

  TMM_norm = norm_counts.table
  write.csv(TMM_norm, file = out_path)
return(TMM_norm)
}

arguments = function(){
  pacman::p_load(optparse)
  option_list = list(
    make_option(c("-f", "--file"), type="character", default=NULL,
                help="dataset file name", metavar="character"),
    make_option(c("-o", "--out"), type="character", default=NULL,
                help="Out file name/path", metavar="character"),
    make_option(c("-t", "--filter"), type="logical", default=NULL,
                help="Filter Low Expression", metavar="character")
  );

  opt_parser = OptionParser(option_list=option_list);
  opt = parse_args(opt_parser);
  return(opt)
}

arg = arguments()

print(tmm_norm(arg$file, arg$out, arg$filter))


# fakedata <- c(1,2,3,4,5)
# plot(fakedata)
?png

mydata <- read.table("data.txt", header=TRUE)
mydata
png(filename="out.png")
plot(ACT ~ Year,data=mydata, pch=16)
dev.off()


Args<-commandArgs()
RDSfile<-Args[6]
gene <- Args[7]
outFile <- Args[8]
method <- Args[9]

start_time <- Sys.time()
# RDSfile <- '/mnt/webrepo/fr-s-bsg-onc-d/htdocs/clinomics_hc/app/storage/project_data/23716/ensembl-gene-coding.all.tmm-rpkm.rds'
# gene <- 'MYCN'
# outFile <- '/mnt/webrepo/fr-s-bsg-onc-d/htdocs/clinomics_hc/app/storage/project_data/23716/cor/ensembl-pearson.tmm-rpkm.MYCN.tsv'
# method <- 'pearson'

#RDSfile=paste("/mnt/webrepo/fr-s-bsg-onc-d/htdocs/clinomics_dev2/app/storage/project_data/",projectId,"/",targetType,"-gene-coding.rds",sep="")

exp_data=readRDS(RDSfile)
#if there are duplicate gene names
if (colnames(exp_data)[1] == "X") {
	rownames(exp_data) <- make.names(exp_data$X, unique=TRUE)
	exp_data <- exp_data[,2:ncol(exp_data)]
}
#exp_date=as.data.frame(data.table::fread(RDSfile, header=T, sep="\t"))
#exp<-exp_data[2:nrow(exp_data),2:ncol(exp_data)]
#exp <- as.data.frame(lapply(exp, function(x) as.numeric(as.character(x))))
exp_mat<-as.matrix(exp_data) # convert to matrix
#rownames(exp_mat)<-exp_data[,1]

exp_mat=t(exp_mat)
class(exp_mat)<-"numeric"
exp_mat=log(exp_mat+1,2)

queryGene=as.vector(exp_mat[,gene])

corMat=t(cor(queryGene,exp_mat, method=c(method))) # type can be pearson or spearman
corSlim=corMat[!abs(corMat) <=0.2,]
finalMat=as.matrix(corSlim)
finalMat=cbind(rownames(finalMat),finalMat)

#spearmanCor=t(cor(queryGene,exp_mat, method=c("spearman"))) # type can be pearson or spearman
#spearmanSlim=spearmanCor[!abs(spearmanCor) <=0.2,]
#spearmanMat=as.matrix(spearmanSlim)
#spearmanMat=cbind(spearmanMat,rownames(spearmanMat))

write.table(finalMat, file=outFile, quote = FALSE, sep='\t',row.names =FALSE,col.names=FALSE)
#write.table(spearmanMat, file=paste(outDir,gene,"SpearmanCoeficient.tsv",sep=""),sep='\t',row.names =FALSE,col.names=FALSE)

end_time <- Sys.time()
time_exec=end_time - start_time
#print (time_exec)


# Import the irr library
library(irr)

# Read data
data = read.csv("rst/rst.csv")

# Measure agreement using Fleiss' kappa
kappam.fleiss(data, detail = TRUE)


subroutine bakfit(x,npetc,y,w,which,spar,dof,match,nef,
			etal,s,eta,beta,var,tol,
			qr,qraux,qpivot,effect,work)
#integer npetc(7)
#1:n
#2:p
#3:q
#4:ifvar
#5:nit
#6:maxit
#7:qrank
#subroutine bakfit(x,n,p,y,w,q,which,spar,dof,match,nef,
#			etal,s,eta,beta,var,ifvar,tol,nit,maxit,
#			qr,qraux,qrank,qpivot,work)
#This subroutine fits an additive spline fit to y
#All arguments are either double precision or integer
# bakfit uses the modified backfitting algorithm described in Buja, Hastie
# and Tibshirani, Annals of Statistics, 1989. It calls splsm, and some
# linpack based routines
# This was written by Trevor Hastie in 1990
# It has been modified from the S3 version by Trevor Hastie
# in March 2005, to accommodate the modified sbart routine in R
# Note that spar has changed, and we change it here to conform with
# the smooth.spline routine in R
#INPUT
#
#x	double dim  n by p ; x variables, includes constant
#n	integer number of rows in x
#p	integer number of columns of x
#y	double length n	; y variable for smoothing
#w	double length n ; prior weights for smoothing, > 0
#q	integer number of nonlinear terms
#which 	integer length q indices of columns of x for nonlinear fits
#spar	double length q spars for smoothing; see below
#dof	double length q dof for/from smoothing; see below
#match 	integer n by q  matrix of match'es; see below
#nef	integer q vector of nef's; see below
#s	double n by q nonlinear part of the smooth functions
#		used as starting values. the linear part is
#		irrelevant
#ifvar	logical should the variance information be computed
#tol	double tolerance for backfitting convergence; 0.0005 is good
#maxit	integer maximum number of iterations; 15 is good
#qr	double n by p weighted qr decomposition of x
#qraux 	double p belongs with qr
#qrank	integer rank of x ; if qrank=0, then bakfit computes qr and qraux
#qpivot	integer p the columns of qr are rearranged according to pivot
#effec  double n effect vector
#work	double
#	Let nk=max(nef)+2, then
# 	work should be (10+2*4)*nk+5*nef+5*n+15 +q double
#BELOW
#the following comments come from documentation for splsm
#	they apply to each element of spar,dof match etc
#spar	double smoothing parameter -1.5 <spar<1.5; default is 1
#dof	double  equivalent degrees of freedom
#		if dof is 0, spar is used
#               if 0< dof <1, dof = 1
#		if dof >=1, dof is used
#		note: dof does not use the constant term
#match 	integer length n -- in S language x[i] == sort(unique(x)[match[i]]
#		match is produced by subroutine namat
#nef	number of unique elements in x; so match has values between 1 and nef+1
#		missing data are given the match number nef+1
#work	double workspace of length (10+2*4)*(nef+2)+5*nef+n+15
#
#OUTPUT
#
#x,y,w,n,p,which,q,maxit,match,nef  are untouched
#spar	for each element of spar:
# 	if spar was 0 and dof was 0, then spar is that spar
#			that minimized gcv
#	if spar was 0 and dof > 0, then spar is that which achieves dof
#dof	the dof of the fitted smooth. Note: even if dof was given
#		as 4, it will be returned as say 3.995 which is what
#		spar produces
#etal	double length n linear component of the fit
#s	double n by q nonlinear part of the smooth functions
#eta	double length n fitted values
#beta	double length p linear coefficients
#       So, the centered fitted functions are:
#			 b(j)*(x(i,j)-mean(x(.,j)) +s(i,j)
#		where j is an element of which
#var	double n by q
#	if ifvar was .true.
#		the unscaled variance elements for the NONLINEAR
#		and UNIQUE part of s, in the order of sort(unique(x))
#		var is lev(i)/w(i) -h(i)/w where h(i) is the hat element from
#		the simple weighted least squares fit. This is  used in gamcov
#
#nit	number of iterations used
#qr etc the qr is returned

implicit double precision(a-h,o-z)
logical ifvar
integer npetc(7),iter
integer n,p,q,which(*),match(*),nef(*),nit,maxit,qrank,qpivot(*)
double precision x(*),y(*),w(*),spar(*),dof(*),
			etal(*),s(*),eta(*),beta(*),var(*),tol,
			qr(*),qraux(*),effect(*),work(*)
n=npetc(1)
p=npetc(2)
q=npetc(3)
ifvar=.false.
if(npetc(4)==1)ifvar=.true.
maxit=npetc(6)
qrank=npetc(7)
do i=1,q{work(i)=dof(i)}
call backf1(x,n,p,y,w,q,which,spar,dof,match,nef,
            etal,s,eta,beta,var,ifvar,tol,nit,maxit,
            qr,qraux,qrank,qpivot,effect,work(q+1),work(q+n+1),
            work(q+2*n+1),work(q+3*n+1),work(q+4*n+1))
npetc(7)=qrank
return
end

subroutine backf1(x,n,p,y,w,q,which,spar,dof,match,nef,
			etal,s,eta,beta,var,ifvar,tol,nit,maxit,
			qr,qraux,qrank,qpivot,effect,z,old,sqwt,sqwti,work)
implicit double precision(a-h,o-z)
logical ifvar
integer n,p,q,which(q),match(n,q),nef(q),nit,maxit,qrank,qpivot(p)
double precision x(n,p),y(n),w(n),spar(q),dof(q),
			etal(n),s(n,q),eta(n),beta(p),var(n,q),tol,
			qr(n,p),qraux(p),effect(n),work(*)
double precision z(*),old(*),dwrss,ratio
double precision sqwt(n),sqwti(n)
logical anyzwt
double precision deltaf, normf,onedm7
integer job,info
onedm7=1d-7
job=1101;info=1
if(q==0)maxit=1
ratio=1d0
# fix up sqy's for weighted problems.
anyzwt=.false.
do i=1,n{
	if(w(i)>0d0){
		sqwt(i)=dsqrt(w(i))
		sqwti(i)=1d0/sqwt(i)
	}
	else{
		sqwt(i)=0d0
		sqwti(i)=0d0
		anyzwt=.true.
		}
	}
# if qrank > 0 then qr etc contain the qr decomposition
# else bakfit computes it.
if(qrank==0){
	do i=1,n{
		do j=1,p{
			qr(i,j)=x(i,j)*sqwt(i)
			}
		}
	do j=1,p{qpivot(j)=j}
	call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7)
	}
do i=1,n{
	eta(i)=0d0
	for(j=1;j<=q;j=j+1){
		eta(i)=eta(i)+s(i,j)
		}
	}
nit=0
while ((ratio > tol )&(nit < maxit)){
	# first the linear fit
	deltaf=0d0
	nit=nit+1
	do i=1,n{
		z(i)=(y(i)-eta(i))*sqwt(i)
		old(i)=etal(i)
	}
#	call dqrsl1(qr,dq,qraux,qrank,sqz,one,work(1),etal,two,three)
#job=1101 -- computes fits, effects and beta
	call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta,
		work(1),etal,job,info)

# now unsqrt the fits
#Note: we dont have to fix up the zero weights till the end, since their fits
#are always immaterial to the computation
	do i=1,n{
		etal(i)=etal(i)*sqwti(i)
		}
	# now a single non-linear backfitting loop
	for(k=1;k<=q;k=k+1){
		j=which(k)
		do i=1,n{
			old(i)=s(i,k)
			z(i)=y(i)-etal(i)-eta(i)+old(i)
		}
                # this uses spar to set smoothing after iteration 1
                if(nit>1){dof(k)=0d0}
		call splsm(x(1,j),z,w,n,match(1,k),nef(k),spar(k),
			dof(k),s(1,k),s0,var(1,k),ifvar,work)
		do i=1,n{
			eta(i)=eta(i)+s(i,k)-old(i)
			etal(i)=etal(i)+s0
			}
		deltaf=deltaf+dwrss(n,old,s(1,k),w)
		}
	normf=0d0
	do i=1,n{
		normf=normf+w(i)*eta(i)*eta(i)
		}
	if(normf>0d0){
		ratio=dsqrt(deltaf/normf)
		}
	 else {ratio = 0d0}
#         call DBLEPR("ratio",-1,ratio,1)
	}
#now package up the results
do j=1,p {work(j)=beta(j)}
do j=1,p {beta(qpivot(j))=work(j)}
if(anyzwt){
	do i=1,n {
		if(w(i) <= 0d0){
			etal(i)=0d0
			do j=1,p{
				etal(i)=etal(i)+beta(j)*x(i,j)
				}
			}
		}
	}

do i=1,n
	eta(i)=eta(i)+etal(i)

do j=1,q {
	call unpck(n,nef(j),match(1,j),var(1,j),old)
	do i=1,n {var(i,j)=old(i)}
	}

return
end


suppressMessages(library(pbdDMAT))
source("setup.r")
init.grid(quiet=TRUE)
comm.set.seed(SEED, diff=TRUE)

n = 5000

GRID_TYPE = PROC_GRID_SQUARE
.pbd_env$ICTXT = GRID_TYPE
.pbd_env$BLDIM = c(BLOCKSIZE, BLOCKSIZE)
g = base.blacs(GRID_TYPE)

t_gen = mpitime({
  x <- ddmatrix("runif", n, n)
  x <- crossprod(x)
})
t_op = mpitime(solve(x))

p = sprintf("invert,%d,%d,%d,%d,%d,%d,%d,%f,%f\n", comm.size(), g$NPROW, g$NPCOL, n, n, BLOCKSIZE, BLOCKSIZE, t_gen, t_op)
comm.cat(p, quiet=TRUE)

finalize()


##############
# SAGP Model #
##############

message('sagp.R module loaded!\n')

# sagp
# Y observations, n*1 vector.
# X observed locations, n*d matrix (only d=1 for now).
# pinfo list of prior information, used for specifying the hyper-parameters.
# minfo list of MCMC information. number of MCMC steps, burn-in, etc.
# tinfo list of partition design that defines the domains of the components and the
#   structure of the layers.
#   E.g., 3 layers, 7 components in bipartite component design (1 comp in 1st layer, 2 comp in 2nd layer, 4 comp in 3rd layer)
#     is represented by:
#     tinfo = list(data.frame(loc=c(0.5),
#                             rad=c(0.5)),
#                  data.frame(loc=c(0.25,0.75),
#                             rad=c(rep(0.25,2))),
#                  data.frame(loc=c(0.125,.375,.625,0.875),
#                             rad=c(rep(0.125,4))))
# Xnew is the locations over which we want to conduct our predictions.
# sampleEta/sampleRho are booleans, should eta/rho be sampled in MCMC algorithm.
# storePredX boolean, should the predictions at the observed locatios be stored? If X large,
#   should be set to FALSE and only predictions at Xnew are stored.
sagp<-function(Y,X,pinfo,minfo,tinfo,Xnew=X,sampleEta=T,sampleRho=F,storePredX=T)
{
  #Seed, for reproducibility
  set.seed(minfo$seed)

  #Transform Y to have mean = 0 and sd = 1
  meanY <- mean(Y)
  sdY <- sd(Y)
  Y <- (Y-meanY)/sdY
  #At the end of the code, samples of Y are transformed back to original scale

  #overall number of observations in the sample.
  n =nrow(X)
  if(n!=length(Y))stop('sagpfun::sagp @ the length of X and Y shall match.')
  #overall number of new locations to be predicted.
  nNew = nrow(Xnew)
  #number of additive components - defined by the list with tree partition structure
  #N=length(unlist(tinfo))/2
  #number of pseudo inputs - if equal for all components
  m=pinfo$m
  #number of layers
  L=length(tinfo)
  #dimension of X
  D=ncol(X)

  #number of samples to store and return in the result list
  Nmcmc    = minfo$Nmcmc
  #number of burn-in iterations
  burnIn   = minfo$burnIn
  #total number of iterations to run
  Nsamples = Nmcmc+burnIn

  #Identify the locations (X and Xnew) corresponding to each component, for each layer
  # indexCompX is a list of L elements. For each layer l, indexCompX[[l]] is a vector with length n.
  #   For each element X[i] in X[1],...,X[n], indexCompX[[l]][i] is the index of the component in the l-th layer to which X[i] belongs.
  # indexCompNew is a list of L elements. For each layer l, indexCompX[[l]] is a vector with length nNew.
  #   For each element X[i] in X[1],...,X[nNew], indexCompX[[l]][i] is the index of the component in the l-th layer to which X[i] belongs.
  # layers is a data.frame that links layers and components
  #   e.g. layer=data.frame(comp=c(1,2,3),layer=c(1,2,2)) means the component 1 is in the 1st layer while the component 2,3 are in the 2nd layer.
  #   It is used throughtout the code to know which is the layer of each component: layers$layer[layers$comp==j] is the layer of component j.
  indexCompX=vector("list",L)
  indexCompNew=vector("list",L)
  layers <- NULL
  # m_l is a vector of length N=N_1+N_2+...+N_L recording how many PIs should there be in each componet, or the l-th component to be more precise.
  m_comp    <- c()
  #Initialize the layers dataframe. numCompTot is the iterator that records the loop;
  numCompTot <- 0
  for(l in 1:L) {
    #The outer loop loops through 1,2,...,L layer.

    #tinfo_layer is a data frame consisting of N_l*2 elements,
    #   the number of rows N_l means the number of components in the l-th layer
    #   the number of PIs in each component m are determined before.
    #   the first column is recording the center of each component.
    #   the second column is recording the radius of each component.
    tinfo_layer       <- tinfo[[l]]
    indexCompX[[l]]   <- rep(NA, n)
    indexCompNew[[l]] <- rep(NA, nNew)
    #N_l is the number of components in the l-th layer.
    N_l <- nrow(tinfo_layer$loc)
    for(j_l in 1:N_l) {
      #The inner loop loops through different components j_l=1,2,...,nrow(tinfo_layer) in each layer/ the l-th layer.

      #loc_j_l is the 'center' of the j_l component domain
      #rad_j_l is the 'radius' of the j_l component domain.
      loc_j_l <- tinfo_layer$loc[j_l,]
      rad_j_l <- tinfo_layer$rad[j_l,]

      ids_j_l <- ids_X_comp(X,loc=loc_j_l,rad=rad_j_l)
      cat('Initialize...Layer',l,'Component',j_l,'/',N_l,'\n');message('loc=',loc_j_l,' rad=',rad_j_l,'\n')
      #Check:are there points in this component that have not been already assigned to other components?
      #Need to check that the points are not already assigned because points could be on the border between
      #two components and could be assigned to both.
      idToReplace <- ids_j_l[is.na(indexCompX[[l]][ids_j_l])]
      #If yes: include it. Otherwise: do not increase the counter and do not include the component.
      if(length(idToReplace) > 0) {
        numCompTot <- numCompTot + 1

        indexCompX[[l]][idToReplace] <- numCompTot

        ids_new_j_l <- ids_X_comp(Xnew,loc=loc_j_l,rad=rad_j_l)
        indexCompNew[[l]][ids_new_j_l] <- numCompTot

        layers <- rbind(layers, data.frame(layer=l,comp=numCompTot))

        # Assign different m_comp (number of PIs) in this case we use the same number of PIs in each component.
        #m_comp <- c(m_comp,m-4*floor(log(numCompTot,base=sqrt(2))))
        # or set  all m_comp to be the same
        m_comp<-c(m_comp,m)
      }

    }
  }
  #Note: numCompTot is the number of temporary real components, where I have at least one data point.

  #cat(m_comp)
  m_max <- max(m_comp)
  m_compActual<-m_comp
  if(m_max<=0)stop('sagpfuns::sagp @ the maximal number of PIs in components must be greater than 0.')

  #"Deactivate" components corresponding to areas where there are not enough data points.
  # Loop from last component (lowest layer, local) to first (higher layer, global).
  # For each component j, look how many components are nested in j and compute necessary number of PIs.
  # If number of data points is not sufficient, deactivate the most local components nested in j (lowest layer)
  # and check if there are enough data points. Iterate, removing one layer of components each time.
  for(j in numCompTot:1) {
    layer_j <- layers$layer[layers$comp==j] #Layer of component j
    ids_layer_j <- (indexCompX[[layer_j]] %in% j) #ids of points in comp j
    nestedComp <- list() #list where store the nested components
    layers_below_j <- 0 #counter of nested layers
    for(l in layer_j:L) {
      #Which components are nested in j in layer l? stored in nestedComp_l
      compOfNestedPoints <- indexCompX[[l]][ids_layer_j]
      compOfNestedPoints_noNA <- compOfNestedPoints[!is.na(compOfNestedPoints)]
      nestedComp_l <- sort(unique(compOfNestedPoints_noNA))
      #If there is one component at layer l: store it in list nestedComp.
      if(length(nestedComp_l)>0) {
        layers_below_j <- layers_below_j + 1
        nestedComp[[layers_below_j]] <-  nestedComp_l
      } else {
        break
      }
    }
    #Given all the components nested in j, how many PIs do we need?
    req_m <- length(unlist(nestedComp)) * m
    #How many data points are available in component j?
    numPointsComp <- sum(ids_layer_j)
    #If the component does not contain enough points for its PI and the PI of the nested components:
    if(numPointsComp<req_m) {

      #Deactivate components from the layer at lowest level (most local) to the highest (more global).
      for(l_deact in layers_below_j:1) {
        #Components to deactivate
        compToDeact <- nestedComp[[l_deact]]
        #Loop to deactivate the components. Also, drop the component from the dataframe layers.
        for(j_deact in compToDeact) {
          layer_j_deact <- layers$layer[layers$comp==j_deact]
          indexCompX[[layer_j_deact]][indexCompX[[layer_j_deact]] %in% j_deact] <- NA
          indexCompNew[[layer_j_deact]][indexCompNew[[layer_j_deact]] %in% j_deact] <- NA
          layers <- layers[layers$comp!=j_deact,]
        }
        #When a layer of components is removed, check: do we have enough data points now?
        nestedComp <- nestedComp[1:(l_deact-1)]
        req_m <- length(unlist(nestedComp)) * m #Required data points now
        #If now there are enough data points: OK, move to check another component
        if(numPointsComp>=req_m) {
          break
        }
      }

    }
  }

  #Rename remaining components from 1 to the number of remaining components and match the number of PIs
  #assigned to the "old" components to the "new" components.
  #Assign "old" labels to comp_old and "new" labels to comp.
  layers$comp_old <- layers$comp
  layers$comp <- 1:nrow(layers)
  #Same for m_comp
  m_comp_old <- m_comp
  m_comp <- rep(NA,nrow(layers))
  #Loop on the "new" labels of the components
  for(j in layers$comp) {
    layer_j <- layers$layer[layers$comp==j]
    indexCompX[[layer_j]][indexCompX[[layer_j]] %in% layers$comp_old[layers$comp==j]] <- j
    indexCompNew[[layer_j]][indexCompNew[[layer_j]] %in% layers$comp_old[layers$comp==j]] <- j
    m_comp[j] <- m_comp_old[layers$comp_old[layers$comp==j]]
  }
  #Remove "old" labels
  layers$comp_old <- NULL
  m_compActual<-m_comp

  #If a layer does not have any components left, remove layer
  for(l in L:1) {
    if(all(is.na(indexCompX[[l]]))) {
      indexCompX <- indexCompX[1:(l-1)]
      indexCompNew <- indexCompNew[1:(l-1)]
    }
  }

  #Rename objects with correct number of components:
  N <- nrow(layers)
  L <- length(indexCompX)

  #Define prior on rhos and eta using the correct number of components and layers
  #Same priors for all the dimensions
  pinfo$rho=list() # one rho prior per layer, list of values defined below
  pinfo$eta=list() # one eta prior per layer, list of values defined below
  #Fixed vector of rhos
  fixedRhos <- 10^(seq(pinfo$logRhoFirstLayer, pinfo$logRhoLastLayer,length = L))
  for(l in 1:L) {
    #rho: fixed values, equispaced in the log_10-scale between 10^-1 and 10^-50
    pinfo$rho[[l]] <-  fixedRhos[l]
    #eta: gamma prior with mean 1/ ((1-r) * r^(l-1)) in layer l
    #pinfo$eta[[l]] <- list(a=1, b = (1-pinfo$r) * (pinfo$r^(l-1)))
    pinfo$eta[[l]] <- list(a=50, b = 50*(1-pinfo$r) * (pinfo$r^(l-1)))
  }

  #Rhos
  #Initialize array to store rho samples, each row stores one MCMC sample for rho.
  rho=array(NA,dim=c(Nsamples,N,D))
  #First value for each component: sampled or set to fixed value
  for(j in 1:N) {
    for(d in 1:D) {
      layer_j <- layers$layer[layers$comp==j]
      if(sampleRho) {
        rho[1,j,d]=rbeta(1,pinfo$rho[[layer_j]]$alpha, pinfo$rho[[layer_j]]$beta)
      } else {
        rho[1,j,d]=pinfo$rho[[layer_j]]
      }
    }
  }
  #Semiwidth of MH proposal for rho (same for all component and for each dimension)
  semiWidthRho=matrix(minfo$semiWidthRho,nrow=N,ncol=D)

  #Etas
  #Initialize matrix to store eta samples, each row stores one MCMC sample for eta.
  eta=matrix(NA,nrow=Nsamples,ncol=N)
  #print(pinfo$eta)
  #First value for each component: sampled
  for(j in 1:N) {
    layer_j <- layers$layer[layers$comp==j]
    #if(sampleEta) {
    eta[1,j]=rgamma(1,pinfo$eta[[layer_j]]$a, pinfo$eta[[layer_j]]$b)
    #}
  }
  #Semiwidth of MH proposal for eta(same for all component)
  semiWidthEta=rep(minfo$semiWidthEta,N)

  #lambda - reciprocal of overall Gaussian noise variance
  lambda=rep(NA,Nsamples)
  lambda[1]=rgamma(1,pinfo$a,pinfo$b)

  #D_mcmc is a matrix that stores the last set of residuals for each component, each column stores residuals for each component.
  D_mcmc=matrix(0,nrow=n,ncol=N)
  for(j in 1:N){
    D_mcmc[,j]=Y
  }

  #xBar/fBar are lists storing the samples of pseudo-inputs/targets (for *ALL* samples, also burn-in iterations).
  xBar=vector("list",Nsamples)
  fBar=vector("list",Nsamples)
  for(i in 1:Nsamples){
    #Initialize the xBar to be zero vectors.
    #Each term in xBar is a matrix representing the xBars. Each column of the matrix is a vector for xBar in an additive component.
    xBar[[i]]=array(0,dim=c(m_max,N,D))
    #Initializes the fBar to be zeros.
    #Each term in xBar is a matrix representing the fBars. Each column of the matrix is a vector for fBar in an additive component.
    fBar[[i]]=matrix(0,nrow=m_max,ncol=N)

  }
  complete_vec<-function(vec,len){
    ret<-c(vec,rep(NA,len-length(vec)))
    return(ret)
  }
  complete_mat<-function(mat,len){
    ret<-rbind(mat,matrix(NA,nrow=(len-nrow(mat)),ncol=ncol(mat)))
    return(ret)
  }
  #Sample first xBar/fBar we must complete the vector to store them in a mtrix form if m_comp differ.
  for(j in 1:N) {
    idSampleX <- sample.int(n,m_comp[j])
    xBar[[1]][,j,] <- complete_mat(matrix(X[idSampleX,],ncol=D),m_max)
    fBar[[1]][,j] <- complete_vec(mvtnorm::rmvnorm(1,mean=rep(0,m_comp[j]),sigma=diag(1,m_comp[j]) ),m_max)
  }

  #Matrices storing the means of each component in last MCMC iteration (at observed and new locations).
  #Cannot initialize as non-0.
  mu.component.temp=matrix(0,nrow=n,ncol=N)
  mu.new.component.temp=matrix(0,nrow=nNew,ncol=N)

  #Lists to store samples of the means of each component at each MCMC iteration - only after burnin to reduce memory allocation.
  mu.component=vector("list",Nmcmc)
  mu.new.component=vector("list",Nmcmc)

  #Lambda_diag is a list with N components, Lambda_diag[[j]] is the diagonal of Lambda_j (diagonal matrices)
  Lambda_diag=vector("list",N)
  for(j in 1:N) {
    layer_j <- layers$layer[layers$comp==j]
    #The number of elements of Lambda_diag[[j]] is the number of data points X belonging to component j
    Lambda_diag[[j]] <- rep(1, sum(indexCompX[[layer_j]] %in% j))
  }

  #Vector of in-sample and out-sample means (only last iteration)
  mu.temp = matrix(0,nrow=n,ncol=1)
  mu.new.temp = matrix(0,nrow=nNew,ncol=1)

  #Stored in-sample and out-sample means - only stored after burn-in to reduce memory allocation
  # Means at observed locations are stored only if storePredX==T
  if(storePredX==T) {
    mu=matrix(NA,nrow=n,ncol=Nmcmc)
    mu[,1]=mu.temp
  } else {
    mu <- NULL
  }
  mu.new=matrix(NA,nrow=nNew,ncol=Nmcmc)
  mu.new[,1]=mu.new.temp

  #Stored in-sample and out-sample predictions - only stored after burn-in to reduce memory allocation
  # Prediction at observed locations are stored only if storePredX==T
  # No need to initialize them
  if(storePredX==T) {
    Yhat=matrix(NA,nrow=n,ncol=Nmcmc)
  } else {
    Yhat <- NULL
  }
  Yhat.new=matrix(NA,nrow=nNew,ncol=Nmcmc)

  #Acceptance rates of MH samples
  acceptCountRhos <- matrix(0,nrow=N,ncol=D)
  sampledRhos     <- matrix(0,nrow=N,ncol=D)
  acceptCountEtas <- rep(0,N)
  sampledEtas     <- rep(0,N)

  #Say some stuff
  cat("Sparse Additive Gaussian Process (SAGP) Model\n")
  cat("Number of observations: ",n,"\n")
  cat("Number of predictive locations: ",nrow(Xnew),"\n")

  cat("Number of layers: ",L,"\n")
  cat("Number of additive components: ",N,"\n")
  cat("Number of inducing variables measure at pseudo-inputs per component: ",m,"\n")
  cat("\n")
  cat("Running MCMC for ",Nsamples," iterations (burn-in:",burnIn,", saved:", Nmcmc, ")\n")

  pb <- txtProgressBar(min=2,max=Nsamples,style=3)
  # Main MCMC loop
  for(i in 2:Nsamples) {

    setTxtProgressBar(pb, i)

    #Initialize i-th step to (i-1)-th step for all the sampled parameters - so we don't need to worry about i or i-1
    xBar[[i]] <- xBar[[i-1]]
    fBar[[i]] <- fBar[[i-1]]
    rho[i,,]   <- rho[i-1,,]
    eta[i,]   <- eta[i-1,]
    lambda[i] <- lambda[i-1]

    # BOTTOM-UP
    #Arrange the pseudo-inputs for the current iterations of the MCMC loop
    # Pseudo-inputs are assigned from the last (finest) to the first (roughest) layer, to make sure
    # that there are enough pseudo-inputs in each component.
    # Pseudo-inputs are assigned to each component *WITHOUT* repetition.
    Xavail <- rep(T, n) #Available X (all at beginning)
    listIndexEligX <- list() #Store eligible X for each component
    #From last to first component:
    for(j in N:1) {
      layer_j <- layers$layer[layers$comp==j]
      #Eligible X: which are X that happen to fall in layer_j layer.
      #Available X: which are X that are not used in all previous components.
      listIndexEligX[[j]] <- which(indexCompX[[layer_j]]==j)
      #Eligible AND available X:
      indexesEligAndAvailX <-  which(indexCompX[[layer_j]]==j & Xavail)
      #Sample from eligible AND available X:
      indexesSampledX <- sample(indexesEligAndAvailX, m_comp[j])
      #Sampled X are not available anymore
      Xavail[indexesSampledX] <- F
      #Store sampled xBar
      #xBar[[i]][,j]<-X[indexesSampledX]
      xBar[[i]][,j,]<-complete_mat(matrix(X[indexesSampledX,],ncol=D),m_max)
    }

    # TOP-DOWN (commented)
    # #For each component, Gibbs sampler
    # Xavail <- rep(T, n) #Available X (all at beginning) for xBar sampling

    for(j in 1:N) {

      # Component j corresponds to layer layer_j
      layer_j <- layers$layer[layers$comp==j]

      ########################################
      #          Sampling xBar(START)        #

      # TOP-DOWN (commented)
      # #Alternative sampling scheme
      # #Arrange the pseudo-inputs for the current iterations of the MCMC loop
      # # Pseudo-inputs are assigned to each component *WITHOUT* repetition.
      #
      # listIndexEligX <- list() #Store eligible X for each component
      # #Eligible X: which are X that happen to fall in layer_j layer.
      # #Available X: which are X that are not used in all previous components.
      # listIndexEligX[[j]] <- which(indexCompX[[layer_j]]==j)
      # #Eligible AND available X:
      # indexesEligAndAvailX <-  which(indexCompX[[layer_j]]==j & Xavail)
      # #Sample from eligible AND available X:
      # if(length(indexesEligAndAvailX)<m_comp[j]){
      #   #If there is no sufficient number of observations in certain component to conduct the sampling, skip whole component.
      #   message('sagpfuns::sagp There is insufficent observations in ')
      #   message(paste0('  OUTPUT: This happens for comp ',j,' at layer',layer_j,'!'))
      #   m_compActual[j]<-0
      #   next
      # }else{
      #   indexesSampledX <- sample(indexesEligAndAvailX, m_comp[j])
      # }
      # #Sampled X are not available anymore
      # Xavail[indexesSampledX] <- F
      # #Store sampled xBar
      # xBar[[i]][,j]<-complete_vec(X[indexesSampledX],m_max)

      #          Sampling xBar(END)          #
      ########################################

      # Indexes of the X corresponding to component j
      indexesEligX <- listIndexEligX[[j]]
      #This xBar_noNA fetches the xBar, whose empty entries are NA, into a shorter vector by dropping the NAs.
      #Recall that NAs comes from the complete_vec function that allows us to record the xBar in a matrix form.
      xBar_noNA<-matrix(na.omit(xBar[[i]][,j,]),ncol=D)

      ########################################
      #          Sampling fBar(START)        #
      # Gibbs step

      #Compute residuals of component j given all the other components.
      if(N==1){
        D_mcmc[,j] = Y
      }else{
        idx=(1:N)[-j]
        D_mcmc[,j] = Y-apply(mu.component.temp[,idx,drop=FALSE],1,sum)
      }

      #Training data of the j-th component: only on data points (X,Y) within that component
      X_train <- matrix(X[indexesEligX,],ncol=D)
      Y_train <- matrix(Y[indexesEligX],ncol=1)
      D_mcmc_train <- D_mcmc[indexesEligX,j]

      #Compute covariance matrices

      Ktrainm <- makeKernel(X1=X_train,
                            X2=xBar_noNA,
                            kinfo=list(eta=eta[i,j],rho=rho[i,j,]))
      Kmm <- makeKernel(X1=xBar_noNA,
                        X2=xBar_noNA,
                        kinfo=list(eta=eta[i,j],rho=rho[i,j,]))
      Knewm <- makeKernel(X1=Xnew,
                          X2=xBar_noNA,
                          kinfo=list(eta=eta[i,j],rho=rho[i,j,]))

      #Inverse of Kmm
      # Trick in cov/apxSparse.m of matlab code
      # Any sparse approximation to the posterior Gaussian process is equivalent to
      # using the approximate covariance function:
      #   Kt = Q + s*diag(g); g = diag(K-Q); Q = Ku'*inv(Kuu+diag(snu2))*Ku;
      # where Ku and Kuu are covariances w.r.t. to inducing inputs xu and
      # snu2 is a vector with the noise variance of the inducing inputs.
      # As a default, we fix the standard deviation of the inducing inputs
      # snu = sfu/1e3 * ones(nu,1) to be a one per mil of the signal standard
      # deviation sfu^2 = trace(Kuu)/nu of the inducing inputs. Alternatively, the
      # noise of the inducing inputs can be treated as a hyperparameter by means
      # of the field hyp.snu that can contain a scalar value log(snu) or a vector
      # of inducing point specific log noise standard deviations.
      sfu2   <- sum( diag(Kmm)/m_comp[j] )
      sfu    <- sqrt(sfu2)
      snu    <- sfu/1e3
      snu2   <- snu^2
      Kmm    <- Kmm +  snu2*diag(m_comp[j])
      KmmInv <- chol2inv(chol(Kmm,pivot=F))

      #Compute matrix Lambda_j
      # Definition: Lambda_j =  diag(diag(1/eta[i,j] * I_train - Ktrainm %*% KmmInv %*% t(Ktrainm)))
      # Computation of Ktrainm %*% KmmInv %*% t(Ktrainm) is waste of computations: we only need the diagonal of this.
      # Element (iDiag,iDiag) of Ktrainm %*% KmmInv %*% t(Ktrainm) is Ktrainm[iDiag,] %*% KmmInv %*% Ktrainm[iDiag,]
      # Compute only the diagonal elements with a for loop
      nTrain <- length(Y_train) # number of training data points for component j
      diag_Knm_KmmInv_Kmn <- rep(NA,nTrain)
      for(iDiag in 1:nTrain) {
        diag_Knm_KmmInv_Kmn[iDiag] <- matrix(Ktrainm[iDiag,],ncol=m_comp[j]) %*% KmmInv %*% matrix(Ktrainm[iDiag,],nrow=m_comp[j])
      }
      Lambda_diag[[j]] <- rep(1/eta[i,j],nTrain) - diag_Knm_KmmInv_Kmn

      #Perturbation of diagonal of Lambda_j with noise (precision lambda, variance 1/lambda)
      LambdaPerturbed_diag   = Lambda_diag[[j]] + (1/lambda[i])
      #Diagonal of (Lambda_j + noise)^-1
      LambdaPerturbedInv_diag = (1/LambdaPerturbed_diag)

      #Compute Q
      # Definition: Q = Kmm + t(Ktrainm) %*% LambdaPerturbedInv %*% Ktrainm
      # Take advantage of the fact that LambdaPerturbedInv is diagonal matrix =>
      # LambdaPerturbedInv %*% Ktrainm =
      #    [ diag(diaLambdaPerturbedInv) * Ktrainm[,1] | diag(diaLambdaPerturbedInv) * Ktrainm[,m] | ... | diag(diaLambdaPerturbedInv) * Ktrainm[,m] ],
      # where diag(diaLambdaPerturbedInv) %*% Ktrainm[,k] is the elementwise product of the k-t column of Ktrainm times  diag(diaLambdaPerturbedInv).
      # This is computed in R with Ktrainm * LambdaPerturbedInv_diag
      LambdaPerturbedInv_Ktrainm <- Ktrainm * LambdaPerturbedInv_diag
      Q <- Kmm + t(Ktrainm) %*% LambdaPerturbedInv_Ktrainm

      Qinv           = chol2inv(chol(Q,pivot=F))
      #M_j is just auxillary matrix to reduce computation.
      M_j            = Kmm %*% Qinv %*% t(Ktrainm)

      #Compute Mean_j
      # Definition: Mean_j  = M_j%*% LambdaPerturbedInv %*% D_mcmc_train
      # As for the definition of Q, take advantage of diagonal structure of LambdaPerturbedInv.
      # M_j %*% LambdaPerturbedInv = elementwise product of rows of M_j times LambdaPerturbedInv_diag = t(t(M_j) * LambdaPerturbedInv_diag)
      Mean_j         = t(t(M_j) * LambdaPerturbedInv_diag) %*% D_mcmc_train

      M_j            = Kmm %*% Qinv %*% t(Kmm)
      #Symmetrizer to avoid numerical issue.
      Var_j          = (1/2) * (M_j+t(M_j))

      #Sample fBar
      fBar[[i]][,j]  = complete_vec(mvtnorm::rmvnorm(1,mean=Mean_j,sigma=Var_j),m_max)
      #This fBar_noNA fetches the fBar, whose empty entries are NA, into a shorter vector by dropping the NAs.
      #Recall that NAs comes from the complete_vec function that allows us to record the fBar in a matrix form.
      fBar_noNA<-fBar[[i]][,j][!is.na(fBar[[i]][,j])]

      #Define prediction of component j with STEP-TAPERING: mean is 0 outside the domain of the component j.
      # Observed locations: avoid computing Knm - mean !=0 only on Xtrain
      mu.component.temp[,j] <- 0
      mu.component.temp[indexesEligX,j]  = (Ktrainm %*% KmmInv %*% fBar_noNA)
      # New locations: force mean to be 0 outside domain
      mu.new.component.temp[,j]          = (Knewm %*% KmmInv %*% fBar_noNA) * (indexCompNew[[layer_j]] %in% j)

      #
      #          Sampling fBar(END)          #
      ########################################

      ########################################
      #          Sampling rho(START)         #
      # MH step
      if(sampleRho) {
        #This commented part is not updated to multidimensional case
        # alpha   = pinfo$rho[[layer_j]]$alpha
        # beta    = pinfo$rho[[layer_j]]$beta
        # current_rho = rho[i,j]
        #
        # proposal_rho  <-  runif(1, min = (current_rho-semiWidthRho[j]), max = (current_rho+semiWidthRho[j]))
        #
        # #If acceptable proposal: compute acceptance prob. Otherwise, acceptance prob = 0.
        # if(proposal_rho>0 && proposal_rho<1) {
        #
        #   result_logLikProp <- logLikelihood(rho_j=proposal_rho,
        #                                      Y=Y_train,X=X_train,xBar_j=xBar_noNA,fBar_j=fBar_noNA,eta_j=eta[i,j],lambda=lambda[i],
        #                                      mu.component.temp = matrix(mu.component.temp[indexesEligX,],ncol=N),j_index=j)
        #   result_logLikCurr <- logLikelihood(rho_j=current_rho,
        #                                      Y=Y_train,X=X_train,xBar_j=xBar_noNA,fBar_j=fBar_noNA,eta_j=eta[i,j],lambda=lambda[i],
        #                                      mu.component.temp = matrix(mu.component.temp[indexesEligX,],ncol=N),j_index=j)
        #
        #   logPriorProp <- dbeta(proposal_rho, alpha, beta, log = T)
        #   logPriorCurr <- dbeta(current_rho, alpha, beta,log = T)
        #
        #   logPriorProp_fBar_j <- mvtnorm::dmvnorm(fBar_noNA,mean=rep(0,m_comp[j]),sigma=result_logLikProp$Kmm, log = T)
        #   logPriorCurr_fBar_j <- mvtnorm::dmvnorm(fBar_noNA,mean=rep(0,m_comp[j]),sigma=result_logLikCurr$Kmm, log = T)
        #
        #   if(logPriorProp_fBar_j==-Inf && logPriorCurr_fBar_j==-Inf) {
        #     logPriorProp_fBar_j <- 0
        #     logPriorCurr_fBar_j <- 0
        #   }
        #
        #   acceptanceProb <- min(1,exp(result_logLikProp$logLik + logPriorProp + logPriorProp_fBar_j - result_logLikCurr$logLik - logPriorCurr - logPriorCurr_fBar_j))
        # } else {
        #   acceptanceProb <- 0
        # }
        #
        # #Number of rhos sampled
        # sampledRhos[j]<-sampledRhos[j]+1
        #
        # #Accept or reject with prob acceptanceProb
        # if(runif(1) < acceptanceProb){
        #
        #   #Accept! Count of accepted value + 1
        #   acceptCountRhos[j]<-acceptCountRhos[j]+1
        #   rho[i,j]<-proposal_rho
        #
        #   #If I update rho_j, I also need to update the mean
        #   Knewm<-makeKernel(X1=Xnew,
        #                     X2=xBar_noNA,
        #                     kinfo=list(eta=eta[i,j],rho=rho[i,j]))
        #
        #   #Define prediction of component j with STEP-TAPERING: mean is 0 outside the domain of the component j.
        #   mu.component.temp[,j] = 0
        #   mu.component.temp[indexesEligX,j]  = result_logLikProp$mu.component.temp.new[,j]
        #   mu.new.component.temp[,j] = (Knewm %*% result_logLikProp$KmmInv %*% fBar_noNA) * (indexCompNew[[layer_j]] %in% j)
        #
        # }else{
        #   #Reject!
        #   rho[i,j]<- current_rho
        # }
        #
        # #Adapt semiWidthRho[j]:
        # # - every burnIn/20 iterations.
        # # - leave last 5% of burnin iterations without adapting semiwidth of proposal.
        # if(  i %% (burnIn/20) == 0 && i < (burnIn*19/20+1)  )
        # {
        #   rate_rho = acceptCountRhos[j]/sampledRhos[j]
        #   if(rate_rho>.49 || rate_rho<.39) {
        #     semiWidthRho[j]=semiWidthRho[j]*rate_rho/.44
        #   }
        #   acceptCountRhos[j] <- 0
        #   sampledRhos[j] <- 0
        # }

      }else{

        #If rho is not sampled, set it to fixed value
        rho[i,j,] <- rep(pinfo$rho[[layer_j]], D)

      }

      #           Sampling rho(END)          #
      ########################################

      ########################################
      #          Sampling eta(START)         #
      # MH step
      if(sampleEta) {
        a_eta   = pinfo$eta[[layer_j]]$a
        b_eta   = pinfo$eta[[layer_j]]$b
        current_eta = eta[i,j]

        proposal_eta  <-  runif(1, min = (current_eta-semiWidthEta[j]), max =  (current_eta+semiWidthEta[j]))

        #If acceptable proposal: compute acceptance prob. Otherwise, acceptance prob = 0.
        if(proposal_eta>0) {

          result_logLikProp <- logLikelihood(eta_j = proposal_eta,
                                             Y=Y_train,X=X_train,xBar_j=xBar_noNA,fBar_j=fBar_noNA,rho_j=rho[i,j,],lambda=lambda[i],
                                             mu.component.temp = matrix(mu.component.temp[indexesEligX,],ncol=N),j_index=j)
          result_logLikCurr <- logLikelihood(eta_j = current_eta,
                                             Y=Y_train,X=X_train,xBar_j=xBar_noNA,fBar_j=fBar_noNA,rho_j=rho[i,j,],lambda=lambda[i],
                                             mu.component.temp = matrix(mu.component.temp[indexesEligX,],ncol=N),j_index=j)

          logPriorProp <- dgamma(proposal_eta, a_eta, b_eta,log = T)
          logPriorCurr <- dgamma(current_eta , a_eta, b_eta,log = T)

          logPriorProp_fBar_j <- mvtnorm::dmvnorm(fBar_noNA,mean=rep(0,m_comp[j]),sigma=result_logLikProp$Kmm, log = T)
          logPriorCurr_fBar_j <- mvtnorm::dmvnorm(fBar_noNA,mean=rep(0,m_comp[j]),sigma=result_logLikCurr$Kmm, log = T)

          if(logPriorProp_fBar_j==-Inf && logPriorCurr_fBar_j==-Inf) {
            logPriorProp_fBar_j <- 0
            logPriorCurr_fBar_j <- 0
          }

          acceptanceProb <- min(1,exp(result_logLikProp$logLik + logPriorProp + logPriorProp_fBar_j - result_logLikCurr$logLik - logPriorCurr - logPriorCurr_fBar_j))
        } else {
          acceptanceProb <- 0
        }
        print(acceptanceProb)
        #Number of etas sampled
        sampledEtas[j]<-sampledEtas[j]+1

        #Accept or reject with prob acceptanceProb
        if(runif(1) < acceptanceProb){

          #Accept! Count of accepted value + 1
          acceptCountEtas[j]<-acceptCountEtas[j]+1
          eta[i,j]<- proposal_eta

          #If I update eta_j, I need to update the mean
          Knewm<-makeKernel(X1=Xnew,
                            X2=xBar_noNA,
                            kinfo=list(eta=eta[i,j],rho=rho[i,j,]))

          #Define prediction of component j with STEP-TAPERING: mean is 0 outside the domain of the component j.
          mu.component.temp[,j] = 0
          mu.component.temp[indexesEligX,j]  = result_logLikProp$mu.component.temp.new[,j]
          mu.new.component.temp[,j] = (Knewm %*% result_logLikProp$KmmInv %*% fBar_noNA) * (indexCompNew[[layer_j]] %in% j)
          #print(Knewm)
        } else {
          #Reject!
          eta[i,j]<- current_eta
        }

        #Adapt semiWidthEta[j]:
        # - every burnIn/20 iterations.
        # - leave last 5% of burnin iterations without adapting semiwidth of proposal.
        if( i %% (burnIn/20) == 0 && i < (burnIn*19/20+1) ) {
          rate_eta = acceptCountEtas[j]/sampledEtas[j]
          if(rate_eta>.49 || rate_eta<.39) {
            semiWidthEta[j]=semiWidthEta[j]*rate_eta/.44
          }
          acceptCountEtas[j] <- 0
          sampledEtas[j] <- 0
        }

      } else {
        #Set eta to fixed value
        eta[i,j] <- 1
      }

      #           Sampling eta(END)          #
      ########################################
    }

    # Save in-sample prediction of this iteration
    mu.temp      <- apply(mu.component.temp    ,1,sum)
    mu.new.temp  <- apply(mu.new.component.temp,1,sum)

    ########################################
    #        Sampling lambda(START)        #

    # Draw lambda, reciprocal of error variance, using gamma normal conjugacy.
    # D_mcmc_overall is the residual in this step of MCMC loop.
    D_mcmc_overall     <- Y-mu.temp
    lambda[i]          <- rgamma(1,pinfo$a+n/2,pinfo$b+0.5*t(D_mcmc_overall)%*%D_mcmc_overall)

    #         Sampling lambda(END)         #
    ########################################

    #Store predictions only after burnin to save space
    if(i>burnIn) {

      #Store predictions at observed locations only if requested (it requires *A LOT* of space if n large)
      if(storePredX==T) {
        #Mean in observed location
        mu[,i-burnIn] <- mu.temp*sdY + meanY
        #Prediction in observed location
        Yhat[,i-burnIn] <- (mu.temp + rnorm(n,sd=sqrt(1/lambda[i])))*sdY + meanY
        #Mean of each component in observed location
        mu.component[[i-burnIn]] <- mu.component.temp*sdY
      } else {
        mu.component[[i-burnIn]] <- NULL
      }

      #Predictions of mean in new locations
      mu.new[,i-burnIn] <- mu.new.temp*sdY + meanY
      #Prediction in observed location
      Yhat.new[,i-burnIn] <- (mu.new.temp + rnorm(nNew,sd=sqrt(1/lambda[i])))*sdY + meanY
      #Prediction of mean of each component in new locations
      mu.new.component[[i-burnIn]]<- mu.new.component.temp*sdY
    }

  }
  close(pb)

  return(list(#data provided as input:
              Y=Y*sdY + meanY,
              X=X,
              Xnew=Xnew,
              #parameters provided as input:
              pinfo=pinfo, minfo=minfo, tinfo=tinfo,
              sampleRho=sampleRho, sampleEta=sampleEta,storePredX=storePredX,
              #MCMC samples:
              mu=mu,                                #mu has Nmcmc elements, only stored the samples after burn-in
              mu.component=mu.component,            #mu.component has Nmcmc elements, only stored the samples after burn-in
              Yhat=Yhat,                            #Yhat has Nmcmc elements, only stored the samples after burn-in
              mu.new=mu.new,                        #mu.new has Nmcmc elements, only stored the samples after burn-in
              mu.new.component=mu.new.component,    #mu.new.component has Nmcmc elements, only stored the samples after burn-in
              Yhat.new=Yhat.new,                    #Yhat.new has Nmcmc elements, only stored the samples after burn-in
              xBar=xBar[(burnIn+1):(burnIn+Nmcmc)],
              fBar=fBar[(burnIn+1):(burnIn+Nmcmc)],
              draw.lambda=lambda[(burnIn+1):(burnIn+Nmcmc)],
              draw.rho=rho[(burnIn+1):(burnIn+Nmcmc),,],
              draw.eta=eta[(burnIn+1):(burnIn+Nmcmc),],
              #Info of MH samples
              acceptRateRhos=acceptCountRhos/sampledRhos,
              acceptRateEtas=acceptCountEtas/sampledEtas,
              semiWidthRho=semiWidthRho,
              semiWidthEta=semiWidthEta,
              #Data frame for correspondence between layer and components--e.g., layer=data.frame(comp=c(1,2,3),layer=c(1,2,2))
              layers=layers,
              m_comp=m_comp,m_compActual=m_compActual)
         )
}

# logLikelihood
# log-Likelihood of the model, used in MH steps to sample rhos and etas.
logLikelihood <- function(Y,X,xBar_j,fBar_j,rho_j,eta_j,lambda,mu.component.temp,j_index){

  Knm <- makeKernel(X1=X,
                    X2=xBar_j,
                    kinfo=list(eta=eta_j,rho=rho_j))
  Kmm <- makeKernel(X1=xBar_j,
                    X2=xBar_j,
                    kinfo=list(eta=eta_j,rho=rho_j))

  #Inversion of Kmm: same trick as before.
  sfu2   <- sum( diag(Kmm)/(dim(Kmm)[1]) )
  sfu    <- sqrt(sfu2)
  snu    <- sfu/1e3
  snu2   <- snu^2
  Kmm    <- Kmm +  snu2*diag((dim(Kmm)[1]))
  KmmInv <- chol2inv(chol(Kmm))

  #Update the j-th component of the mean
  mu.component.temp[,j_index] = Knm %*% KmmInv %*% fBar_j

  #Computation of Lambda_j: same trick as before
  diag_Knm_KmmInv_Kmn <- rep(NA,nrow(X))
  for(iDiag in 1:nrow(X)) {
    diag_Knm_KmmInv_Kmn[iDiag] <- matrix(Knm[iDiag,],ncol=(dim(Kmm)[1])) %*% KmmInv %*% matrix(Knm[iDiag,],nrow=(dim(Kmm)[1]))
  }
  Lambda_j_diag <- rep(1/eta_j,nrow(X)) - diag_Knm_KmmInv_Kmn

  #log-likelihood
  # We should compute this:
  # logLikelihood <- mvtnorm::dmvnorm(x=as.vector(Y),
  #                                   mean=rowSums(mu.component.temp),
  #                                   sigma=diag(Lambda_j_diag + 1/lambda ), log = T)
  # However, the covariance matrix is diagonal and mvtnorm::dmvnorm does not take advantage of the diagonal structure to compute its inverse.
  # The computational time was prohibitive for n~10,000. Simply replace the evaluation of the log-likelihood with the pdf of
  # multivariate normal

  #Vector of (Y[i] - X[i])^2
  vector_YminMeaSq <- (as.vector(Y) - rowSums(mu.component.temp))^2
  #Vector of sigma^2[i]
  vectorVariances <- (Lambda_j_diag + 1/lambda )
  #log-likelihood
  logLikelihood <- - .5 * sum(log(vectorVariances)) - 0.5 * nrow(X) * log(2 * pi) + #determinant
    - 0.5 * sum(vector_YminMeaSq/vectorVariances) #part in exponent

  return(list(logLik=logLikelihood,
              mu.component.temp.new=mu.component.temp,
              Kmm=Kmm,
              KmmInv=KmmInv))

}

#generateTree
# generate a partition tree in the domain, given:
# - domain: list of length D, each element is a vector c(Xmin,Xmax) in that dimension
# - the number of layers L
# - base: vector of length D, each element tells how many times the tree should partition that dimension
generateTree <- function(domain, L, base=rep(2,length(domain))) {

  #Dimension
  D <- length(domain)

  tinfo <- list()
  #For each layer:
  for(l in 1:L) {
    #Compute the coordinates of the centers of the components in each dimensions
    # and store them in the list list_loc_l
    list_loc_l <- list()
    for(d in 1:D) {
      loc_temp <- seq(from = domain[[d]][1], to = domain[[d]][2], length.out = (2*base[[d]]^(l-1) + 1) )
      #Take the even components: they are the locations
      loc_d <-loc_temp[seq(from=2,to=length(loc_temp),by=2)]
      list_loc_l[[d]] <- loc_d
    }
    #The centers of the components are the D-dimensional grid based on the points in list_loc_l
    tinfo[[l]] <- list(loc = as.matrix(expand.grid(list_loc_l)))

    tinfo[[l]]$rad <- matrix(NA, nrow=nrow(tinfo[[l]]$loc), ncol=D)
    for(d in 1:D) {
      tinfo[[l]]$rad[,d] <- (domain[[d]][2]-domain[[d]][1])/(2*base[[d]]^(l-1))
    }

  }
  return(tinfo)
}

#ids_X_comp
#Extract the ids of the X that belong to the component with
#center 'loc' and radius 'rad'
ids_X_comp <- function(X,loc,rad) {
  D=ncol(X)
  ids_output <- which(rowSums(sapply(1:D,
                                     function(id_col) {
                                       abs(X[,id_col, drop = FALSE] - loc[id_col]) <= rad[id_col]
                                       }
                                     )
                              ) == D)
  return(ids_output)
}

ids_X_comp_old <- function(X,loc,rad) {
  absDiff_X_loc <- matrix(apply(X, FUN=function(x){abs(x-loc)}, 1),ncol=nrow(X))
  boolean_by_dim <- matrix(apply(absDiff_X_loc,FUN=function(x){x<=rad},2),ncol=nrow(X))
  boolean_X_comp <- apply(boolean_by_dim, FUN=all, 2)
}


plotdata <- read.csv("results_odds.tsv", header = TRUE, sep = "\t")

plotdata$modeltype <- toupper(plotdata$modeltype)
plotdata$rmse_odds <- sqrt(plotdata$oddsdelta)

reportNumber <- function(x, nsmall = 2) {
  sapply(x, function(x) {format(x, digits = 2, nsmall = nsmall, decimal.mark = ".")})
}

getQuantiles <- function(plotdata, col) {
  ret <- lapply(list(1,2,5,20), function(nsites) {
      ret <- lapply(list("DBM", "GAN", "IM", "MICE", "VAE"), function(modeltype) {
        qs <- quantile(plotdata[plotdata$nsites == nsites & plotdata$modeltype == modeltype, col],
                       probs = c(0.05, 0.5, 0.95))
        qstring <- paste0(reportNumber(qs[2]), " (", reportNumber(qs[1]), " - ", reportNumber(qs[3]), ")")
        ret <- list()
        ret[[modeltype]] <- qstring
        ret
      })
      ret <- unlist(ret, recursive = TRUE)
  })
  ret <- Reduce(rbind, ret)
  rownames(ret) <- c(1,2,5,20)
  write.table(t(ret), file = paste0("quantiles_", col, ".tsv"), sep = "\t")
}

plotORdist <- function(plotdata) {
  plotdata <- aggregate(rmse_odds ~ datasetindex + modeltype + nsites,
                        data = plotdata, FUN = min)
  par(mfrow = c(2,2))

  ymax <- max(plotdata$rmse_odds[is.finite(plotdata$rmse_odds)])

  ylablogor = "RMSE of ORs"
  boxplot(rmse_odds ~ modeltype,
          data = plotdata[plotdata$nsites == 1, ], ylab = ylablogor,
          xlab = "", ylim = c(0, ymax))
  title("One site")

  boxplot(rmse_odds ~ modeltype,
          plotdata[plotdata$nsites == 2, ], ylab = ylablogor,
          xlab = "", ylim = c(0, ymax))
  title("Two sites")

  boxplot(rmse_odds ~ modeltype,
          plotdata[plotdata$nsites == 5, ], ylab = ylablogor,
          xlab = "", ylim = c(0, ymax))
  title("5 sites")

  boxplot(rmse_odds ~ modeltype,
          plotdata[plotdata$nsites == 20, ], ylab = ylablogor,
          xlab = "", ylim = c(0, ymax))
  title("20 sites")

  getQuantiles(plotdata, "rmse_odds")
}

plotDisclosureMetric <- function(plotdata) {
  plotdata2 <- aggregate(rmse_odds ~ datasetindex + modeltype + nsites,
                        data = plotdata, FUN = min)
  plotdata <- merge(plotdata2, plotdata)

  plotdata$discmetric <- (plotdata$rmse_odds - sqrt(plotdata$oddsdeltatrain))/
    plotdata$rmse_odds

  ymax <- max(plotdata$discmetric[is.finite(plotdata$discmetric)])
  ymin <- min(plotdata$discmetric[is.finite(plotdata$discmetric)])
  ylim <- c(ymin, ymax)

  par(mfrow = c(2,2))

  ylablogor <- "Proportion of overfitting"
  boxplot(discmetric ~ modeltype,
          data = plotdata[plotdata$nsites == 1, ], ylab = ylablogor,
          xlab = "", ylim = ylim)
  title("One site")

  boxplot(discmetric ~ modeltype,
          plotdata[plotdata$nsites == 2, ], ylab = ylablogor,
          xlab = "", ylim = ylim)
  title("Two sites")

  boxplot(discmetric ~ modeltype,
          plotdata[plotdata$nsites == 5, ], ylab = ylablogor,
          xlab = "", ylim = ylim)
  title("5 sites")

  boxplot(discmetric ~ modeltype,
          plotdata[plotdata$nsites == 20, ], ylab = ylablogor,
          xlab = "", ylim = ylim)
  title("20 sites")

  getQuantiles(plotdata, "discmetric")
}

pdf(file = "ordist.pdf", width = 9, height = 8)
plotORdist(plotdata)
dev.off()

pdf(file = "overfitting.pdf", width = 9, height = 8)
plotDisclosureMetric(plotdata)
dev.off()


hh = c(1.65,1.7,1.75,1.8,1.85)
eq = function(x){x*x}
plot(eq(hh), type='l')


library(changepoint)

#check_tab <- readLines("E:\\airbox-May.csv")
air_data <- read.table("E:\\airbox-May.csv", header = FALSE)
#names(air_data) <- c("date-time", "ID", "PM25", "T", "Humid", "Coor_x", "Coor_y")
colnames(air_data) <- c("date_time", "ID", "PM25", "T", "Humid", "Coor_x", "Coor_y")

air_data$date_d <- sapply(air_data$date_time, substr, start = 1, stop = 10)
air_data$time_d <- sapply(air_data$date_time, substr, start = 12, stop = 19)

sensor_ID <- unique(air_data$ID)
#data_of_sensor <- which(air_data$ID %in% sensor_ID[1])
for(i in 1:length(sensor_ID)){
	PM25_of_sensor <- subset(air_data, ID == sensor_ID[i], select = PM25)
	if( length(PM25_of_sensor$PM25) < 10 ) next
	#is.data.frame(PM25_of_sensor)
	#PM25_of_sensor <- as.numeric(unlist(PM25_of_sensor)) 可以把他變成一個普通的vector
	#data.matrix(PM25_of_sensor)
	ansmeanvar=cpt.meanvar(PM25_of_sensor$PM25)
	plot(ansmeanvar)
	pic_name <- paste0("E:\\myGraph\\p", i,".png")
	dev.copy(png,pic_name)
	dev.off()
	cat ("Press [enter] to continue")
	line <- readline()
}


#------------------------------
# library
#------------------------------

library(data.table)
library(magrittr)
library(dtplyr)
library(dplyr)
library(digest)

#------------------------------
# set seed
#------------------------------

seed <- as.integer(commandArgs(trailingOnly=TRUE)[1])
if(is.na(seed)) seed <- 1000
cat("seed: ", seed, "\n - - - - - - - - - -\n")

set.seed(seed)

#------------------------------
# function
#------------------------------

source("get_features_duplicated.r")

generate_output <- function(input, path){
	cat("==> Generate output\n")
	numeric_id <- fread(path, select="Id") %>% use_series(Id)
	data.frame(Id=numeric_id, is_duplicated=input)
}

remove_L3_S38 <- function(data){
	data[, -grep("^L3_S38_", colnames(data))]
}

#------------------------------
# main
#------------------------------

data_dir <- file.path("..", "..", "dataset")
input_dir <- file.path("..", "..", "input")

tic <- proc.time()

train_numeric_path <- file.path(data_dir, "train_numeric.csv")

fread(train_numeric_path, data.table=FALSE) %>%
	select(-Response) %>%
	select(-Id) %>%
	remove_L3_S38 %>%
	apply(1, digest) -> train_digest

names(train_digest) <- fread(train_numeric_path, select="Id") %>% use_series(Id)

test_numeric_path <- file.path(data_dir, "test_numeric.csv")

fread(test_numeric_path, data.table=FALSE) %>%
	select(-Id) %>%
	remove_L3_S38 %>%
	apply(1, digest) -> test_digest

names(test_digest) <- fread(test_numeric_path, select="Id") %>% use_series(Id)

joint_digest <- c(train_digest, test_digest)

joint_digest_order <- names(joint_digest) %>% as.integer %>% order
joint_digest <- joint_digest[joint_digest_order]

train_response <- fread(train_numeric_path, select="Response") %>% use_series(Response)
joint_response <- c(train_response, rep(NA, length(test_digest)))
joint_response <- joint_response[joint_digest_order]

train_date <- fread("../../input/train_date_features.csv") %>% use_series(date_mean)
test_date <- fread("../../input/test_date_features.csv") %>% use_series(date_mean)
joint_date <- c(train_date, test_date)
joint_date <- joint_date[joint_digest_order]

# gc -----

gc();gc();

# train --------------------

cat("==> Preprocess train data\n")

train_digest %>% get_features_duplicated %>%
	select(-Id) %>% as.matrix %>% inset(,, as.integer(.)) %>%
	generate_output(train_numeric_path) %>%
	write.table(file.path(input_dir, "train_is_duplicated.csv"), row.names=FALSE, quote=FALSE, sep=",")

# gc -----

gc();gc();

# test --------------------

cat("==> Preprocess test data\n")

test_digest %>% get_features_duplicated %>%
	select(-Id) %>% as.matrix %>% inset(,, as.integer(.)) %>%
	generate_output(test_numeric_path) %>%
	write.table(file.path(input_dir, "test_is_duplicated.csv"), row.names=FALSE, quote=FALSE, sep=",")

# display computational time -----

cat("==> Computational time\n")
proc.time() %>% subtract(tic) %>% print


# Visualize the differences between two datasets

# Comparing the parts used within Batman and Star Wars lego sets
# Input dataset
inventory_parts_themes <- inventories %>%
  inner_join(inventory_parts, by = c("id" = "inventory_id")) %>%
  arrange(desc(quantity)) %>%
  select(-id, -version) %>%
  inner_join(sets, by = "set_num") %>%
  inner_join(themes, by = c("theme_id" = "id"), suffix = c("_set", "_theme"))

# Create the batman dataset
batman_colors <- inventory_parts_themes %>%
  # Filter the inventory_parts_themes table for the Batman theme
  filter(name_theme == "Batman") %>%
  group_by(color_id) %>%
  summarize(total = sum(quantity)) %>%
  # Add a fraction column of the total divided by the sum of the total
  mutate(fraction = total / sum(total))

# Filter and aggregate the Star Wars set data; add a fraction column
star_wars_colors <- inventory_parts_themes %>%
  filter(name_theme == "Star Wars") %>%
  group_by(color_id) %>%
  summarize(total = sum(quantity)) %>%
  # Add a fraction column of the total divided by the sum of the total
  mutate(fraction = total / sum(total))

# 1. Combining sets
batman_colors %>%
  full_join(star_wars_colors, by = "color_id", suffix = c("_batman", "_star_wars")) %>%
  replace_na(list(total_batman = 0, total_star_wars = 0)) %>%
  inner_join(colors, by = c("color_id" = "id")) %>%
  # Create the difference and total columns
  mutate(difference = fraction_batman - fraction_star_wars,
         total = total_batman + total_star_wars) %>%
  # Filter for totals greater than 200
  filter(total > 200)

# 2. Visualizing the difference
# Create a bar plot using colors_joined and the name and difference columns
ggplot(colors_joined, aes(name, difference, fill = name)) +
  geom_col() +
  coord_flip() +
  scale_fill_manual(values = color_palette, guide = FALSE) +
  labs(y = "Difference: Batman - Star Wars")


pdf_file<-"pdf/timeseries_scatterplots_8x5.pdf"
cairo_pdf(bg="grey98", pdf_file,width=8.27,height=11.7)
par(omi=c(0.25,0.1,0.7,0.1),mai=c(0.1,0.1,0.45,0.1),mfrow=c(9,5),family="Lato Light",las=1)

source("scripts/inc_datadesign_dbconnect.r")

# Read data and prepare chart

myCountry<-c("ARG","AUS","AUT","BGR", "CAN","CHL", "CHN", "CZE", "DEU", "DNK",
	 "DOM", "EST", "FIN", "FRA", "GBR", "HRV", "HUN", "IRL", "ISR", "ITA",
	 "JPN", "KOR", "LVA", "MEX", "NLD", "NOR", "NZL", "PHL", "POL", "PRT",
	 "RUS", "SVK", "SVN", "ESP", "SWE", "TUR", "TWN", "UKR", "USA", "ZAF")
myPart1<-"select Year, Gini from v_wiid2c_Gini where Country3='"
myPart2<-"'"
for (i in 1:length(myCountry))
{
sql1<-paste(myPart1,myCountry[i],myPart2,sep="")
sql2<-paste(myPart1,myCountry[i],myPart2," and Gini > 36",sep="")
myData<-dbGetQuery(con,sql1)
myData2<-dbGetQuery(con,sql2)

# Create chart and other elements

plot(myData,xlim=c(1950,2010),ylim=c(10,75),main=myCountry[i], type="n",axes=F)
rect(1950,36,2010,75,col=rgb(255,0,0,50,maxColorValue=255),lwd=0)
rect(1950,0,2010,36,col=rgb(68,90,111,50,maxColorValue=255),lwd=0)
points(myData,col=rgb(68,90,111,100,maxColorValue=255),pch=19,type="b")
axis(1,at=c(1950,2010),col=par("bg"),cex.axis=0.95)
if (length(myData2) > 0)
{
points(myData2,pch=19,col=rgb(255,0,0,100,maxColorValue=255))
}
}

# Titling

mtext("Inequality in 40 countries 1950-2010",3,outer=T,line=2,xpd=T,adj=0,family="Lato Black",cex=1.3)
mtext("Gini coefficient of income distribution (yearly values)",3,outer=T,line=0,xpd=T,adj=0,font=3)
mtext("Source: World Income Inequality Database V2.0c May 2008",1,outer=T,line=-3,xpd=T,adj=0.9,font=3)
mtext("Blue: up to 0.36. Red: more than 0.36",1,outer=T,line=-3,xpd=T,adj=0,font=3)
dev.off()


#' @title truncate_distribution
#' @description the following truncates data to a range limited by quantiles or fixed limits
#' @param \code{W} NULL
#' @param \code{Ql} NULL
#' @param \code{Qu} NULL
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
truncate_distribution = function( W, Ql, Qu ) {
        Q = quantile( W, c(Ql, Qu), na.rm=T )
        j = which( W < Q[1] )
        k = which( W > Q[2] )
        if (length( j)>0 ) W[j] = Q[1]
        if (length( k)>0 ) W[k] = Q[2]
        return (W)
      }


###################################################################################
# R-script submitted as Supplementary Information to Seebens et al. (2016) No
# saturation in the accumulation of alien species worldwide. Nature Communications ....
#
# The script is called by the file Rcode_Seebens-etal_InvasionModel_PropPress_MAIN.r
# which reproduces the modelling results shown in Supplementary Fig. 5 of the article.
#
# This file simulates the model scenario: increase related to number of botanic gardens.
#
# The model implemented here describes the temporal development of the
# accumulation of alien species on an island, which were randomly depicted
# from an arbitrary mainland community. The probability of depicting a species
# may change during the simulation depending on the scenario to account for increases
# in propagule and colonisation pressures due to e.g. increases of trade volumes.
# For further details, consult the article.
# Five scenarios were simulated assuming different increases in the rate of
# introduction (constant, linear or exponential increase, related to import
# volumes or the number of founded botanic gardens).
#
# The code is free of use as long as the article is properly cited.
#
# Author of code: Hanno Seebens, Frankfurt, Germany
# 25. August, 2016
###################################################################################

##### Defintion of objects/variables for simulation ###########################################################

n_spec <- 50000 # number of species of the mainland community
t_max <- 202000 # max simulation time

n_bins <- 1000 # number of steps abundances of the mainland community are stored

add <- "botgar" # type of increase in propagule pressure, required for output file

## Define temporal development of propagule pressure ###########################################################

## calculate propagule pressure as a function of newly founded botanical gardens ###############################
# The year of foundation of botanical gardens can be obtained from Botanic Gardens Conservation International
# (https://www.bgci.org/). We selected the years of foundation for botanic gardens in those countries, which
# have records of vascular plants in our first record database resulting in 2762 years of foundation:
botgar <- c(1971,1832,1898,1929,1988,1980,1989,1947,1924,2006,1963,1995,1997,1988,1999,1855,1952,1928,1877,1997,1956,1971,1996,1984,1964,1967,1987,1902,1901,1993,1887,1901,1949,1926,2005,1993,1981,1966,1983,1985,1970,1886,1957,1984,
            1946,1978,1988,1965,1976,1998,1988,1941,1967,1988,1953,1818,1978,1951,1968,1955,1982,1990,1981,1991,1988,2003,1994,1965,1864,1965,1989,1992,1984,1986,1984,1970,1980,1964,1980,1958,1961,1992,1961,1928,1960,1970,1981,1968,
            1929,1986,1988,2001,1981,1933,1898,1966,1976,1970,1816,1992,1986,1987,1985,1976,1932,1932,1970,1969,1988,1983,1969,1895,1964,1982,1974,1914,1947,1887,1954,1909,1952,1993,1987,1997,1754,1950,1973,1980,1910,1954,1983,1966,
            1979,1960,1981,1922,1978,1980,1985,1797,1899,1985,1952,1970,1937,2011,1902,1962,1991,1986,1984,1994,1998,1991,1968,1974,1985,1998,1990,1991,1992,1997,1998,2000,2003,1961,1808,1994,1938,1978,1997,1948,1930,1967,1959,1976,
            1993,1967,1926,1970,1942,2000,1985,1967,1998,1980,1931,2000,1924,1936,2000,1990,1950,1966,1999,1980,1970,1998,1971,1952,1972,1975,1958,1973,1916,1971,1904,1979,1968,1908,1904,1968,1999,1987,1994,1970,1970,1969,1960,1956,
            2006,1972,1955,1951,1977,1982,1985,1983,1991,1985,1959,1989,1985,1986,1980,1964,1929,1927,1956,1985,1956,1952,1871,1981,1986,1938,1983,1934,1980,1947,1954,1929,1958,1976,1974,1976,1955,1963,1983,2010,1956,1976,1976,1962,
            1956,2007,1959,1955,1985,1981,1915,1959,1980,1986,1982,2004,1955,1982,1979,2001,1983,1968,1960,1979,1969,1997,1988,1968,1960,1976,1967,1963,1889,1902,1968,1996,1929,1936,1922,1975,1954,1980,1901,1956,1961,1969,1931,1961,
            1927,1963,1958,2002,1943,1923,1970,1858,1976,1936,1933,1991,1976,1942,1958,1928,1875,1960,1961,1984,2010,1958,1988,1902,1678,1985,1982,1960,1978,1924,1936,1987,1953,1993,1957,1986,1977,1689,1953,1988,1976,1947,1942,1986,
            1992,1979,1979,1989,1899,2008,1970,1948,1983,1958,1970,1857,1903,1985,1986,1999,1987,1987,1905,1987,1990,1593,1901,1982,1965,1624,1994,1867,1995,1626,1777,1969,1986,1970,1986,1924,1988,1993,1992,1906,1932,1924,1965,1887,
            1843,1975,1968,1912,1845,1912,1953,1936,1971,1978,1879,1912,1968,1818,1989,1936,1955,1874,1905,1979,1945,1927,1868,1948,1945,1609,1736,1970,1967,1965,1927,1593,1586,1912,1970,1669,1864,1963,1973,1928,1946,1975,1977,1803,
            1901,1914,1975,1882,1984,1927,1950,1977,1885,1952,1903,1998,1846,1776,1910,1890,1905,1970,1965,1950,1835,1965,1947,2000,2004,2000,2007,2001,1984,1820,1963,1771,1771,1954,1928,1951,1922,1952,1961,1912,1930,1964,1978,1962,
            1962,1960,1923,1975,1964,2019,1973,1963,1964,1965,1985,1971,1975,1918,1971,1991,1961,1986,1971,1906,1979,1948,1958,1934,1947,1976,1963,1786,1958,1963,1787,1908,1968,1934,1951,1953,1964,1973,1970,1930,1964,1967,1981,1972,
            1980,1958,1961,1979,1978,1946,1966,1959,1980,1979,1979,1968,1972,1969,1963,1959,1817,1852,1941,1968,1931,1850,1795,1948,1968,1994,1958,1948,1930,1933,1954,1949,1971,1954,1987,1985,1972,1998,1981,1568,1979,1990,1828,1938,
            1858,1955,1984,1984,1771,1990,1904,1545,1959,1990,1980,1967,1994,1953,1980,1966,2001,1774,1954,1807,1989,1545,1933,1985,1720,1981,1955,1979,1967,1984,1988,1961,1968,1953,1991,1964,1965,1876,1938,1964,1842,1962,1951,1983,
            1990,1985,1955,1969,1961,1961,1984,1985,1952,1965,1930,1980,1971,1921,1976,1969,1939,1974,1976,1985,1974,1976,1971,1969,1967,1961,1950,1967,1957,1933,1958,1954,1933,1953,1924,1964,1958,1964,1911,1953,1968,1929,1958,1955,
            1961,1945,1684,1988,1980,1979,2002,2002,1948,1990,1940,1907,1990,1938,1922,1956,1997,1958,1923,1997,1958,1781,1925,1980,1987,1987,1926,1981,1974,1982,1976,1970,1981,1986,1989,1971,1974,1982,1977,1967,1990,1979,1979,1986,
            2002,1980,1982,1985,1978,1929,1983,1976,1979,1959,1987,1983,2005,1993,1994,1987,1993,2005,1990,1993,1970,1978,1991,1989,1980,1999,1949,2002,1976,1968,1974,1950,1997,1952,1961,1982,1863,1863,1910,1951,1927,1947,1966,1926,
            1868,1999,1954,1948,1976,1978,1958,1986,1969,1814,1971,1991,1973,1989,2006,1912,1999,1965,1973,2007,1959,1968,1968,1977,1980,1947,1930,1925,1951,1946,1960,1963,1989,1984,1925,1924,1947,1933,1925,1974,1890,1811,1953,1986,
            1960,1768,1878,1906,1951,2000,1970,1987,1901,1971,1991,1987,1903,1920,2000,1953,1856,1968,2018,1952,1913,1983,1991,1903,1960,1903,1960,1986,1859,1942,1967,1950,1982,1892,1965,1977,1959,1967,1927,1913,1849,1989,1996,1853,
            1967,1970,1982,1969,2008,1957,1874,1962,1934,1958,1976,1991,1922,1921,1979,2006,1967,1965,1966,1999,1987,1969,1989,2003,1987,1976,1991,1934,1988,1918,1952,1979,2003,2000,1952,2007,1755,1994,1945,1965,1986,1567,1962,1986,
            1950,1986,1964,1923,1860,1981,1970,1859,1968,1589,1968,1950,1925,1937,1943,1927,1946,1965,1896,1954,1945,1977,1931,1966,1906,1999,1896,1990,1902,2006,1953,1993,1993,2011,1941,1978,1968,1988,1993,1913,1919,1990,1999,1972,
            1950,1964,2009,1949,1935,1980,2003,1898,2001,1945,2000,1877,1930,1931,1963,1930,1934,1921,1935,1928,1974,1977,1934,1965,1912,1796,1946,1963,1933,2001,1963,1988,1977,1925,1929,1829,1903,1997,1906,1996,1955,1934,1971,1971,
            1670,1922,1817,1950,1950,1965,1948,1946,1921,1964,1673,1910,1975,1898,1997,1967,1621,1923,1972,1953,1966,1836,1951,1961,1950,1889,1978,1968,1960,1926,1856,1991,1996,1971,1986,1938,1904,1969,1970,1981,2000,1995,1986,1907,
            1948,1960,1986,1980,1995,1968,1976,1985,1889,1963,1982,1982,1935,1970,1981,1922,1984,1991,2000,1991,1940,1892,1911,1997,1964,1984,1984,1991,1872,1992,1987,1972,1907,1891,1965,1966,1910,1900,1831,1972,1990,1975,1971,1912,
            1934,1967,1961,1966,1870,1968,1966,1768,1958,1956,1977,1908,1890,2004,1873,1873,1933,1845,1927,1958,1929,1930,1970,2002,1977,1999,1895,1981,1938,1947,1959,1965,1983,1926,1974,1936,1997,1885,1927,1936,1962,1990,2000,1999,
            1951,1979,1955,1976,1990,1966,1980,1932,1999,1934,1873,1965,1975,2000,1990,1999,1963,1961,1926,1972,1951,1973,1992,1991,1950,1994,1989,1993,1981,1959,1939,1961,1974,1947,1984,1985,1983,1933,1931,1984,1971,1978,1953,1983,
            1948,1987,1965,2001,1995,1982,2000,1925,1887,1996,1973,1939,1935,1974,1939,1978,1937,1981,1964,1922,1935,1963,1929,1970,1930,1918,1930,1956,1967,1999,1974,1992,1988,1926,1978,1970,1935,1926,1925,1989,1998,2007,1964,1960,
            1967,1974,2001,2004,1906,1978,2005,2009,1937,2006,1957,1988,1931,1983,1968,1954,1981,1971,2002,1929,1987,1989,1948,2000,1990,1985,1991,1969,1922,1996,1961,1997,1929,1952,1934,1969,1974,1953,1955,1972,1985,1993,1962,1967,
            1946,1976,1953,1940,1922,1974,1980,1898,1936,1899,1971,1966,1959,1907,1974,1929,2000,1971,1909,1928,1988,1970,1931,1995,1917,1960,1988,1903,1934,1923,1934,1931,1884,1969,1936,1929,1950,1964,1942,1938,1900,1958,1895,1959,
            1929,1964,1988,1904,1958,2001,2008,1962,1983,1960,1934,1947,1963,1993,1955,1970,1961,1979,1976,1897,1932,1939,1967,1979,1952,1978,1893,1925,1928,1981,1963,1978,1991,1941,1976,1926,1972,1986,1959,1984,1925,1980,1963,1888,
            1999,1998,1959,1915,1973,1988,1961,1980,1916,1964,1937,1879,1993,1973,1903,1969,1993,1926,1964,1987,1973,1983,1832,1996,1975,1971,2002,1994,1972,1934,2003,1911,1912,1907,1958,1906,1999,1878,1936,1949,1903,1998,1998,1972,
            1985,1859,1965,1975,1989,1938,1976,1934,1977,1974,1994,1927,1929,1969,1977,1932,1997,1945,1964,1952,1964,1958,1985,2002,1999,1967,1937,1989,1986,1997,2001,1980,1961,2000,1957,1960,1972,1931,1950,1990,1926,2001,1816,1927,
            1916,1990,1852,1875,1975,1983,1958,1898,1972,1969,1955,1915,1901,1962,1930,1976,1908,1958,1979,1993,1972,1973,1956,1991,1967,1950,1962,1947)

botgar_ts <- as.data.frame(table(botgar),stringsAsFactors=F) # get annual time series of foundations
colnames(botgar_ts) <- c("Year","BotGar") # set column names
botgar_ts$Year <- as.numeric(botgar_ts$Year) # redefine column types
botgar_ts <- subset(botgar_ts,Year<2002) # consider only foundation during the time period of the first record database
botgar_ts[,2] <- cumsum(botgar_ts[,2]) # calculate cumulative sum of the annual number of foundations

raw <- cbind(1800:2000,NA) # create dummy file for the full time period to identify gaps in time series of botanic garden foundations
colnames(raw) <- c("Year","Dummy")
botgar_fullts <-merge(botgar_ts,raw,by=c("Year"),all=T)
botgar_fullts[which(is.na(botgar_fullts[,2])),2] <- approx(botgar_fullts[,2],xout=which(is.na(botgar_fullts[,2])),method="constant")$y # fill gaps with constant values
botgar_fullts <- subset(botgar_fullts,Year>1799) # cut entries before start of simulation (note that these early botanic gardens are still considered in the  cumulative number of foundations)

botgar_interpol <- approx(botgar_fullts[,1],botgar_fullts[,2],n=t_max) # interpolate annual values to achieve a continuous development of increasing propagule pressure according to the simulation time steps
timeaxis <- botgar_interpol[[1]] # identify time axis (for plotting)

# rescale accumulation of botanic gardens to get a propagule pressure comparable to other scenario runs
m_bg <- botgar_interpol[[2]]
m_bg <- m_bg/mean(m_bg)*0.05
m <- m_bg
###############################################################################################################

# define basic characteristics of community size #############################################################
mlog <- seq(-3,1,length.out=5) # size of communities (defined as mean of log-normal distribution) for different model scenarios
sdlog <- 300 # standard deviation of log-normal distribution, constant
run_tot <- length(mlog)*length(sdlog) # number of model scenarios

######### SIMULATION #########################################################################################

island <- matrix(0,nr=t_max,nc=run_tot+1) # results file
island[,1] <- 1:t_max # include time axis in first column
all_main <- matrix(0,nr=n_bins,nc=run_tot) # store communities (abundances and species)
x <- 0 # counter
for (j in 1:length(mlog)){# loop through model scenarios depending on the number of defined means
  for (i in 1:length(sdlog)){# loop through model scenarios depending on the number of defined standard deviations
    x <- x + 1 # increase counter

    ## define mainland community ###############################################
    specabund <- dlnorm((seq(0.1,2,length.out=n_bins)),meanlog=mlog[j],sdlog=1)*10000
    axis1 <- seq(10,10000,length.out=n_bins) # steps of storing individuals per species (for plotting)
    specabund <- ceiling(specabund) # avoid decimals in abundances
    specabund <- round(specabund/sum(specabund)*n_spec) # rescale numbers

    tot_spec <- sum(specabund) # number of species
    abundances <- rep(axis1,round(specabund)) # set abundances
    tot_abund <- sum(abundances) # number of individuals
    all_main[,x] <- specabund # store community
    print(tot_spec)
    print(tot_abund)

    #### simulation ############################################################################
    for (t in 1:t_max){ # loop through time steps

      ## select individual from mainland community and transfer it on the island
      if (runif(1)<m[t]){  # determine if new individual arrives, depending on propagule pressure m at time t
        ind <- runif(1)*tot_abund # if individual arrives, determine new individual
        spec <- max(which(c(0,cumsum(abundances))<=ind)) # select species accordingly
        # if (spec==-Inf) break #
        island[t,x+1] <- spec # store species entry at time t and scenario x
      }
    }
    ## process time series of arriving individuals
    dupl <- duplicated(island[,x+1]) # identify duplicated entries of species in time series
    island[which(dupl),x+1] <- 0 # set all duplicated entries to zero (i.e., remove all entries after the first occurrence of that species)
    island[which(!dupl),x+1] <- 1  # set all species numbers to 1 (species identity is not required any more)
  }
}

## calculate number of first records per year #####################
ts_round <- round(timeaxis) # get an annual time axis
isl_agg <- matrix(NA,nr=length(unique(ts_round)),nc=dim(island)[2]-1) # results files
for (i in 2:dim(island)[2]){
  isl_agg[,i-1] <- tapply(island[,i],ts_round,sum) # sum up number of new species per year
}

### output (only the information which is required to create the plot) ######################################
write.table(isl_agg,paste("SimInvAcc_VarMain_island_",add,".csv",sep=""),sep=";",row.names=F)
write.table(unique(ts_round),paste("SimInvAcc_VarMain_realtime_",add,".csv",sep=""),sep=";",row.names=F)
write.table(all_main,paste("SimInvAcc_VarMain_allmain_",add,".csv",sep=""),sep=";",row.names=F)
write.table(axis1,paste("SimInvAcc_VarMain_axis1_",add,".csv",sep=""),sep=";",row.names=F)
write.table(timeaxis[seq(1,t_max,length.out=200)],paste("SimInvAcc_VarMain_timeaxis_",add,".csv",sep=""),sep=";",row.names=F)
write.table(m[seq(1,t_max,length.out=200)],paste("SimInvAcc_VarMain_PropPress_",add,".csv",sep=""),sep=";",row.names=F)

information/Seebens - 2017 - No saturation in the accumulation of alien species/Rcode_Seebens-etal_InvasionModel_BotGar.r


library(Cairo)

CairoSVG( 'expressionXtalk_Other', width=6, height=2.5 )
par( mfrow=c(1,4), mai=c(1,.5,.5,0) )

pValCutoff = .05

data   = read.table( 'W:/2013_06_wnt_tgfb_crosstalk/qPCR/SKMEL2+MALME3/SKEML2+MALME3M.csv',sep=',',header=T,stringsAsFactors=F)
celltypes  = unique(data$Celltype)
treatments = c("ctrl+ctrl","BMP4+ctrl","ctrl+TGFB3","BMP4+TGFB3",
               "Wnt3A+ctrl","BMP4+Wnt3A","Wnt3A+TGFB3")
outNames   = c("ctrl","BMP4","TGFB3","BMP4+TGFB3",
               "Wnt3A","Wnt3A+BMP4","Wnt3A+TGFB3")
readouts   = c('AXIN2','SMAD7')

colors        = c('darkred','blue')

for( rIdx in 1:length(readouts)){
  for( celltype in celltypes ){
    readout      = readouts[rIdx]
    subdata      = data[data$Detector==readouts[rIdx] &
                        data$Celltype==celltype, ]
    subdata$RNA  = 2^(-subdata$dCT)
    ctrls        = subdata[subdata$Treatment == 'ctrl+ctrl', 'RNA']
    subdata$RNA  = subdata$RNA / mean(ctrls)
    ctrls        = ctrls / mean(ctrls)

    subdata$RNA  = log2(subdata$RNA)

    ylims        = range(subdata$RNA[subdata$Treatment %in% treatments])*1.1
    yvals        = (ceiling(ylims[1])):(floor(ylims[2]))

    plot( NA,NA, xlim=c(.5,length(treatments)+.5), xlab='',
         ylim=ylims,
         main=celltype, yaxt='n',
         ylab=paste('log2(relative',readout,'mRNA)'),xaxt='n')
    axis( 1, at=1:length(treatments),treatments,las=3)
    axis( 2, at=yvals )
    abline(h=0,col='gray',lty=3)

    for( x in 1:length(treatments)){
      values = subdata$RNA[subdata$Treatment==treatments[x]]
      lines( c(x,x), c(-1,1)*sd(values)+mean(values), col=colors[rIdx] )
      points( x, mean(values), pch=16,col=colors[rIdx])

      # SIGNIFICANCE
      isEqCtrl = t.test(subdata$RNA[subdata$Treatment==treatments[x]],
                        subdata$RNA[subdata$Treatment=='ctrl+ctrl'])$p.value
      if( isEqCtrl < pValCutoff){
        isEqCtrl = '*'
      }else{
        isEqCtrl = ''
      }

      axis(1,at=x,isEqCtrl,tick=F,col.axis=colors[rIdx])
    }
  }
}

dev.off()


avjac <- function (v1, v2) {
  av <- sapply (seq(1,length(v1)), function(i) {
    sv1 <- v1 [1:i]
    sv2 <- v2 [1:i]
    length (intersect(sv1, sv2)) / length (union(sv1, sv2))
  })

  mean (av)
}

# lists need to be same length
avjacMatrix <- function (listOfLists1, listOfLists2) {
  len <- length (listOfLists1)
  m <- sapply (seq(1,len), function(i) {
    row <- sapply (seq(1,len), function (j) {
      avjac (names(listOfLists1[[i]]), names(listOfLists2[[j]]))
    })
  })

  m
}

cosin <- function (v1, v2) {
  v1 %*% v2 / sqrt(v1%*%v1 * v2%*%v2)
}

convertToVector <- function (list1, list2) {
  # get names used in lists
  n1 <- names(list1)
  n2 <- names(list2)
  # find differences between names in list
  miss2 <- setdiff (n1, n2)
  miss1 <- setdiff (n2, n1)
  # add the missing names to each list with value zero
  list1[miss1] <- 0
  list2[miss2] <- 0
  # order the lists alphabetically
  list1 <- list1[order(names(list1))]
  list2 <- list2[order(names(list2))]

  # fire them out as vectors which can be compared
  vlist <- list(one=unlist(list1, use.names=F), two=unlist(list2, use.names=F))
  vlist
}

# lists need to be same length
cosinMatrix <- function (listOfLists1, listOfLists2) {
  len <- length (listOfLists1)
  m <- sapply (seq(1,len), function(i) {
    row <- sapply (seq(1,len), function (j) {
      vlist <- convertToVector (listOfLists1[[i]], listOfLists2[[j]])
      cosin (vlist$one, vlist$two)
    })
  })

  m
}

hungarian <- function (mat) {
  library (clue)
  # reduce by mins of rows and then columns
  #mat <- t(apply(mat,1,function(r) r - min(r)))
  #mat <- t(apply(mat,2,function(r) r - min(r)))
  # maximum is true cos we want the matches with highest scores, not lowest
  solve <- solve_LSAP (mat, maximum=TRUE)
  vals <- sapply (seq(1,length(solve)), function(i) mat[i, solve[i]])

  vals
}

topicStabilityMG <- function (listOfLists1, listOfLists2) {
  m <- cosinMatrix (listOfLists1, listOfLists2)
  hvals <- hungarian (m)
  mean (hvals)
}

getTopWordsWithScores <- function (corpus, docImps, dtm, topicCount=10, settings) {
  stm <- makeSupervisedTopicModel (corpus, docImps, matrix=dtm, topicCount=topicCount, settings=settings)
  topWords <- lapply (seq(1,topicCount), function(i) sort (stm$topics[i,], decreasing=TRUE)[1:10])
  topWords
}

topicStabilityForKTopicsMG <- function (corpus, docImps, dtm, topicCount=10, settings) {
  cat ("calculating for",topicCount,"topics","\n")

  results <- lapply (seq(1,settings$iter), function(i) {
    sampleTopWords <- getTopWordsWithScores (corpus, docImps, dtm, topicCount, settings)
  })

  results
}

overallTopicStability <- function (corpus, docImps, krange=seq(2,12), settings=list(iter=6, eit=30, mit=30, alpha = 1.0, trace=0L)) {
  library (parallel)

  dtm <- makeTermMatrices(corpus)$direct
  ptm <- proc.time()
  cl <- makeCluster (4)
  clusterEvalQ(cl, {library(topicmodels); library(lda); library(tm); library(clue)})
  clusterExport(cl=cl, varlist=c("corpus", "docImps", "dtm", "getTopWordsWithScores", "topicStabilityMG",
                                 "makeSupervisedTopicModel", "topicStabilityForKTopicsMG", "settings",
                                 "cosin", "convertToVector", "cosinMatrix", "hungarian"), envir=environment())

  results <- parLapply (cl, krange, function (i) topicStabilityForKTopicsMG (corpus, docImps, dtm, topicCount=i, settings=settings))

  stopCluster (cl)
  cat (proc.time() - ptm, "ms elapsed")

  #results

  uberResult <- sapply (seq(1,length(results)), function(k) {
    topicResults <- results [[k]]
    overallResult <- sapply (seq(2, length(topicResults)), function (m) {
      sapply (seq (1, m-1), function (n) {
        topicStabilityMG (topicResults[[m]], topicResults[[n]])
      })
    })

    unlist(overallResult)
  })

  uberResult
}

topicAccuracy <- function (corpus, docImps, settings, topicCount=10, stm=NA, lda_obj=NA) {
  # return result of slda for this topic size
  dtm <- makeTermMatrices(corpus)$direct

  if (is.na(stm)) {
    stm <- makeSupervisedTopicModel (dtm, docImps, settings, topicCount=topicCount)
  }

  # calculate what document scores should be if dog-fed back in
  if (is.na(lda_obj)) {
    lda_obj <- dtm2ldaformat(dtm)
  }
  predict <- slda.predict (lda_obj$documents, stm$topics, stm$model, alpha=settings$alpha, eta=0.1)

  # squares of differences
  res <- (as.vector(docImps) - predict[,1])
  res <- res * res

  # return results
  list(res=res, predict=predict[,1], mean = sqrt(mean(res)), topicCount=topicCount, corr = cor (docImps, predict[,1]))
}

parUberTopicAccuracy <- function (docImps, dtmdirect, settings = list(eit=50, mit=50, alpha=1.0, trace=0L)) {
  library (parallel)
  library (lda)

  lda_obj <- dtm2ldaformat(dtmdirect)
  # parallelise
  cl <- makeCluster (4)
  clusterEvalQ(cl, {library(topicmodels); library(lda); library(tm)})
  clusterExport(cl=cl, varlist=c("docImps", "dtmdirect", "settings", "lda_obj", "topicAccuracy", "makeSupervisedTopicModel"), envir=environment())
  ures <- parLapply (cl, seq(2,15), function (tsize) {
    topicAccuracy (docImps, dtmdirect, settings, topicCount=tsize, lda_obj=lda_obj)
  })
  stopCluster (cl)

  ures
}

drawUres <- function (ures) {
  m <- ures[[1]]$topicCount
  x  <- seq (m, m+length(ures)-1)
  y1 <- sapply (ures, function(i) i$mean)
  y2 <- sapply (ures, function(i) i$sd)
  plot(x,y1,type="l",col="blue")
  par(new=T)
  plot(x,y2,type="l",col="green", axes=F)
  axis (side=4)
}

drawStable <- function (data, start) {
  library (ggplot2)

  smean <- sapply (seq(1, length(data[1,])), function(i) mean (unlist(data[,i])))
  ssd <- sapply (seq(1, length(data[1,])), function(i) sd (unlist(data[,i])))
  tc <- seq(start, start+length(data[1,])-1)
  dframe <- data.frame (smean, ssd, tc)
  colnames (dframe) <- c("Mean", "SD", "topicCount")

  ggplot(dframe, aes(x=topicCount, y=Mean)) +
    geom_errorbar(aes(ymin=Mean-SD, ymax=Mean+SD), width=.1) +
    geom_line() +
    geom_point()

  #dframe
}

#' Produce visualisation of LDA topic corpus using LDAvis package
#'
#' Takes in corpus and supervised topic model and produces interactive web page with topics marked on it
#' @export
#' @param corpus TM document corpus
#' @param slda supervised LDA topic models
#' @return alpha optional SLDA variable, 1.0 if docs contain diverse material which the merged ones do
#' @return eta an even less explanatory optional SLDA variable, never found a plain words explanation for it yet. Best leave to default.
#' @return dir the directory name in which to place generated web pages. optional, default is "vis"
#' @examples
#' \dontrun{
#' makeLDAVisJSON (corpus, topicModel, dir="vis")
#' }
makeLDAVisJSON <- function (corpus, slda, alpha=1.0, eta=0.1, dir="vis") {
  library (LDAvis)
  library (servr)
  library (lda)

  theta <- t(apply(slda$document_sums + alpha, 2, function(x) x/sum(x)))
  phi <- t(apply(t(slda$topics) + eta, 2, function(x) x/sum(x)))

  matrix <- makeTermMatrices(corpus)$direct
  lda_obj <- dtm2ldaformat(matrix)

  docTokenCounts <- as.vector(rowSums(as.matrix(matrix)))
  termTokenCounts <- as.vector(colSums(as.matrix(matrix)))

  # create the JSON object to feed the visualization:
  json <- createJSON(phi = phi,
                     theta = theta,
                     doc.length = docTokenCounts,
                     vocab = lda_obj$vocab,
                     term.frequency = termTokenCounts
  )

  serVis(json, out.dir = dir, open.browser = TRUE)
}


library(randtoolbox)
library(dplyr)
library(rsm)

quiet <- function(x) {
  sink(tempfile())
  on.exit(sink())
  invisible(force(x))
}

iterations <- 2

search_space <- NULL
results <- NULL

# Resnet50
sobol_dim <- 54 * 2

# VGG19
# sobol_dim <- 19 * 2

starting_sobol_n <- 2 * sobol_dim

sobol_n <- starting_sobol_n

bit_min <- 1
bit_max <- 8

for(i in 1:iterations){
    temp_sobol <- sobol(n = sobol_n,
                        dim = sobol_dim,
                        scrambling = 3,
                        seed = as.integer((99999 - 10000) * runif(1) + 10000),
                        init = TRUE)

    rm(temp_sobol)
    quiet(gc())

    design <- sobol(n = sobol_n,
                    dim = sobol_dim,
                    scrambling = 3,
                    seed = as.integer((99999 - 10000) * runif(1) + 10000),
                    init = FALSE)

    df_design <- data.frame(design)

    names(df_design) <- c(rbind(paste("W",
                                      seq(1:(sobol_dim / 2)),
                                      sep = ""),
                                paste("A",
                                      seq(1:(sobol_dim / 2)),
                                      sep = "")))

    coded_design <- df_design

    coded_df_design <- data.frame(coded_design)

    write.csv(coded_df_design, "current_design.csv", row.names = FALSE)

    start_time <- as.integer(format(Sys.time(), "%s"))

    cmd <- paste("CUDA_VISIBLE_DEVICES=0 python3 -W ignore rl_quantize.py",
                 " --arch ",
                 network,
                 " --dataset imagenet --dataset_root data",
                 " --suffix ratio010 --preserve_ratio 0.1 --n_worker 120",
                 " --warmup -1 --train_episode ",
                 sobol_n,
                 " --use_top5 --gpu_id 0",
                 " --data_bsize 128 --optimizer RS --val_size 10000 --train_size 20000",
                 sep = "")

    print(cmd)
    system(cmd)

    system("rm -r ../../save")

    elapsed_time <- as.integer(format(Sys.time(), "%s")) - start_time

    current_results <- read.csv("current_results.csv", header = TRUE)

    best_points <- filter(current_results, Top1 == max(Top1) | Top5 == max(Top5))
    best_points$id <- i
    best_points$elapsed_seconds <- elapsed_time
    best_points$points <- sobol_n

    if(is.null(results)){
        results <- best_points
    } else{
        results <- bind_rows(results, best_points)
    }

    if(is.null(search_space)){
        search_space <- current_results
    } else{
        search_space <- bind_rows(search_space, current_results)
    }

    write.csv(results,
              paste("rs_",
                    starting_sobol_n,
                    "_samples_",
                    iterations,
                    "_iterations.csv",
                    sep = ""),
              row.names = FALSE)

    write.csv(search_space,
              paste("rs_",
                    starting_sobol_n,
                    "_samples_",
                    iterations,
                    "_iterations_search_space.csv",
                    sep = ""),
              row.names = FALSE)
}


sample = read.csv('../data-PC.csv')

sample.pr = princomp(~x1+x2+x3+x4+x5+x6+x7+x8+x9+x10+x11+x12+x13+x14+x15+x16+x17+x18+x19+x20+x21+x22+x23+x24+x25+x26+x27+x28,data=sample,cor= T)

summary(sample.pr,loadings=T)

pre = predict(sample.pr)

sample$z1 = pre[,1];sample$z2 = pre[,2];sample$z3 = pre[,3];sample$z4 = pre[,4];sample$z5 = pre[,5];sample$z6 = pre[,6];sample$z7 = pre[,7];sample$z8 = pre[,8];sample$z9 = pre[,9];sample$z10 = pre[,10];sample$z11 = pre[,11];sample$z12 = pre[,12];sample$z13 = pre[,13];sample$z14 = pre[,14];sample$z15 = pre[,15];sample$z16 = pre[,16];sample$z17 = pre[,17];sample$z18 = pre[,18];sample$z19 = pre[,19];sample$z20 = pre[,20]

write.csv(sample,"data of pathological stage prediction.csv", row.names=F)