# Defines several coefficents for the drift and diffusion.
# Also defines functions for conversions between processes related through a lamperti transform.

#################################
## General Coefficients
#################################

make_constant_coefficient <- function(const_val)
    # Creates a function that returns a constant.
    #
    # Args:
    #     const_val (numeric): The value that the produced function should return
    # Returns:
    #     (function(anything, anything)): A function that will always return const_val
    function(t,x) const_val

make_affine_coefficient <- function(a, b)
    # Creates a affine function a*x+b.
    #
    # Args:
    #     a (numeric): The constant term of the affine function
    #     b (numeric): The first order term of the affine function
    # Returns:
    #     (function(anything, numeric)): A function that returns a*x+b
    function(t,x) a*x + b

#################################
## Drift Coefficients
#################################

make_mean_reverting_coefficient <- function(reversion_rate, long_term_mean)
    # Creates a mean reverting function of the form -reversion_rate(x-long_term_mean)
    #
    # Args:
    #     reversion_rate (numeric): The mean reverting rate
    #     long_term_mean (numeric): The value that the process reverts to.
    # Returns:
    #     (function(anything, numeric)): A function that returns -reversion_rate(x-long_term_mean)
    function(t,x) -reversion_rate*(x - long_term_mean)

mu_1d_from_paper <- function(t, y){
    # The drift coefficient. Implementing equation 5.2 from the paper.
    #
    # Args:
    #     t (numeric): The current time
    #     y (numeric): The Lamperti-transformed process
    sigma <- 0.4
    x <- convert_y_to_x_1d(y)
    denom <- 1 + x*x
    return(2*sigma*x/(denom*denom))
}

convert_y_to_x_1d <- function(y){
    # Converts Y_t to X_t in equation 5.2
    #
    # Args:
    #     y (numeric): The Lamperti-transformed process
    X0 <- 1
    sigma <- 0.4
    temp <- (27*X0*X0 + 81)*X0 + 162*sigma*y
    temp <- (.5*(sqrt(temp*temp + 2916) + temp))^(1.0/3) / 3
    return(temp - 1/temp)
}

convert_x_to_y_1d <- function(x){
    # Converts X_t to Y_t in equation 5.2
    #
    # Args:
    #     x (numeric): The original process
    X0 <- 1
    sigma <- .4
    return((x-X0 + (x*x*x - X0*X0*X0)/3) / (2*sigma))
}

make_mu_section_52_euler <- function(d)
    # Returns the drift coefficient function described in section 5.2 from the paper.
    #
    # Args:
    #     d (int): The current dimension
    function(t, x){
        # Args:
        #     t (numeric): The current time
        #     x (matrix): The current value of the process across all paths for this dimension
        x <- matrix(x)
        x[d,]*0.1*(sqrt(x[d,]) - 1)
    }

make_mu_from_paper_multi_dimension_lamperti <- function(d)
    # Returns the drift coefficient function of the lamperti transform
    # of the process described in section 5.2 from the paper.
    #
    # Args:
    #     d (int): The current dimension
    function(t, y){
        # Args:
        #     t (numeric): The current time
        #     y (matrix): The ending value of the process for each dimension and path
        X0 <- 1
        x <- convert_y_to_x_multi_d(y)
        return(0.2*(sqrt(x[d])-1) - 0.25)
    }

convert_y_to_x_multi_d <- function(y){
    # Converts Y_t (lamperti) to X_t from section 5.2
    #
    # Args:
    #     y (matrix or vector or numeric): Values of Y_t potentially across dimensions and timesteps
    # Returns:
    #     (matrix or vector or numeric): Values of X_t corresponding to each Y_t
    X0 <- 1
    return(X0*exp(0.5*y))
}

convert_x_to_y_multi_d <- function(x){
    # Converts X_t to Y_t (lamperti) from section 5.2
    #
    # Args:
    #     x (matrix or vector or numeric): Values of X_t potentially across dimensions and timesteps
    # Returns:
    #     (matrix or vector or numeric): Values of Y_t corresponding to each X_t
    X0 <- 1
    return(2*log(x/X0))
}

make_mu_heston_variance <- function(lambda, vbar)
    # Returns the drift coefficient function of the lamperti transform
    # of the Heston variance process
    #
    # Args:
    #     lambda (numeric): The mean reversion rate
    #     vbar (numeric): The long term mean
    function(t, v){
        # Args:
        #     t (numeric): The current time
        #     v (vector or numeric): The current variance
        if (any(v<=0)) print('(mu) v went <=0 !!!') # FIXME
        return(-lambda*((v>0)*v - vbar)) # full truncation
    }

make_mu_heston_variance_lamperti <- function(lambda, vbar, eta, v0){
    # Returns the drift coefficient function of the lamperti transform
    # of the Heston variance process
    #
    # Args:
    #     lambda (numeric): The mean reversion rate
    #     vbar (numeric): The long term mean
    #     eta (numeric): The volatility of volatility
    #     v0 (numeric): The initial variance
    convert_y_to_x_heston_variance <- make_convert_y_to_x_heston_variance(eta, v0)
    function(t, y){
        # Args:
        #     t (numeric): The current time
        #     v (vector or numeric): The current variance
        v <- convert_y_to_x_heston_variance(y)
        if (any(v<=0)) print('(mu L) v went <=0 !!!') # FIXME
        v <- (v>0)*v # full truncation
        return((-lambda*(v-vbar)/eta - 0.25*eta) / sqrt(v))
    }
}

make_convert_y_to_x_heston_variance <- function(eta, v0)
    function(y){
        # Converts Y_t (lamperti) to v_t from the Heston variance process
        #
        # Args:
        #     y (matrix or vector or numeric): Values of Y_t potentially across dimensions and timesteps
        # Returns:
        #     (matrix or vector or numeric): Values of X_t corresponding to each Y_t
        rootv <- 0.5*eta*y + sqrt(v0)
        return(rootv*rootv)
    }

make_convert_x_to_y_heston_variance <- function(eta, v0)
    function(v)
        # Converts X_t to Y_t (lamperti) from the Heston variance process
        #
        # Args:
        #     x (matrix or vector or numeric): Values of X_t potentially across dimensions and timesteps
        # Returns:
        #     (matrix or vector or numeric): Values of Y_t corresponding to each X_t
        return(2*(sqrt(v)-sqrt(v0))/eta)

make_mu_black_scholes_lamperti <- function(mu, sigma)
    # Returns the drift coefficient function of the lamperti transform
    # of the Black Scholes process
    #
    # Args:
    #     TODO
    function(t, y)
        # Args:
        #     t (numeric): The current time
        #     y (matrix): The location of the Lamperti transformed process
        return(mu/sigma - 0.5*sigma)

make_convert_y_to_x_black_scholes <- function(sigma, X0)
    function(y)
        # Converts Y_t (lamperti) to v_t from the Black Scholes process
        #
        # Args:
        #     y (matrix or vector or numeric): Values of Y_t potentially across dimensions and timesteps
        # Returns:
        #     (matrix or vector or numeric): Values of X_t corresponding to each Y_t
        return(X0*exp(sigma*y))

make_convert_x_to_y_black_scholes <- function(sigma, X0)
    function(x)
        # Converts X_t to Y_t (lamperti) from the Black Scholes process
        #
        # Args:
        #     x (matrix or vector or numeric): Values of X_t potentially across dimensions and timesteps
        # Returns:
        #     (matrix or vector or numeric): Values of Y_t corresponding to each X_t
        return(log(x/X0)/sigma)

make_mu_sin <- function(a, k, phi, b)
    # Returns the drift coefficient function of the sin process
    # dX_t = (b + a*sin(n*pi*x))*dt + sigma*dW_t
    #
    # Args:
    #     a (numeric): The amplitude of the oscillatory process
    #     n (numeric): The frequency of the oscillatory process
    #     b (numeric): The drift of the sine process
    function(t, x)
        # Args:
        #     t (numeric): The current time
        #     x (matrix): The location of the process
        return(a*(sin(k*t + phi) + b))

#################################
## Diffusion Coefficients
#################################

sigma_from_paper <- function(t, x){
    # The diffusion coefficient. Implementing equation 5.1 from the paper.
    #
    # Args:
    #     t (numeric): The current time
    #     x (array_like): The previous value of the process for each path
    sigma <- 0.4
    return(2*sigma/(1+x*x))
}

sigma_deriv_from_paper <- function(t, x){
    # The derivative of the diffusion coefficient. Implementing equation 5.1 from the paper.
    #
    # Args:
    #     t (numeric): The current time
    #     x (array_like): The previous value of the process for each path
    sigma <- 0.4
    denom <- 1 + x*x
    return(-4*x*sigma / (denom*denom))
}

make_sigma_section_52_euler <- function(d)
    # Returns the diffusion coefficient function described in section 5.2 from the paper.
    #
    # Args:
    #     d (int): The current dimension
    function(t, x){
        # Args:
        #     t (numeric): The current time
        #     x (matrix): The current value of the process across all paths for this dimension
        x <- matrix(x)
        return(0.5*x[d,])
    }

make_sigma_cir <- function(eta)
    # Returns the CIR diffusion coefficient function eta*sqrt(X_t)
    #
    # Args:
    #     eta (numeric): The diffusion scaling parameter.
    function(t, x){
        # Args:
        #     t (numeric): The current time
        #     x (matrix): The ending value of the process for each dimension and path
        if (any(x<=0)) print('(CIR) x went <=0 !!!') # FIXME
        return(eta*sqrt((x>0)*x)) # full truncation
    }


Temporal_Jaccard<-function(pre,post){
  if(class(pre)!="matrix"){beta<-vegdist(rbind(pre,post),method = "jaccard")} else
  {beta<-rep(NA,nrow(pre))
   for(i in 1:nrow(pre)){
     beta[i]<-vegdist(rbind(pre[i,],post[i,]),method = "jaccard")}}
  return(beta)
}

Temporal_Bray<-function(pre,post){
  if(class(pre)!="matrix"){beta<-vegdist(rbind(pre,post),method = "bray")} else
  {beta<-rep(NA,nrow(pre))
   for(i in 1:nrow(pre)){
     beta[i]<-vegdist(rbind(pre[i,],post[i,]),method = "bray")}}
  return(beta)
}

change_metrics<-function(x,means=T){
  SR_ts<-apply(x>0,3,rowSums)
  Com_abund_ts<-apply(x,3,rowSums)
  Shan_ts<-apply(x,3,renyi,hill=T,scales=c(1))
  Simp_ts<-apply(x,3,renyi,hill=T,scales=c(2))

  log_SR<-log(SR_ts[,-1]/SR_ts[,1])
  log_abund<-log(Com_abund_ts[,-1]/Com_abund_ts[,1])
  log_shan<-log(Shan_ts[,-1]/Shan_ts[,1])
  log_simp<-log(Simp_ts[,-1]/Simp_ts[,1])

  Jaccard<-log_simp
  for(i in 2:dim(x)[3]){
    Jaccard[,i-1]<-Temporal_Jaccard(pre = x[,,1],post = x[,,i])
  }

  Bray_Curtis<-log_simp
  for(i in 2:dim(x)[3]){
    Bray_Curtis[,i-1]<-Temporal_Bray(pre = x[,,1],post = x[,,i])
  }

  if(means==T){Change.df<-data.frame(log_SR=colMeans(log_SR),log_Abund=colMeans(log_abund),log_Shannon=colMeans(log_shan),log_Simpson=colMeans(log_simp),Jaccard=colMeans(Jaccard),Bray_Curtis=colMeans(Bray_Curtis),Stress=Stressor_sub[-1])
  } else{Change.df<-data.frame(log_SR=c(log_SR),log_Abund=c(log_abund),log_Shannon=c(log_shan),log_Simpson=c(log_simp),Jaccard=c(Jaccard),Bray_Curtis=c(Bray_Curtis),Stress=rep(Stressor_sub[-1],each=dim(x)[1]))}
  return(Change.df)
}


Viterbi <- function(nQ, nS, A, E, Ini, Obs){
  # Viterbi's Algorithm: given HMM model & observed sequence, infer state path
  #
  # Args:
  #   mQ: number of states
  #   nS: number of different observed values
  #   A: transition matrix
  #   E: Emission matrix
  #   Ini: initial state prob
  #   Obs: observed sequence, an integer vector
  #
  # Output: A list of path(integer vector) and maximum likelihood(numerical)

  # Initialize vq
  vq <- Ini * E[, Obs[1]]
  nl <- length(Obs)
  # Update vq and save path
  i <- 2
  pathlist <- matrix(0, nQ, nl)
  pathlist[, 1] <- 1:nQ
  while (i <= nl){
    mat <- vq * A * (rep(1, nQ) %*% t(E[, Obs[i]]))
    vq <- apply(mat, 2, max)
    nextState <- apply(mat, 2, which.max)
    pathlist[, i] <- nextState
    i <- i + 1
  }
  ml <- max(vq)
  endState <- which.max(vq)
  path <- rep(0, nl)
  path[nl] <- endState
  for (i in (nl - 1):1){
    path[i] <- pathlist[path[i + 1], i + 1]
  }
  output <- list(Path = path, Likelihood = ml)
  return(output)
}

E <- matrix(c(.7, .9, .6, .2, .05, .3, .1, .05, .1), 3, 3)
A <- matrix(c(.1, .9, .7, .5, .05, .2, .4, .05, .1), 3, 3)
Obs <- c(3, 1, 2, 3, 1)
Ini <- c(.2, .4, .4)
Viterbi(3, 3, A, E, Ini, Obs)
#"3" "1" "3" "1" "2"

#Comparison between "HMM" and this function. Viterbi is 30% faster.
library(HMM)
hmm <- initHMM(c("1", "2", "3"), c("a", "b", "c"), Ini, A, E)
Obsletter <- c("c", "a", "b", "c", "a")

library(microbenchmark)
microbenchmark(viterbi(hmm, Obsletter), Viterbi(3, 3, A, E, Ini, Obs))


phredToProb <- function(phred) {
	if (phred == "#") return(1)
	phredNum <- as.integer(charToRaw(phred))-33
	10^(-phredNum/10)
}

#calculster posteriors for variant calls, taking into account the size of the cluster
# in which the calls were found
bayesBase <- function(calls, quals, templ, mutRate=0.0025, clusterSize=1) {
	#convert phred quals to error probabilities
	probs <- sapply(quals, function(phred) {
		#multiple qualities for the same base can occur for inserations or deletions
		#they are treated as multiplicative (i.e. the probability of all being errors)
		prod(sapply(toChars(phred), phredToProb))
	})
	#all possible hypothetical bases (=q) to test
	qs <- unique(c(templ,calls))
	#calculate priors for each base given the template and mutation rate
	#note: this could be sped up by keeping a hash/lookup table of all possible values around
	r <- mutRate
	m <- clusterSize
	logPriorOdds <- sapply(qs,
		function(q) if (q==templ) {#WT case
			log((1-r)^m)-log(1-(1-r)^m)
		} else {#Mutant case
			log(1-(1-r)^m)-log(3)-log(1-(1-(1-r)^m)/3)
		}
	)
	#log posterior odds = sum of log likelihood ratios plus prior
	k <- colSums(do.call(rbind,lapply(1:length(calls), function(i) {
		#error probablity
		p <- probs[[i]]
		#for each possible base: calculate the log likelihood ratio (LLR).
		#Given that illumina discretizes the qualities, a lookup table could speed this up too
		setNames(sapply(qs, function(q) {
			#if the basecall supports the hypothetical base
			if (calls[[i]] == q) {
				log(1-p)-log(p)+log(3)
			#otherwise, if the basecall contradicts the hypothetical base
			} else {
				log(p) - log(3) - log(1/3-p/9)
			}
		}),qs)
	}))) + logPriorOdds
	#convert to posterior probabilities
	return(exp(k)/(1+exp(k)))
}

#input "callClusters" is list of lists of dataframes. Each top layer element correponds to a
# read pair, containing a list clusters. The clusters themselves are datafraames that list proximal
# proposed variant calls with columns refbase, refpos, readbase1, qual1, readbase2, qual2
# in case of insertions, refbase is "-" and readbase and qual can contain more than one value,
# in case of deletions, readbase1/readbase2 is "-" and qual1/qual2 would contain the qualities of the neighbouring two base calls.
processClusters <- function(callClusters, mutrate=0.0025) {
	#calculate posterior probabilites for each call in each cluster
	out <- lapply(callClusters, function(clusters) {
		#iterate over each cluster for the current read pair
		lapply(clusters, function(cluster) {
			if (!is.data.frame(cluster)){
				return(cluster)
			}
			#cluster size
			csize <- nrow(cluster)
			#iterate over the proposed nucleotide change in the current cluster
			#  and calculate posteriors
			posteriors <- lapply(1:csize,function(i) with(cluster[i,],{
				#check if any calls are missing or "N"
				na1 <- is.na(readbase1) || readbase1=="N"
				na2 <- is.na(readbase2) || readbase2=="N"
				if (na1 && na2) {
					#if there's no usable data, it's WT
					# return(cbind(cluster,varcall=refbase,post=1))
					setNames(1,refbase)
				} else if (na1) {
					bayesBase(readbase2,qual2,refbase,mutrate,csize)
				} else if (na2) {
					bayesBase(readbase1,qual1,refbase,mutrate,csize)
				} else {
					bayesBase(
						c(readbase1,readbase2),
						c(qual1,qual2),
						refbase,mutrate,csize
					)
				}
			}))
			varcall <- sapply(posteriors,function(x)names(which.max(x)))
			callPosteriors <- mapply(function(posteriors,varcall)posteriors[[varcall]],posteriors,varcall)
			return(cbind(cluster,varcall=varcall,post=callPosteriors))
		})
	})
	return(out)
}


subroutine stoke(x1,y1,x2,y2,rw,area,s1,eps,nerror)

# Apply Stokes' theorem to find the area of a polygon;
# we are looking at the boundary segment from (x1,y1)
# to (x2,y2), travelling anti-clockwise.  We find the
# area between this segment and the horizontal base-line
# y = ymin, and attach a sign s1.  (Positive if the
# segment is right-to-left, negative if left to right.)
# The area of the polygon is found by summing the result
# over all boundary segments.

# Just in case you thought this wasn't complicated enough,
# what we really want is the area of the intersection of
# the polygon with the rectangular window that we're using.

# Called by dirout.

implicit double precision(a-h,o-z)
dimension rw(4)
logical value

zero   = 0.d0
nerror = -1

# If the segment is vertical, the area is zero.
call testeq(x1,x2,eps,value)
if(value) {
        area = 0.
        s1   = 0.
        return
}

# Find which is the right-hand end, and which is the left.
if(x1<x2) {
        xl = x1
        yl = y1
        xr = x2
        yr = y2
        s1 = -1.
}
else {
        xl = x2
        yl = y2
        xr = x1
        yr = y1
        s1 = 1.
}

# Dig out the corners of the rectangular window.
xmin = rw(1)
xmax = rw(2)
ymin = rw(3)
ymax = rw(4)

# Now start intersecting with the rectangular window.
# Truncate the segment in the horizontal direction at
# the edges of the rectangle.
slope = (yl-yr)/(xl-xr)
x  = max(xl,xmin)
y  = yl+slope*(x-xl)
xl = x
yl = y

x  = min(xr,xmax)
y  = yr+slope*(x-xr)
xr = x
yr = y

if(xr<=xmin|xl>=xmax) {
        area = 0.
        return
}

# We're now looking at a trapezoidal region which may or may
# not protrude above or below the horizontal strip bounded by
# y = ymax and y = ymin.
ybot = min(yl,yr)
ytop = max(yl,yr)

# Case 1; ymax <= ybot:
# The `roof' of the trapezoid is entirely above the
# horizontal strip.
if(ymax<=ybot) {
        area = (xr-xl)*(ymax-ymin)
        return
}

# Case 2; ymin <= ybot <= ymax <= ytop:
# The `roof' of the trapezoid intersects the top of the
# horizontal strip (y = ymax) but not the bottom (y = ymin).
if(ymin<=ybot&ymax<=ytop) {
        call testeq(slope,zero,eps,value)
        if(value) {
                w1 = 0.
                w2 = xr-xl
        }
        else {
                xit = xl+(ymax-yl)/slope
                w1 = xit-xl
                w2 = xr-xit
                if(slope<0.) {
                        tmp = w1
                        w1  = w2
                        w2  = tmp
                }
        }
        area = 0.5*w1*((ybot-ymin)+(ymax-ymin))+w2*(ymax-ymin)
        return
}

# Case 3; ybot <= ymin <= ymax <= ytop:
# The `roof' intersects both the top (y = ymax) and
# the bottom (y = ymin) of the horizontal strip.
if(ybot<=ymin&ymax<=ytop) {
        xit = xl+(ymax-yl)/slope
        xib = xl+(ymin-yl)/slope
        if(slope>0.) {
                w1 = xit-xib
                w2 = xr-xit
        }
        else {
                w1 = xib-xit
                w2 = xit-xl
        }
        area = 0.5*w1*(ymax-ymin)+w2*(ymax-ymin)
        return
}

# Case 4; ymin <= ybot <= ytop <= ymax:
# The `roof' is ***between*** the bottom (y = ymin) and
# the top (y = ymax) of the horizontal strip.
if(ymin<=ybot&ytop<=ymax) {
        area = 0.5*(xr-xl)*((ytop-ymin)+(ybot-ymin))
        return
}

# Case 5; ybot <= ymin <= ytop <= ymax:
# The `roof' intersects the bottom (y = ymin) but not
# the top (y = ymax) of the horizontal strip.
if(ybot<=ymin&ymin<=ytop) {
        call testeq(slope,zero,eps,value)
        if(value) {
                area = 0.
                return
        }
        xib = xl+(ymin-yl)/slope
        if(slope>0.) w = xr-xib
        else w = xib-xl
        area = 0.5*w*(ytop-ymin)
        return
}

# Case 6; ytop <= ymin:
# The `roof' is entirely below the bottom (y = ymin), so
# there is no area contribution at all.
if(ytop<=ymin) {
        area = 0.
        return
}

# Default; all stuffed up:
nerror = 8
return

end


library("MASS")
library("lattice")
load("./simul-2017.Rdata")

#Valeur pour mettre plus en valeur les screens pour le rapport
lwd_default <- 1

##########################################
# Q1.1
##########################################
#Affichage de l'ensemble d'apprentissage
couleur_app<-rep('red',n_app)
couleur_app[classe_app==1]='red'
couleur_app[classe_app==2]='blue'
couleur_app[classe_app==3]='green'

plot(x_app, col = couleur_app, lwd = lwd_default)

#Affichage de l'ensemble de test
couleur_test<-rep('red',n_test)
couleur_test[classe_test==1]='red'
couleur_test[classe_test==2]='blue'
couleur_test[classe_test==3]='green'
plot(x_test, col = couleur_test, lwd = lwd_default)

##########################################
# Q1.2
##########################################
#Affichage de l'ensemble d'apprentissage
plot(x_app, col = couleur_app, lwd = lwd_default)

# Déclaration des vecteurs moyennes
M1 = seq(1,2)
M2 = seq(1,2)
M3 = seq(1,2)

# Vecteur moyenne de la classe 1
M1[1] = mean(x_app[classe_app==1,1])
M1[2] = mean(x_app[classe_app==1,2])

# Vecteur moyenne de la classe 2
M2[1] = mean(x_app[classe_app==2,1])
M2[2] = mean(x_app[classe_app==2,2])

# Vecteur moyenne de la classe 3
M3[1] = mean(x_app[classe_app==3,1])
M3[2] = mean(x_app[classe_app==3,2])

points(M1[1], y = M1[2], pch = 20, col = "red", lwd=15)
points(M2[1], y = M2[2], pch = 20, col = "blue", lwd=15)
points(M3[1], y = M3[2], pch = 20, col = "green", lwd=15)

#Affichage de l'ensemble d'apprentissage
plot(x_app, col = couleur_app, lwd = lwd_default)

# Matrices de co variance
Sigma1 <- matrix(1,2,2)
Sigma2 <- matrix(1,2,2)
Sigma3 <- matrix(1,2,2)

for (i in 1:2) {
  for (j in 1:2) {
    Sigma1[i,j]=cov(as.vector(x_app[classe_app==1,i]), as.vector(x_app[classe_app==1,j]))
    Sigma2[i,j]=cov(as.vector(x_app[classe_app==2,i]), as.vector(x_app[classe_app==2,j]))
    Sigma3[i,j]=cov(as.vector(x_app[classe_app==3,i]), as.vector(x_app[classe_app==3,j]))
  }
}

s1 = s1^2
s2 = s2^2
s3 = s3^2

##########################################
# Q1.3
##########################################

# Grille d'estimation de la densit´e de probabilit´e en 50 intervalles selon 1er attribut
xp1 <- seq(min(x_app[,1]),max(x_app[,1]),length=50)
# Grille d'estimation de la densit´e de probabilit´e en 50 intervalles selon 2eme attribut
xp2 <- seq(min(x_app[,2]),max(x_app[,2]),length=50)

grille <- expand.grid(x1=xp1,x2=xp2)
x_app_lda<-lda(x_app,classe_app)

# Estimation des densit´es de probabilit´es a posteriori dans Zp
grille = cbind(grille[,1],grille[,2])
Zp <- predict(x_app_lda,grille)

#Affichage des lignes de décision
zp_3<-Zp[["posterior"]][,3]-pmax(Zp[["posterior"]][,1],Zp[["posterior"]][,2])
zp_2<-Zp[["posterior"]][,2]-pmax(Zp[["posterior"]][,1],Zp[["posterior"]][,3])

contour(xp1,xp2,matrix(zp_3,50),add=TRUE,levels=0,drawlabels=FALSE, col="green", lwd = lwd_default)
contour(xp1,xp2,matrix(zp_2,50),add=TRUE,levels=0,drawlabels=FALSE, col="blue", lwd = lwd_default)

##########################################
# Q1.4
##########################################

assigne_test <- predict(x_app_lda, newdata=x_test)
# Estimation des taux de bonnes classifications
table_classification_test_lda <-table(classe_test, assigne_test[["class"]])
# table of correct class vs. classification
diag(prop.table(table_classification_test_lda, 1))
# total percent correct
taux_bonne_classif_test_lda <-sum(diag(prop.table(table_classification_test_lda)))

# Création du vecteur contenant le code de la forme des données test assignées aux
shape<-rep(1,n_test) ;
# Forme des données assignées
shape[assigne_test[["class"]]==1]=1 ;
shape[assigne_test[["class"]]==2]=2 ;
shape[assigne_test[["class"]]==3]=3 ;
plot(x_test,col=couleur_test,pch=shape,xlab = "X1", ylab = "X2", lwd = lwd_default)

#Affichage des lignes de décision
contour(xp1,xp2,matrix(zp_3,50),add=TRUE,levels=0,drawlabels=FALSE, col="green", lwd = lwd_default)
contour(xp1,xp2,matrix(zp_2,50),add=TRUE,levels=0,drawlabels=FALSE, col="blue", lwd = lwd_default)

##########################################
# Q1.5
##########################################
#Affichage de l'ensemble d'apprentissage
plot(x_app, col = couleur_app, lwd = lwd_default)

x_app_qda<-qda(x_app,classe_app)

# Estimation des densit´es de probabilit´es a posteriori dans Zp
Zp <- predict(x_app_qda,grille)

#Affichage des lignes de décision
zp_3<-Zp[["posterior"]][,3]-pmax(Zp[["posterior"]][,1],Zp[["posterior"]][,2])
zp_2<-Zp[["posterior"]][,2]-pmax(Zp[["posterior"]][,1],Zp[["posterior"]][,3])
contour(xp1,xp2,matrix(zp_3,50),add=TRUE,levels=0,drawlabels=FALSE, col="green", lwd = lwd_default)
contour(xp1,xp2,matrix(zp_2,50),add=TRUE,levels=0,drawlabels=FALSE, col="blue", lwd = lwd_default)

assigne_test <- predict(x_app_qda, newdata=x_test)
# Estimation des taux de bonnes classifications
table_classification_test_qda <-table(classe_test, assigne_test[["class"]])
# table of correct class vs. classification
diag(prop.table(table_classification_test_qda, 1))
# total percent correct
taux_bonne_classif_test_qda <-sum(diag(prop.table(table_classification_test_qda)))

# Création du vecteur contenant le code de la forme des données test assignées aux
shape<-rep(1,n_test) ;
# Forme des données assignées
shape[assigne_test[["class"]]==1]=1 ;
shape[assigne_test[["class"]]==2]=2 ;
shape[assigne_test[["class"]]==3]=3 ;
# Affichage avec code couleur et forme adapt´ees
plot(x_test,col=couleur_test,pch=shape,xlab = "X1", ylab = "X2", lwd = lwd_default)

#Affichage des lignes de décision
contour(xp1,xp2,matrix(zp_3,50),add=TRUE,levels=0,drawlabels=FALSE, col="green", lwd = lwd_default)
contour(xp1,xp2,matrix(zp_2,50),add=TRUE,levels=0,drawlabels=FALSE, col="blue", lwd = lwd_default)


### Model Complexity Toy Example
## Use: Generate data for the toy example in the paper
## Author: Mark Verhagen

## Load libraries
library(tidyverse)
library(texreg)
library(lmtest)

## Set n and seed
n <- 40000
set.seed(1704)

n <- 40000
set.seed(1704)

## Simulate data for toy example

age <- rnorm(n, 0, 7.5) + 70
age[age <= 50] <- runif(length(age[age <= 50]), 50, 51)
age[age >= 90] <- runif(length(age[age >= 90]), 89, 90)
medication_use <- ifelse((age - 20) / 100 + runif(n, 0, 0.2) >
    runif(n, 0, 1), 1, 0)
gender <- ifelse((runif(n, 0, 1) + (age / 1000)) > 0.5, 1, 0)
assistance <- ifelse(runif(n, 0, 0.08) + (age / 180) > 0.5, 1, 0)
error <- rnorm(n, 0, 0.3)

fixed_part <- (10 * (ifelse(age >= 50, (age - 50) * 0.025, -0.8) +
    ifelse(age > 65, (age - 65) * 0.05, 0) -
    ifelse(age > 75, (age - 75) * 0.04, 0) -
    ifelse(age > 85, (age - 85) * 0.025, 0) + 0.05 * assistance +
    0.05 * medication_use -
    0.1 * gender + error)) + 10

y <- ifelse(fixed_part < 0, 0, fixed_part)

df <- data.frame(
    fall = y, age = age, age2 = age^2, med_use = medication_use,
    sex = gender, assist = assistance
) %>%
    mutate(
        age_50p = ifelse(age >= 50, age - 50, 0),
        age_65p = ifelse(age > 65, age - 65, 0),
        age_75p = ifelse(age > 75, age - 75, 0),
        age_85p = ifelse(age > 85, age - 85, 0)
    )

## Save datasets for other scripts
save(df, file = "toy_example/data/edit/toy_data.rda")
write.csv(df, "toy_example/data/edit/toy_df.csv")

## Estimate three functional forms
lm1 <- lm(fall ~ 1 + age + assist + sex + med_use, data = df)

lm2 <- lm(fall ~ 1 + age + age2 + assist + sex + med_use, data = df)

lm3 <- lm(fall ~ 1 + age_50p + age_65p + age_75p + age_85p + assist + sex +
    med_use, data = df)

## Evaluate LR-likelihood test
lrtest(lm1, lm2)
lrtest(lm2, lm3)

## Output regression results
texreg(list(summary(lm1), summary(lm2), summary(lm3)),
    file = "tex/tables/results_toy.tex"
)
screenreg(list(summary(lm1), summary(lm2), summary(lm3)))

## Generate dataset including the implied age effect from the linear models
lm1_df <- summary(lm1)$coefficients %>% as.data.frame()
lm2_df <- summary(lm2)$coefficients %>% as.data.frame()
lm3_df <- summary(lm3)$coefficients %>% as.data.frame()

df <- df %>%
    mutate(
        true_effect = 10 * (age_50p * 0.025 + age_65p * 0.05 -
            age_75p * 0.04 - age_85p * 0.025),
        lm1_implied = lm1_df$Estimate[1] + lm1_df$Estimate[2] * age - 10,
        lm2_implied = lm2_df$Estimate[1] + lm2_df$Estimate[2] * age + lm2_df$Estimate[3] * age2 - 10,
        lm3_implied = lm3_df$Estimate[1] + lm3_df$Estimate[2] * age_50p + lm3_df$Estimate[3] * age_65p +
            lm3_df$Estimate[4] * age_75p + lm3_df$Estimate[5] * age_85p - 10
    )

df_effects <- df %>%
    sample_frac(0.1) %>%
    dplyr::select(age, true_effect, lm1_implied, lm2_implied, lm3_implied) %>%
    reshape2::melt(id.vars = c("age")) %>%
    mutate(` ` = ifelse(grepl("true", variable), "True effect", NA))

saveRDS(df_effects, "toy_example/data/edit/df_effects.rds")


#  James Rekow

eulerIntegrate = function(smpl, threshold = 10 ^ (-6), maxSteps = 10 ^ 4, tStep = 10 ^ (-2)){

  #  ARGS: smpl - a sample of the form list(abd, gr, imat)
  #        maxSteps - maximum number of time steps allowed before termination
  #        tStep - length of time covered in each iteration (e.g. delta t)
  #        threshold - cutoff below which a change in the abd vector is considered
  #                    a small step
  #
  #  RETURNS: abd - numeric vector containing the integrated abd vector corresponding to smpl

  #  extract list elements
  abd = smpl[[1]]
  gr = smpl[[2]]
  imat = smpl[[3]]

  #  stores the number of consecutive small steps
  smallSteps = 0

  #  integrate the system of ODEs from the GLV model with parameters from smpl using Euler's method
  for(j in 1:maxSteps){

    #  compute delta x
    abdChange = abd * {gr + c(imat %*% abd)}
    deltaabd = tStep * abdChange
    abd = abd + deltaabd

    #  ensure nonnegativity of abundances
    abd = 0.5 * {abs(abd) + abd}

    #  check if delta x is less than the threshold value (euclidean distance with threshold pre-squared)
    smallStep = sum(abdChange * abdChange) < threshold

    #  if delta x is less than the threshold value five times in a row, we assume x has
    #  reached a steady state and terminate the loop
    if(smallStep){
      smallSteps = smallSteps + 1

      if(smallSteps == 5){
        break
      } #  end if
    } #  end if

    #  reset small step counter if delta x is greater than the threshold value
    else{
      smallSteps = 0
    } #  end else

  } #  end integration loop

  #  round (in part to set very small abundances to zero)
  abd = round(abd, 4)

  return(abd)

} #  end eulerIntegrate function


# Jinliang Yang
# purpose: calculate the GCA and SCA
# updated: 3.7.2012

#Row        Barcode KRN Note.x         Pedigree   Genotype  Note.y
#3133  8757  11-8757-23 OP  16        10g-1028-21/2048 Tzi8 x P39 Diallel
# input data=d should contain trait and Genotype (Tzi x P39)

getca2 <- function(data=d, trait="KRN", square=FALSE){
  ### check the required cols
  if (!("Genotype" %in% names(data) & trait %in% names(data) ))
    stop(paste("Make sure your data frame contains columns Genotype and ", trait, sep=""));
  data$Genotype <- as.character(data$Genotype)
  ### remove the self genotype
  idx <- grep("@", data$Genotype);
  if(sum(idx)>0) data <- data[-idx,];

  ### get the p1, p2 and reciprocal col
  if(!("p1" %in% names(data) & "p2" %in% names(data) & "reciprocal" %in% names(data) )){
    data$p1 <- NA;
    data$p2 <- NA;
    data$reciprocal <- NA;
    data$Genotype <- as.character(data$Genotype);
    for(i in 1:nrow(data)){
      tem <- unlist(strsplit(data$Genotype[i], split="x"));
      tem <- sort(tem)
      data$p1[i] <- tem[1];
      data$p2[i] <- tem[2];
      data$reciprocal[i] <- paste(tem[1], tem[2], sep="_")
    }
  }

  ### start the calculation according to Method 4, Model I
  uhat <- mean(data[,trait], na.rm=T);
  inbred <- sort(unique(c(data$p1, data$p2)));

  ### General Combining Ability
  gca <- data.frame(Genotype=inbred, GCA=NA);
  for(j in 1:length(inbred)){
      inbredj = inbred[j];
      ghat <- mean(subset(data, p1==inbredj | p2==inbredj)[, trait], na.rm=T)-uhat;
      gca[gca$Genotype==inbredj,]$GCA <- ghat;
  }

  ### Specific Combining Ability
  sca <- matrix(NA, nrow=length(inbred), ncol=length(inbred)+1);
  sca <- as.data.frame(sca)
  names(sca) <- c(trait, inbred)
  sca[,1] <- inbred

  specific <- unique(data$reciprocal);

  scatable <- data.frame()
  for(k in 1:length(specific)){
      tem2 <- unlist(strsplit(specific[k], split="_"));
      myp1 <- tem2[1];
      myp2 <- tem2[2];

      pheno <- subset(data, (p1==myp1 & p2==myp2) | (p1==myp2 & p2==myp1));
      shat <- mean(pheno[, trait], na.rm=T) - subset(gca, Genotype==myp1)$GCA - subset(gca, Genotype==myp2)$GCA - uhat;
    if(square){
      sca[sca[,1]==myp1, myp2] <- shat;
    } else {
      temid <- paste(myp1, myp2, sep="x");
      temsca <- data.frame(Genotype=temid, SCA=shat)
      scatable <- rbind(scatable, temsca)
    }

  }

  outputlist <- list();
  names(gca)[2] <- trait;
  outputlist[[1]] <- gca;
  names(scatable)[2] <- trait;
  if(square){
    outputlist[[2]] <- sca;
  } else{
    outputlist[[2]] <- scatable;
  }

  return(outputlist)
}
###############################################
mydata <- read.csv("pheno_diallel_master_BLUE.csv")

krnca <- getca2(data=mydata, trait="KRN", square=FALSE)
akwca <- getca2(data=mydata, trait="AKW", square=FALSE)
tkwca <- getca2(data=mydata, trait="TKW", square=FALSE)
kcca <- getca2(data=mydata, trait="KC", square=FALSE)

cdca <- getca2(data=mydata, trait="CD", square=FALSE)
cwca <- getca2(data=mydata, trait="CW", square=FALSE)
clca <- getca2(data=mydata, trait="CL", square=FALSE)

##########  GCA #################
gca_master <- merge(krnca[[1]], akwca[[1]], by="Genotype")
gca_master <- merge(gca_master, tkwca[[1]], by="Genotype")
gca_master <- merge(gca_master, kcca[[1]], by="Genotype")
gca_master <- merge(gca_master, cdca[[1]], by="Genotype")
gca_master <- merge(gca_master, cwca[[1]], by="Genotype")
gca_master <- merge(gca_master, clca[[1]], by="Genotype")

write.table(gca_master, "pheno_diallel_master_BLUE_GCA.csv", sep=",", row.names=FALSE, quote=FALSE)

##########  SCA #################
sca_master <- merge(krnca[[2]], akwca[[2]], by="Genotype")
sca_master <- merge(sca_master, tkwca[[2]], by="Genotype")
sca_master <- merge(sca_master, kcca[[2]], by="Genotype")
sca_master <- merge(sca_master, cdca[[2]], by="Genotype")
sca_master <- merge(sca_master, cwca[[2]], by="Genotype")
sca_master <- merge(sca_master, clca[[2]], by="Genotype")

write.table(sca_master, "pheno_diallel_master_BLUE_SCA.csv", sep=",", row.names=FALSE, quote=FALSE)

pairs(d[, c(4,7,9, 11:13)], text.panel = diag, upper.panel=panel.smooth,
lower.panel=panel.cor, gap=0, main="KRN Correlation Plots of three obs")

#################################################################################
# make the design matrix
#####################################################################################################################################################
design <- read.table("/Users/yangjl/Documents/Heterosis_GWAS/SNP/diallel_4impute.txt", header=TRUE)

dm <- matrix(0, nrow=378, ncol=28+378)
dm <- as.data.frame(dm)
p <- as.character(unique(design$p1));
names(dm) <- c("Geno", p, as.character(design$geno))
dm$Geno <- as.character(design$geno);

for(i in 1:nrow(dm)){
  tem <- unlist(strsplit(dm$Geno[i], split="x"));
  p1 <- tem[1];
  p2 <- tem[2];
  dm[i, p1] <- 1;
  dm[i, p2] <- 1;
  dm[i, dm$Geno[i]] <- 1;
}

#################
trait <- read.csv("pheno_diallel_master_raw_040612.csv")
trait$Curtiss <- 0; # Only B73
trait$Dairy <- 0;
trait$Johnson <- 0;
trait$zumwalt <- 0;

for (i in 1:nrow(trait)){
  farm <- as.character(trait$Farm[i]);
  trait[i, farm] <- 1;
}

#############################
#FUNCTION to GCA and SCA
getca1 <- function(traitnm="TKW"){
  tem <- merge(trait[, c("Genotype2", traitnm, "Dairy", "Johnson", "zumwalt")], dm, by.x="Genotype2", by.y="Geno")
  tem <- tem[!is.na(tem[,2]),]
  yield <- tem[,2]

  idx1 <- numeric(ncol(tem))
  for(i in 3:ncol(tem)){
    idx1[i] <- sum(tem[,i])
  }
  idx <- which(idx1==0)

  dmatrix1 <- as.matrix(tem[, -idx]);
  fit1 <- lm(yield ~ dmatrix1)
  ped.hat1 <- fit1$coef
  ped.hat1 <- ped.hat1[!is.na(ped.hat1)]

  names(ped.hat1) <- gsub("dmatrix1", "", names(ped.hat1));
  names(ped.hat1)[1] <- "yhat"

  gcaout <- data.frame(Genotype=names(ped.hat1[1:29]), GCA=ped.hat1[1:29]);
  names(gcaout)[2] <- traitnm;

  scaout <- data.frame(Genotype=names(ped.hat1[30:227]), GCA=ped.hat1[30:227]);
  names(gcaout)[2] <- traitnm;

  output <- list(gca=gcaout, sca=scaout)
  return(output)
}

#############
krn1 <- getca1("KRN")

krntem <- merge(krnca[[2]], krn1[[2]], by="Genotype", all.x=TRUE)
krntem[is.na(krntem)] <- 0

kc <- getca("KC")
akw <- getca("AKW")
tkw <- getca("TKW")
cd <- getca("CD")
cw <- getca("CW")
cl <- getca("CL")

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

getca(data=sample, trait="Yield")
#########################################################################################################################
x1 <- c("P1", "P1", "P1", "P1", "P2", "P2");
x2 <- c("P2", "P2", "P3", "P3", "P3", "P3")
yield <- c(10, 12, 20, 22, 14, 16)

sample <- data.frame(Parent1=x1, Parent2=x2, Yield=yield)

#####################################################################################################################################################
X <- matrix(c(1, 1, 0, 1, 0, 0,
                   1, 1, 0, 1, 0, 0,
                   1, 0, 1, 0, 1, 0,
                   1, 0, 1, 0, 1, 0,
                   0, 1, 1, 0, 0, 1,
                   0, 1, 1, 0, 0, 1), ncol=6, byrow=TRUE)

y <- sample$Yield
XX=t(X)%*%X
library(MASS)
XXgi=ginv(XX)
Px=X%*%XXgi%*%t(X)
yhat=Px%*%y

fit <- lm(y~X)

y=c(4,1,3,5,3,3,1)
X=matrix(c(
  1,1,0,0,0,1,0,0,
  1,1,0,0,0,0,1,0,
  1,0,1,0,0,0,1,0,
  1,0,1,0,0,0,0,1,
  1,0,0,1,0,0,0,1,
  1,0,0,0,1,1,0,0,
  1,0,0,0,1,0,1,0
  ),byrow=T,nrow=7)
fit <- lm(y ~X)
XX=t(X)%*%X
library(MASS)
XXgi=ginv(XX)
Px=X%*%XXgi%*%t(X)
yhat=Px%*%y

#################
data1 <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/LL_KN_AKW_test.csv");

###########################################################
### Delete duplicated input and missing data
file1 <- read.csv("LL_KRN_test.csv")
dim(file1)
#8678 8

diallel <- subset(file1, Note.y=="Diallel" | Note.y=="NAM Filler");
dim(diallel)
#[1] 2850    8
#summary(diallel)

###########################################################
### Delete duplicated input and missing data
# Get ride of 4 duplicated records
dup <- which(duplicated(diallel$Barcode))
diallel <- diallel[!duplicated(diallel$Barcode),]

# Get ride of the missing records
### checking for outlyers
diallel$KRN <- as.numeric(as.character(diallel$KRN));
diallel[is.na(diallel$KRN),]
diallel <- diallel[!is.na(diallel$KRN),]
hist(diallel$KRN, breaks=10)
dim(diallel)
#[1] 2837    8

data2 <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/LL_KRN_test.csv");
data3 <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/LL_cob.test.csv");

data1 <- subset(data1, )

dm2 <- merge(sample, dm, by.x="Genotype", by.y="Geno")

yield <- dm2$Yield
dmatrix <- as.matrix(dm2[, 7:52]);

fit <- lm(yield ~ dmatrix)


n_experiments <- 100
result <- 0
exper <- 0

while (exper <= n_experiments)
{
	n_samples <- 100
	samples <- runif(n_samples)
	counter <- 1
	for (sample in samples)
	{
		if (sample <= 1/6)
		{
			result = result + counter
			break
		}
		else
		{
			counter = counter + 1
		}
	}
	exper = exper + 1
}

result = result / n_experiments
print(result)


=begin
[((<index-ja|URL:index-ja.html>))]
((<Algebra::Polynomial>))
/
((<Algebra::PolynomialFactorization>))
/
((<Algebra::SplittingField>))
/
((<Algebra::Galois>))

= Algebra::Polynomial
((*(1変数多項式環クラス)*))

1変数の多項式環を表現します。実際のクラスを生成するには環を指定して、クラスメソッド ((<::create>)) あるいは関数 ((<Algebra.Polynomial>))() を用います。

== ファイル名:
* ((|polynomial.rb|))

== スーパークラス:

* ((|Object|))

== インクルードしているモジュール:

* ((|Enumerable|))
* ((|Comparable|))
* ((<Algebra::EuclidianRing|URL:euclidian-ring-ja.html>))
* ((<Algebra::PolynomialFactorization>))
* ((<Algebra::SplittingField>))
* ((<Algebra::Galois>))

== 関連するメソッド:

--- Algebra.Polynomial(ring [, obj0 , obj1 [, ...]])
    ((<::create>))(ring, obj0[, obj1 [, ...]])> に同じ。

== クラスメソッド:

--- ::create(ring, obj0[, obj1[, ...]])
    ((|ring|)) で表現されるクラスを係数環とする多項式環クラスを
    生成します。

    (({obj0, obj1, ...})) で指定されたオブジェクトが変数を
    表現し、これが複数ならば、再帰的に多項式環上の多項
    式環を生成します。

    このメソッドの戻り値は Polynomial クラスのサブクラス
    です。このサブクラスにはクラスメソッドとして ((|ground|)) と
    ((|var|))、((|vars|)) が定義され、それぞれ、係数環 ((|ring|))、
    主変数オブジェクト（最後に指定された変数）、全ての変数オ
    ブジェクトを返します。

    オブジェクト(({obj0, obj1, ...}))は変数の名（((|to_s|))の値）
    に利用されるだけです。

    例: 整数を係数とする多項式環の生成
      require "polynomial"
      P = Algebra::Polynomial.create(Integer, "x")
      x = P.var
      p((x + 1)**100) #=> x^100 + 100x^99 + ... + 100x + 1
      p P.ground #=> integer

    例: 整数を係数とする複数変数多項式環の生成
      require "polynomial"
      P = Algebra::Polynomial.create(Integer, "x", "y", "z")
      x, y, z = P.vars
      p((-x + y + z)*(x + y - z)*(x - y + z))
      #=> -z^3 + (y + x)z^2 + (y^2 - 2xy + x^2)z - y^3 + xy^2 + x^2y - x^3
      p P.var #=> z

    この例の (({P})) は

      Algebra::Polynomial.create(
        Algebra::Polynomial.create(
          Algebra::Polynomial.create(
            Integer,
          "x"),
        "y"),
      "z")

    と同値で、最後の変数 ((|z|)) が主変数となります。

--- ::var
    多項式環の変数（主変数）を返します。

--- ::vars
    再帰的に各多項式環の変数を集めた配列を返します。

--- ::mvar
    ((<::vars>)) と同じです。

--- ::to_ary
    (({[self, *vars]})) を返します。

    例: 多項式環と変数を同時に定義する。
      P, x, y, z = Algebra::Polynomial.create(Integer, "x", "y", "z")

--- ::variable
    変数（主変数）を表現するオブジェクトを返します。

--- ::variables
    再帰的に各多項式環の変数を表現するオブジェクトを
    集めた配列を返します。

--- ::indeterminate(obj)
    ((|obj|)) で表現される変数を再帰的に探して返します。

--- ::monomial([n])
    ((|n|)) 次の単項式を返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      P.monomial(3) #=> x^3

--- ::const(c)
    値 ((|c|)) の定数項を返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      P.const(3)      #=> 3
      P.const(3).type #=> P

--- ::zero
    零元を返します。

--- ::unity
    単位元を返します。

#--- ::euclidian?

== メソッド:

--- var
    ((<::var>)) と同じです。

--- variable
    ((<::variable>)) と同じです。

--- each(&b)
    各次の係数を昇冪順に繰り返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      (x**3 + 2*x**2 + 4).each do |c|
        p c #=> 4, 0, 2, 1
      end

--- reverse_each(&b)
    各次の係数を降冪順に繰り返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      (x**3 + 2*x**2 + 4).reverse_each do |c|
        p c #=> 1, 2, 0, 4
      end

--- [](n)
    ((|n|)) 次の係数を返します。

--- []=(n, v)
    ((|n|)) 次の係数を((|v|))に設定します。

--- monomial
    ((<::monomial>)) と同じです。

--- monomial?
    単項式であるとき真を返します。

--- zero?
    零元であるとき真を返します。

--- zero
    零元を返します。

--- unity
    単位元を返します。

#--- variable=(bf)
#--- size
#--- compact!
#--- ground_div(n, d)

--- ==(other)
    等しいとき真を返します。

--- <=>(other)
    大小関係を求めます。

--- +(other)
    和を計算します。

--- -(other)
    差を計算します。

--- *(other)
    積を計算します。

--- **(n)
    ((|n|)) 乗を計算します。

--- /(other)
    商を計算します。((<div>))と同じです。

--- divmod(other)
    ((|other|)) で割った商と余りの配列を返します。

--- div(other)
    ((|other|)) で割った商を返します。(({divmod(other).first}))
    と一致します。

--- %(other)
    ((|other|)) で割った余りを返します。(({divmod(other).last}))
    と一致します。

--- divide?(other)
    ((|other|)) で割り切れるとき真を返します。
    (({divmod(other).last == zero?}))と一致します。

--- deg
    次数を返します。

    例:
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      (5*x**3 + 2*x + 1).deg #=> 3

--- lc
    先頭係数(leading coeffcient)を返します。

    例:
      (5*x**3 + 2*x + 1).lc #=> 5

--- lm
    先頭単項式(leading monomial)を返します。

    例:
      (5*x**3 + 2*x + 1).lm #=> x**3

--- lt
    先頭項(leading term)を返します。(({lc * lm}))と等しい値を持ちます。

    例:
      (5*x**3 + 2*x + 1).lt #=> 5*x**3

--- rt
    残余項(rest term)を返します。(({self - lt}))と等しい値を持ちます。

    例:
      (5*x**3 + 2*x + 1).rt #=> 2*x + 1

--- monic
    最高次係数を1に直した式を返します。(({self / lc})) と同じ値を持
    ちます。

--- cont
    係因数(content(全ての係数の最大公約数)）を返します。

--- pp
    原始的部分(primitive part)を返します。(({self / cont}))と
    同じ値を持ちます。

--- to_s
    文字列表現を得ます。表示形式を変えるには ((|display_type|)) を用います。
    ((|display_type|)) に与えられる値は ((|:norm|))(デフォルト), ((|:code|))
    です。

    例:
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      p 5*x**3 + 2*x + 1 #=>5x^3 + 2x + 1
      P.display_type = :code
      p 5*x**3 + 2*x + 1 #=> 5*x**3 + 2*x + 1

--- derivate
    微分した値を返します。

    例:
      (5*x**3 + 2*x + 1).derivate #=> 15*x**2 + 2

--- sylvester_matrix(other)
    ((|other|)) とのシルベスター行列を返します。

--- resultant(other)
    ((|other|)) との集結式返します。予め

--- project(ring[, obj]){|c, n| ... }
    各単項式について、
    次数を ((|n|)) に、係数 ((|c|)) に代入し ... を評価したものを
    その単項式の値に置き換え、((|ring|)) 上で和を取った値を
    返します。((|obj|)) が省略されると (({ring.var})) が用いら
    れます。

    例:
      require "polynomial"
      require "rational"
      P = Algebra::Polynomial(Integer, "x")
      PQ = Algebra::Polynomial(Rational, "y")
      x = P.var
      f = 5*x**3 + 2*x + 1
      p f.convert_to(PQ) #=> 5y^3 + 2y + 1
      p f.project(PQ) {|c, n| Rational(c) / (n + 1)} #=> 5/4y^3 + y + 1

--- evaluate(obj)
    主変数に ((|obj|)) を代入した値を返します。
    (({ project(ground, obj){|c, n| c} })) の値と一致します。

    例:
      require "polynomial"
      P = Algebra::Polynomial(Integer, "x")
      x = P.var
      f = x**3 - 3*x**2 + 1
      p f.evaluate(-1)    #=> -3 (in Integer)
      p f.evaluate(x + 1) #=> x^3 - 3x - 1 (in P)

--- call(obj)
    ((<evaluate>))と同じです。

--- sub(var, value)
    変数 ((|var|)) に ((|value|)) を代入した値を返します。

    例:
      require "polynomial"
      P = Algebra::Polynomial(Integer, "x", "y", "z")
      x, y, z = P.vars
      f = (x - y)*(y - z - 1)
      p f.sub(y, z+1)    #=> 0

--- convert_to(ring)
    各項を((|ring|))上で評価します。(({ project(ring){|c, n| c} }))の
    値と一致します。

= Algebra::PolynomialFactorization
((*(因数分解モジュール)*))

因数分解をするためのモジュールです。

== ファイル名:
((|polynomial-factor.rb|))

== メソッド:

--- sqfree
    無平方化します。

--- sqfree?
    無平方なら真を返します。

--- irreducible?
    既約なら真を返します。

--- factorize
    因数分解します。

    因数分解可能な係数環は
    * Integer
    * Rational
    * 素体
    * 代数体（Rational 上の有限次拡大）
    です。

= Algebra::SplittingField
((*(分解体モジュール)*))

多項式の最小分解体を求めるためのモジュール

== ファイル名:
* ((|splitting-field.rb|))

== メソッド:

--- decompose([fac0])
    自身の最小分解体を ((|field|))、拡大に要した既約多項式
    の配列を ((|def_polys|))、最小分解体上で1次式の積に因数分解し
    たものを ((|facts|))、多項式の根の配列を ((|roots|))、
    ((|roots|)) を基礎体に添加した元が前に来るように並べ替えた
    の配列を ((|proots|)) として、

      [field, def_polys, facts, roots, proots]

    を返します。基礎体上の因数分解 ((|fac0|)) を添えると高速化に役立ちます。
    （((|facts|)) の要素と ((|fact0|)) は ((|Algebra::Factors|)) オブジェクト
    、((|field|)) は
    ((<AlgebraicExtensionField|algebraic-extension-field.html>))
    オブジェクトです。ただし、自身が一次因子に分解されるときは
    ((<groud>)) そのものを返します。

    例:
      require "algebra"
      PQ = Polynomial(Rational, "x")
      x = PQ.var
      f = x**5 - x**4 + 2*x - 2
      field, def_polys, facts, roots, proots = f.decompose
      p def_polys #=> [a^4 + 2, b^2 + a^2]
      p facts    #=> (x - 1)(x - a)(x + a)(x - b)(x + b)
      p roots    #=> [1, a, -a, b, -b]
      p proots   #=> [a, b, 1, -a, -b]
      fp = Polynomial(field, "x")
      x = fp.var
      facts1 = Factors.new(facts.collect{|g, n| [g.call(x), n]})
      p facts1.pi == f.convert_to(fp) #=> true

--- splitting_field([fac0]))
    自身の最小分解体の情報を返します。返り値の各フィールドの値は以下
    の通りです。poly_exps 以外は ((<decompose>)) の以下のものに相当します。

    poly, field, roots, proots, def_polys

    ただし、((|roots|))、((|proots|)) の各要素は ((|field|)) の
    要素として変換されています。

    例:
      require "algebra"
      PQ = Polynomial(Rational, "x")
      x = PQ.var
      f = x**5 - x**4 + 2*x - 2
      sf = f.splitting_field
      p sf.roots     #=> [1, a, -a, b, -b]
      p sf.proots     #=> [a, b, 1, -a, -b]
      p sf.def_polys #=> [a^4 + 2, b^2 + a^2]

= Algebra::Galois
((*(ガロア群)*))

多項式のガロア群を求めるためのモジュール

== ファイル名:
* ((|galois-group.rb|))

== インクルードしているモジュール:
* なし

== 関連するメソッド:

--- GaloisGroup.galois_group(poly)
    ((<galois_group>)) と同じ

== モジュールメソッド:
* なし

== メソッド:

--- galois_group
    多項式のガロア群を返します。群は各元が
    ((<PermutationGroup|permutation-group.html>)) である
    ((<FiniteGroup|finite-group.html>)) オブジェクトとして表現されます。

    例:
      require "rational"
      require "polynomial"

      P = Algebra.Polynomial(Rational, "x")
      x = P.var
      p( (x**3 - 3*x + 1).galois_group.to_a )
      #=>[[0, 1, 2], [1, 2, 0], [2, 0, 1]]

      (x**3 - x + 1).galois_group.each do |g|
        p g
      end
      #=> [0, 1, 2]
      #   [1, 0, 2]
      #   [2, 0, 1]
      #   [0, 2, 1]
      #   [1, 2, 0]
      #   [2, 1, 0]

=end


#-------------------------------------------------------------------
# vtfn -- Generate spectrum of vocal tract response given formant
#         frequency, amplitude, and bandwidth.
#
# Args:
#  pars -- A vector of named parameters for 8 formants. Each
#          parameter has a name such as f[1-8][fba] to specify
#          formant number (1-8) and parameter (f(requency),
#          b(andwidth), or a(mplitude)). All frequencies and
#          bandwidths specified in Hertz, and amplitudes in dB.
#
#  np   -- The number of points of spectrum values to cover the
#          Nyquist range from 0 - fs/2. This is deceptive because,
#          to be consistent with FFT concentions, there will really
#          be an np+1 point spectrum returned with the first value
#          corresponding to DC and the last to the Nyquist frequency.
#
#  fs   -- Sampling frequency in Hz.
#
# Notes: This is the "parallel formant" version with each formant
#        curve calculated independently and added to the others.
#        Each formant is also multiplied by an amplitude factor
#        that is passed as a quantity in dB via the pars vector.
#        Additionally, this function called the underlying formant
#        function with scaled=TRUE so that every formant response
#        curve is generated with a theoretical peak amplitude of 1.0.
#
# 1/10/20 -- htb
#-------------------------------------------------------------------

vtfn <- function(pars, np=512, fs=16000) {
  maxf <- fs/2
  a1s <- 10^(pars['f1a']/20)
  a2s <- 10^(pars['f2a']/20)
  a3s <- 10^(pars['f3a']/20)
  a4s <- 10^(pars['f4a']/20)
  a5s <- 10^(pars['f5a']/20)
  a6s <- 10^(pars['f6a']/20)
  a7s <- 10^(pars['f7a']/20)
  a8s <- 10^(pars['f8a']/20)

  f1 <- formant(pars['f1f'], pars['f1b'], np, maxf, scale=F)
  f2 <- formant(pars['f2f'], pars['f2b'], np, maxf, scale=F)
  f3 <- formant(pars['f3f'], pars['f3b'], np, maxf, scale=F)
  f4 <- formant(pars['f4f'], pars['f4b'], np, maxf, scale=F)
  f5 <- formant(pars['f5f'], pars['f5b'], np, maxf, scale=F)
  f6 <- formant(pars['f6f'], pars['f6b'], np, maxf, scale=F)
  f7 <- formant(pars['f7f'], pars['f7b'], np, maxf, scale=F)
  f8 <- formant(pars['f8f'], pars['f8b'], np, maxf, scale=F)

  s <- a1s*f1 + a2s*f2 + a3s*f3 + a4s*f4 + a5s*f5 +
    a6s*f6 + a7s*f7 + a8s*f8
  s
}


# take radius from user

a <- readline(prompt="Enter the radius:")
r <- as.double(a)

# compute area and store in a variable
area <- pi * r ^ 2

# print area
print(area)


QSAR_ridge_regression <- function (X, Y, K) {

     # Ridge regression with parcor package
     # Date: 8-4-2014
     # Author: Sheikh M. Rahman
     # require parcor, ggplot2 packages
     # X variables, Y response, k - fold validation
     ridgeFit <- ridge.cv(X, Y, k = K, scale = FALSE); # it will find the optimum lambda by 10-fold validation

     coeff_ridge <- matrix(ridgeFit$coefficients,nrow = 1)

     # fitted data
     yFit <- X %*% t(coeff_ridge) # matrix multiplication
     yFit <- yFit + ridgeFit$intercept # add intercept

     residualY <- yFit - Y # residual
     sumResidual <- sum(residualY);

     SquaredError <- (yFit - Y)^2
     SumSquareError <- sum(SquaredError);
     #############################################
     # R- square calculation
     # DOF: Model- p (p, no. of explanatory variables, not includes the intercept)
     #  	Error- n-p-1 (n, no. of samples)
     #############################################
     SumSquareModel <- sum((yFit - mean(Y))^2)
     SumSquareTotal <- sum((Y - mean(Y))^2)

     Rsquared <- SumSquareModel/SumSquareTotal;

     return (list(ridgeFit = ridgeFit, yFit = yFit, residualY = residualY,
                  sumResidual = sumResidual, SquaredError = SquaredError,
                  SumSquareError = SumSquareError, Rsquared = Rsquared, X = X, Yobs = Y))

}

QSAR_lasso_regression <- function (X, Y, K) {
     lassoFit <- adalasso(X,Y, k = K, both = FALSE); # it will find the optimum lambda by k-fold validation

     coeff_lasso <- matrix(lassoFit$coefficients.lasso,nrow = 1)

     # fitted data
     yFit <- X %*% t(coeff_lasso) # matrix multiplication
     yFit <- yFit + lassoFit$intercept.lasso # add intercept
     yFit[yFit<0] <- 0 # to change the negative value to 0
     residualY <- yFit - Y # residual
     sumResidual <- sum(residualY);

     SquaredError <- (yFit - Y)^2
     SumSquareError <- sum(SquaredError);

     #############################################
     # R- square calculation
     # DOF: Model- p (p, no. of explanatory variables, not includes the intercept)
     #       Error- n-p-1 (n, no. of samples)
     #############################################
     SumSquareModel <- sum((yFit - mean(Y))^2)
     SumSquareTotal <- sum((Y - mean(Y))^2)

     Rsquared <- SumSquareModel/SumSquareTotal;

     return (list(lassoFit = lassoFit, yFit = yFit, residualY = residualY,
                  sumResidual = sumResidual, SquaredError = SquaredError,
                  SumSquareError = SumSquareError, Rsquared = Rsquared, X = X, Yobs = Y))

}

plotPanelFigures <- function (Y, regMdl, axsLabel,subHdr) {
yTest_obs <- Y
#coeff <- matrix(regMdl$lassoFit$coefficients.lasso, nrow = 1)
#intercept <- regMdl$lassoFit$intercept.lasso
#yTest <- regMdl$X %*% t( coeff ) # matrix multiplication
yTest <- regMdl$yFit
#yTest[yTest<0] <- 1
#dat <- data.frame(xvar = log(yTest_obs), yvar = log(yTest))
dat <- data.frame(xvar = (yTest_obs), yvar = (yTest))
p <- ggplot(dat, aes(x=xvar, y=yvar)) + labs(title=axsLabel,subtitle=subHdr)+
  geom_point(colour="blue", size = 2.0, shape = 21, fill='orange') +
  theme_bw()  + coord_cartesian(xlim = c(0, 8000), ylim = c(0, 8000)) + #coord_cartesian(xlim = c(0, 10), ylim = c(0, 10)) +
  geom_abline(intercept = 0, slope = 1,'linetype' = 'dashed',color = 'black','size' = 0.5) +
  theme (axis.title = element_text(size=21), axis.text=element_text(colour="black",size=10)) +
  labs(x="", y="") +  theme(plot.title = element_text(size=12, hjust=0.5, face="bold", vjust=-1)) +
  theme(plot.subtitle = element_text(size=9, hjust=0.5, vjust=1)) +
  #annotate("text", x=1.25, y=9.5, label= paste("R^2 == ", round(regMdl$Rsquared,2)), parse=TRUE, size = 4,family="Arial", fontface = 2)
  annotate("text", x=1000, y=7500, label= paste("R^2 == ", round(regMdl$Rsquared,2)), parse=TRUE, size = 4,family="Arial", fontface = "bold")

#  labs(x=paste("Observed", axsLabel), y=paste("Predicted", axsLabel))

return(p)
}


# Likelihood and optimization of an AR(1) model with trend
# Rest is taken over from analysis v23

# Model ------------------------------------------------------------------------

set.seed(2020)

#' LogLikelihood of AR(1) model with drift and seasonality
#'
#' Box & Jenkins suggest using unconditional likelihood, but here I have taken
#' the approach of excluding p + q variables for ease.
#'
#' @param mu,sigma,phi scalars
#' @param betas vector of betas for xreg
#' @param xreg matrix of regressors similar to mu
#'
#' @keywords internal
logL <- function(x, mu, sigma, phi1, betas = NULL, xreg = NULL) {
  n <- length(x)
  M <- phi1*x[-n] + mu * (1 - phi1)
  if (!is.null(betas) || !is.null(xreg)) {
    reg <- xreg[-1,,drop=FALSE] - phi1*xreg[-n,,drop=FALSE]
    M <- M + reg %*% betas
  }
  squared <- (x[-1] - M)^2
  sum(-squared/(2*sigma^2)) - (n - 1)*log(sigma * sqrt(2*pi))
}

logL(rnorm(100), mu = 0, sigma = 1, phi1 = 5, betas = 2, xreg = matrix(c(rep(0, 4), 1:(100-4))))
logL(rnorm(100), mu = 0, sigma = 1, phi1 = 5)

logL.compile <- function(mu = NULL, sigma = NULL, phi1 = NULL, betas = list()) {

  stopifnot(length(betas) == 0 || !is.null(names(betas)))

  i <- 0

  fn.str <- sprintf(
    'function(par, x, xreg = NULL) {
      logL(x = x, mu = %s, sigma = %s, phi1 = %s, betas = %s, xreg = xreg)
    }'
    , if (is.null(mu)) sprintf('par[%i]', (i <- i + 1)) else mu
    , if (is.null(sigma)) sprintf('par[%i]', (i <- i + 1)) else sigma
    , if (is.null(phi1)) sprintf('par[%i]', (i <- i + 1)) else phi1
    , if (length(betas) > 0L)
      sprintf('c(%s)', paste(names(betas), '=', vapply(betas, function(v)
        if (is.null(v)) sprintf('par[%i]', (i <<- i + 1)) else as.character(v), ''), collapse = ', '))
      else 'NULL'
  )

  fn <- eval(parse(text = fn.str))
  environment(fn) <- globalenv()

  fn
}

(logL.fn <- logL.compile(phi1 = 0, betas = list('b1' = 1, 'b2' = NULL, 'b3' = 3)))
logL.fn(par = c(1,2,3), x = rnorm(100), xreg = matrix(rnorm(300), ncol = 3))
(logL.fn <- logL.compile(phi1 = 0))
logL.fn(par = c(1,2), x = rnorm(100))

sim <- function(n, mu, sigma, phi1, betas = NULL, xreg = NULL,
                init = mu, xt = NULL, a = rnorm(n, 0, sd = sigma)) {

  R <- rep(0, n)
  if (!is.null(betas) || !is.null(xreg)) {
    reg <- xreg[-1,,drop=FALSE] - phi1*xreg[-n,,drop=FALSE]
    R <- c(0, reg %*% betas)
  }

  if (is.null(xt)) {
    # xp is the previous x: x_{t-1}
    Reduce(f = function(xp, t) phi1*xp + mu*(1-phi1) + R[t] + a[t], x = 2:n, init = init, accumulate = TRUE)
  } else {
    c(xt[1],
      phi1*xt[-n] + mu*(1-phi1) + R[-1] + a[-1])
  }
}

set.seed(2020)

x.sim <- sim(10000, mu = 1032, sigma = sqrt(23), phi1 = 0.9, betas = 0, xreg = matrix(1:10000, ncol = 1))
plot(x.sim, type = 'l')
acf(x.sim)
pacf(x.sim)

x.sim.trend <- sim(10000, mu = 1032, sigma = sqrt(23), phi1 = 0.9, betas = 0.005, xreg = matrix(1:10000, ncol = 1))
plot(x.sim.trend, type = 'l')

#' Fit the custom drift detection model
#'
#' If specific parameters are supplied, then they will be fixed.
#'
#' @keywords internal
fit <- function(x, mu = NULL, sigma = NULL, phi1 = NULL,
                betas = if (is.null(xreg)) list() else setNames(vector('list', ncol(xreg)), colnames(xreg)),
                xreg = NULL) {

  stopifnot(is.null(xreg) || is.matrix(xreg))
  stopifnot(!is.matrix(xreg) || length(betas) == ncol(xreg))
  stopifnot(!is.matrix(xreg) || all(names(betas) == colnames(xreg)))

  all.param.names <- c('mu', 'sigma', 'phi1', names(betas))
  stopifnot(length(unique(all.param.names)) == length(all.param.names))

  stopifnot(!any(ls() %in% names(betas)))
  list2env(betas, envir = environment())

  inits <- c(
    'mu'= median(x),
    'sigma' = var(x),
    'phi1' = pacf(x, plot = FALSE, lag.max = 1)$acf[1,1,1],
    if (length(betas) == 0L) NULL else setNames(coef(lm(x ~ xreg))[-1], names(betas))
  )

  scale <- c(
    'mu' = if (length(betas) == 0L) 1 else summary(lm(x ~ xreg))$coefficients[1L, 2L],
    'sigma' = 1,
    'phi1' = 1/100,
    if (length(betas) == 0L) NULL else setNames(summary(lm(x ~ xreg))$coefficients[-1L, 2L], names(betas))
  )

  lower.bound <- c(
    'mu' = -Inf,
    'sigma' = 1e-7,
    'phi1' = -Inf,
    setNames(rep(-Inf, length(betas)), names(betas))
  )

  upper.bound <- c(
    'mu' = Inf,
    'sigma' = Inf,
    'phi1' = 1 - 1e-7,
    setNames(rep(Inf, length(betas)), names(betas))
  )

  fixed <- unlist(mget(all.param.names)[!sapply(mget(all.param.names), is.null)])
  param.names <- setdiff(all.param.names, names(fixed))

  opt <- optim(
    par = inits[param.names],
    fn = logL.compile(mu = mu, sigma = sigma, phi1 = phi1, betas = betas),
    method = 'L-BFGS-B',
    x = x,
    lower = lower.bound[param.names],
    upper = upper.bound[param.names],
    xreg = xreg,
    control = list('fnscale' = -1,
                   'parscale' = scale[param.names],
                   'trace' = 0)
  )

  # Add fixed parameters
  opt <- append(x = opt, values = list('par.fixed' = fixed), after = 1)

  opt
}

xreg.trend.1 <- matrix(data = 1:length(x.sim), dimnames = list(NULL, 'trend'))

# Here specification of likelihood is tested with general arima model.
## x.sim
fit(x = x.sim) # -29832.06
fit(x = x.sim, xreg = xreg.trend.1)
fit(x = x.sim, betas = list('trend' = 0), xreg = xreg.trend.1) # -29832.06

#forecast::auto.arima(y = x.sim, trace = TRUE)
fit.arima <- arima(x = x.sim, order = c(1, 0, 0))
fit.arima # -29835.35

## x.sim.trend
fit(x = x.sim.trend, xreg = xreg.trend.1) # -29997.49
fit.arima <- arima(x = x.sim.trend, order = c(1, 0, 0), xreg = xreg.trend.1)
fit.arima # -30000.82

# Data -------------------------------------------------------------------------

source('./../../gwloggeR/R/fourier.R')

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Meta data
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]

  data.table::setkey(df, TIMESTAMP_UTC)
  data.table::setattr(df, 'logger.name', logger.name)

  df
}

# from analysis 04
compare <- function(df1, df2) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(data.table::data.table())

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE, TIMESTAMP_UTC)][!is.na(PRESSURE_DIFF), ]

  data.table::setkey(diff.df, TIMESTAMP_UTC)

  diff.df
}

ref.compare <- function(logger.name) {
  compare(read.baro(logger.name), read.baro('KNMI_20200312_hourly'))
}

coef.pvals <- function(M) {
  (1-pnorm(abs(M$coef)/sqrt(diag(M$var.coef))))*2
}

plt.comp <- function(TIMESTAMP_UTC, Y, M = NULL, significant = NULL, front_layer = NULL,
                     xlim = range(TIMESTAMP_UTC), ylim = quantile(Y, c(0.005, 0.995))) {

  force(TIMESTAMP_UTC); force(Y); force(M)
  force(ylim); force(xlim)

  p <- ggplot2::ggplot(mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = Y)) +
    front_layer +
    ggplot2::geom_line(col = 'red', alpha = 0.9)

  if (!is.null(M))
    p <- p + ggplot2::geom_line(mapping = ggplot2::aes(y = fitted(M)), col = 'black', size = 1.5)

  if (!is.null(significant)) {
    p <- p + ggplot2::annotate(
      "label", x = as.POSIXct(-Inf, origin = '1970-01-01'), y = Inf,
      size = 4, col = if (significant) 'green' else 'red',
      hjust = 0, vjust = 1, fill = 'grey', label.size = NA,
      label = if (significant) 'SIGNIFINCANT' else 'NOT SIGNIFICANT'
    )
  }

  if (!is.null(M[['btrend']]) && coef.pvals(M)['btrend'] < 0.001)
    p <- p + ggplot2::geom_vline(xintercept = TIMESTAMP_UTC[which.max(M$btrend > 0)],
                                 col = 'blue', linetype = 'dotted', size = 1.2)

  p <- p +
    ggplot2::coord_cartesian(ylim = ylim, xlim = xlim) +
    ggplot2::ylab('PRESSURE_DIFF') +
    ggplot2::theme_light() +
    ggplot2::theme(axis.text.y = ggplot2::element_text(angle = 90, hjust = 0.5))

  p
}

report <- function(logger.name) {

  environment(plt.comp) <- environment() # fitted(Arima) then can find the source data.

  print(logger.name)

  df.diff <- ref.compare(logger.name)

  if (nrow(df.diff) < 10L) return(invisible(FALSE))

  # M <- fit(x = df.diff$PRESSURE_DIFF, phi1 = 0, d = 0, dsi = 1)
  M <- arima(x = df.diff$PRESSURE_DIFF, order = c(0, 0, 0))
  df.diff[, M_pred := fitted(M)]

  # M.AR <- fit(x = df.diff$PRESSURE_DIFF, d = 0, dsi = 1)
  M.AR <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0))
  df.diff[, M.AR.pred := fitted(M.AR)]

  trend <- c(0, cumsum(diff(as.numeric(df.diff$TIMESTAMP_UTC))/3600/24))
  breakpoints <- seq(from = 1, to = nrow(df.diff), by = 10)
  # M.ARD <- M.AR
  # for (bp in breakpoints) {
  #   .M <- fit(x = df.diff$PRESSURE_DIFF, dsi = bp)
  #   if (.M$value > M.ARD$value) M.ARD <- .M
  # }
  M.ARD <- M.AR
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = btrend)
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARD)) M.ARD <- .M
  }
  df.diff[, M.ARD.pred := fitted(M.ARD)]

  sbasis <- fbasis(timestamps = df.diff$TIMESTAMP_UTC, frequencies = 1/(365.25*3600*24))

  M.ARS <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = sbasis)

  M.ARDS <- M.ARS
  for (bp in breakpoints) {
    btrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
    .M <- arima(x = df.diff$PRESSURE_DIFF, order = c(1, 0, 0), xreg = cbind(sbasis, btrend))
    .M[['btrend']] <- btrend
    if (logLik(.M) > logLik(M.ARDS)) M.ARDS <- .M
  }

  p.comp <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF)

  p.M <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M)

  p.M.AR <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.AR)

  p.M.ARS <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARS)

  p.M.ARD <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARD)

  p.M.ARDS <- plt.comp(df.diff$TIMESTAMP_UTC, df.diff$PRESSURE_DIFF, M.ARDS)

  # File export ----------------------------------------------------------------

  filename <- sprintf('./drifts/analysis_25/%s.png', tools::file_path_sans_ext(basename(logger.name)))
  dir.create(dirname(filename), showWarnings = FALSE, recursive = TRUE)

  layout_matrix <- rbind(c(1, 2),
                         c(3, 4),
                         c(5, 6))

  grob.title <- grid::textGrob(sprintf('%s (#%s differences with KNMI data from %s to %s)',
                                       basename(logger.name), nrow(df.diff),
                                       min(df.diff$TIMESTAMP_UTC), max(df.diff$TIMESTAMP_UTC)),
                               x = 0.05, hjust = 0)

  p.empty <- ggplot2::ggplot() + ggplot2::theme_void()

  local({
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    gridExtra::grid.arrange(p.comp, p.empty,
                            p.M, p.M.ARS,
                            p.M.ARD, p.M.ARDS,
                            layout_matrix = layout_matrix,
                            top = grob.title)
  })

  invisible(TRUE)

}

# report('BAOL009X_78680')
invisible(lapply(logger.names, report))


# 07. Beta Diversity
# Figure 3c, Figure 5c, Figure S6, Figure S10
# Ref for CLR PCA: Gloor, G. B.; Macklaim, J. M.; Pawlowsky-Glahn, V.; Egozcue, J. J. Microbiome Datasets Are Compositional: And This Is Not Optional. Front. Microbiol. 2017, 8. https://doi.org/10.3389/fmicb.2017.02224.
# Ref for PhILR PCA: Silverman, J. D.; Washburne, A. D.; Mukherjee, S.; David, L. A. A Phylogenetic Transform Enhances Analysis of Compositional Microbiota Data. eLife 2017, 6, e21887. https://doi.org/10.7554/eLife.21887.
# Water and sediment sequences were analyzed separately

#### Phyloseq Object ####
ps.noncontam.tree

#### Set Directory ####
beta <- file.path(paste(path_phy, "/beta_diversity/Ordination", sep=""))
dir.create(beta, showWarnings=FALSE, recursive=TRUE)
setwd(beta)

#### CLR transformation ####
set.seed(2021)

# Obtain the OTU table
ps_filt_otu <- as.data.frame(otu_table(ps.noncontam.tree))
metadata <- as.data.frame(as.matrix(sample_data(ps.noncontam.tree)))

# Transform the OTU table and replace 0 values with an estimate
f.n0 <- cmultRepl(t(ps_filt_otu), method="CZM", label=0, output="p-counts")

# CLR Transformation
f.clr <- codaSeq.clr(f.n0, IQLR=FALSE)
head(f.clr)

# Check distribution
qplot(rowSums(f.clr),bins=50) + xlab("clr transformed counts-per-sample")
qplot(colSums(f.clr),bins=50) + xlab("clr transformed counts-per-taxa")

# Add CLR to phyloseq object
ps_clr <- phyloseq(
    otu_table(t(f.clr), taxa_are_rows = TRUE),
    sample_data(sample_data(ps.noncontam.tree)),
    phy_tree(filt_tree),
    tax_table(tax_table(ps.noncontam.tree))
)
ps_clr

# get PCA
f.pcx <- prcomp(f.clr)

# extract results from PCA
var <- get_pca_var(f.pcx)

# get eigenvalue
eig.val <- get_eigenvalue(f.pcx)
head(eig.val)

#### PhILR transformation ####
library("philr")

# Add clr to phyloseq object
ps_philr <- phyloseq(
    otu_table(t(f.n0), taxa_are_rows = TRUE),
    sample_data(sample_data(ps.noncontam.tree)),
    phy_tree(filt_tree),
    tax_table(tax_table(ps.noncontam.tree))
)
ps_philr

# check the object
is.rooted(phy_tree(ps_philr))
is.binary.tree(phy_tree(ps_philr))

# labels and name balance
phy_tree(ps_philr) <- makeNodeLabel(phy_tree(ps_philr), method="number", prefix='n')

name.balance(phy_tree(ps_philr), tax_table(ps_philr), 'n1')

# calculate philr
otu.table <- as.data.frame(otu_table(ps_philr))
otu.table <- as.matrix(t(otu.table))
tree <- phy_tree(ps_philr)
metadata <- sample_data(ps_philr)
tax <- tax_table(ps_philr)

gp.philr <- philr(otu.table, tree, part.weights='enorm.x.gm.counts', ilr.weights='blw.sqrt', return.all=TRUE)

# get philr info
gp.dist <- dist(gp.philr$df.ilrp, method="euclidean")
gp.pcoa <- ordinate(ps_philr, 'PCoA', distance=gp.dist)

#### Prepare for combining CLR and PhILR data to plot (Water Samples) ####
ordi_clr <- as.data.frame(f.pcx$x[,1:2])
ordi_clr$ID_keep <- rownames(ordi_clr)
head(ordi_clr)

DATA_PHYLOSEQ_FIXED$ID_keep <- rownames(DATA_PHYLOSEQ_FIXED)
ordi_data <- merge(DATA_PHYLOSEQ_FIXED, ordi_clr, by = c('ID_keep'))
ordi_data$strat_time <- ifelse(ordi_data$Season == "Fall", "Stratified (~7 months)",
                  ifelse(ordi_data$Season == "Spring", "Incipient Stratification",
                         ifelse(ordi_data$Season == "Summer", "Stratified (~3 months)", "")))
ordi_data$strat_time <- factor(ordi_data$strat_time, ordered = TRUE, levels = c("Incipient Stratification", "Stratified (~3 months)", "Stratified (~7 months)"))

ordi.scores_philr <- as.data.frame(gp.pcoa$vectors)
colnames(ordi.scores_philr) <- c("Axis.1philr", "Axis.2philr")
ordi.scores_philr <- ordi.scores_philr[c("Axis.1philr","Axis.2philr")]
ordi.scores_philr$ID_keep <- rownames(ordi.scores_philr)

# Merge data with ordi_data
ordi_data <- merge(ordi_data, ordi.scores_philr, by = c('ID_keep'))
head(ordi_data)
colnames(ordi_data)

# remove bad samples
ordi_data_sub <- subset(ordi_data, SampleID != "W64")
ordi_data_sub <- subset(ordi_data_sub, SampleID != "W66")
ordi_data_sub <- subset(ordi_data_sub, SampleID != "W67")

# remove batch 4 (same as batch 1 and 3)
ordi_data_sub_NoBatch4 <- subset(ordi_data_sub, Sequence_batch != "Batch4")

# data for plotting batches
ordi_data_sub_batch <- subset(ordi_data_sub, Plot_batch == "Y")

#### Prepare for combining CLR and PhILR data to plot (Sediment Samples) ####
# CLR
ordi_clr = ordinate(ps_clr, "PCoA", "euclidean")
head(ordi_clr$values)
head(ordi_clr$vectors)

ordi.scores_clr <- as.data.frame(ordi_clr$vectors)
ordi.scores_clr[,3:20] <- NULL
colnames(ordi.scores_clr) <- c("Axis.1clr", "Axis2.clr")
ordi.scores_clr$ID_keep <- rownames(ordi.scores_clr)

# PhILR
ordi.scores_philr <- as.data.frame(gp.pcoa$vectors)
ordi.scores_philr[,3:20] <- NULL
colnames(ordi.scores_philr) <- c("Axis.1philr", "Axis.2philr")
ordi.scores_philr$ID_keep <- rownames(ordi.scores_philr)

# Merge data with ordi_data
DATA_PHYLOSEQ_FIXED$ID_keep <- rownames(DATA_PHYLOSEQ_FIXED)
ordi_data <- merge(DATA_PHYLOSEQ_FIXED, ordi.scores_clr, by = c('ID_keep'))
ordi_data <- merge(ordi_data, ordi.scores_philr, by = c('ID_keep'))
head(ordi_data)

#### Plot CLR and PhILR PCA ####
# Set up theme
plot_theme <- theme(panel.background = element_rect(fill = "white", colour = "black", size = 1, linetype = "solid"),
    panel.border = element_rect(colour="black", size=1, fill=NA),
    strip.background=element_rect(fill='white', colour='white', size = 0),
    strip.text = element_text(face="bold", size=20),
    panel.spacing.x=unit(0.5, "lines"),
    panel.grid.major = element_line(size = 0),
    panel.grid.minor = element_line(size = 0),
    axis.text = element_text(size=15, colour="black"),
    axis.title = element_text(face="bold", size=20),
    legend.position="right",
    legend.key = element_rect(fill = "transparent"),
    legend.title = element_text(face="bold", size=20),
    legend.text = element_text(size=20),
    legend.background = element_rect(fill = "transparent"),
    legend.box.background = element_rect(fill = "transparent", colour = NA))
plot_guide <- guides(fill = guide_colourbar(frame.linewidth = 1, frame.colour = "black", ticks = TRUE, ticks.colour = "black", ticks.linewidth = 1, reverse=T),
    shape = guide_legend(order=1, override.aes = list(size = 5, color="black", alpha=1)),
    color = "none")

### CLR PCA
## Water Samples
clr_plot_final <- ggplot(ordi_data_sub_NoBatch4, aes(x=PC1, y = PC2)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, aes(fill=Depth_meters, shape=strat_time)) +
    xlab(paste("PC1: 29.2%")) +
    ylab(paste("PC2: 15.3%")) +
    scale_shape_manual(name = "Stratification?", values=c(21, 23, 24)) +
    scale_fill_gradient2(name = "Depth (m)", breaks = c(0, 2, 6, 10), limits = c(0, 10), low="#fffab1", mid="#ed105f", high="#023e73", midpoint=5) +
     plot_theme + plot_guide
clr_plot_final

save_file <- paste("clr.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# label CLR PCA
clr_plot_label <- clr_plot_final +
    geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)

save_file <- paste("clr_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# Plot batches CLR PCA
plot_guide <- guides(shape = guide_legend(order=1, override.aes = list(size = 5, color="black", alpha=1)),
                     color = "none")
ordi_data_sub_batch$Sequence_batch <- gsub("Batch1", "Batch 1", ordi_data_sub_batch$Sequence_batch)
ordi_data_sub_batch$Sequence_batch <- gsub("Batch2", "Batch 2", ordi_data_sub_batch$Sequence_batch)
ordi_data_sub_batch$Sequence_batch <- gsub("Batch3", "Batch 3", ordi_data_sub_batch$Sequence_batch)
ordi_data_sub_batch$Sequence_batch <- gsub("Batch4", "Batch 4", ordi_data_sub_batch$Sequence_batch)

clr_plot_batch <- ggplot(ordi_data_sub_batch, aes(x=PC1, y = PC2)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, shape=21, aes(fill=Sequence_batch)) +
    xlab(paste("PC1: 29.2%")) +
    ylab(paste("PC2: 15.3%")) +
    scale_fill_manual(name="Sequence Batch", values = c("#003566", "#ffc300", "#ed105f")) +
    plot_theme + plot_guide

save_file <- paste("clr_plot_batch.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# label CLR PCA batch
clr_plot_batch_label <- clr_plot_batch +
    geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)
clr_plot_batch_label

save_file <- paste("clr_plot_batch_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

## Sediment Samples
clr_plot_final <- ggplot(ordi_data, aes(x=Axis.1clr, y = Axis2.clr)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, aes(fill=Location_description, shape=Depth_desc)) +
    xlab(paste("PC1: 23.6%")) +
    ylab(paste("PC2: 10.8%")) +
    scale_shape_manual(name = "Depth layer", values=c(25, 21, 22)) +
    scale_fill_manual(name = "Location", values=c("#dcab6b", "#9be564")) +
    plot_theme + plot_guide
clr_plot_final

# save file
save_file <- paste("PCA_clr.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 9, height = 5, units = c("in"), dpi = 300)

# label plot
clr_plot_label <- clr_plot_final +
geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)
pca_clr_label

# save file
save_file <- paste("PCA_clr_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 9, height = 5, units = c("in"), dpi = 300)

### Plot PhILR PCA
## Water Samples
plot_guide <- guides(fill = guide_colourbar(frame.linewidth = 1, frame.colour = "black", ticks = TRUE, ticks.colour = "black", ticks.linewidth = 1, reverse=T),
    shape = guide_legend(order=1, override.aes = list(size = 5, color="black", alpha=1)),
    color = "none")

philr_plot_final <- ggplot(ordi_data_sub_NoBatch4, aes(x=Axis.1philr, y = Axis.2philr)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, aes(fill=Depth_meters, shape=strat_time)) +
    xlab(paste("PC1: 53.8%")) +
    ylab(paste("PC2: 14.5%")) +
    scale_shape_manual(name = "Stratification?", values=c(21, 23, 24)) +
    scale_fill_gradient2(name = "Depth (m)", breaks = c(0, 2, 6, 10), limits = c(0, 10), low="#fffab1", mid="#ed105f", high="#023e73", midpoint=5) +
     plot_theme + plot_guide
philr_plot_final

save_file <- paste("philr.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# label PhILR PCA plot
philr_plot_label <- philr_plot_final +
    geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)

save_file <- paste("philr_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# plot batches PhILR PCA
plot_guide <- guides(shape = guide_legend(order=1, override.aes = list(size = 5, color="black", alpha=1)),
                     color = "none")

philr_plot_batch <- ggplot(ordi_data_sub_batch, aes(x=Axis.1philr, y = Axis.2philr)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, shape=21, aes(fill=Sequence_batch)) +
    xlab(paste("PC1: 53.8%")) +
    ylab(paste("PC2: 14.5%")) +
    scale_fill_manual(name="Sequence Batch", values = c("#003566", "#ffc300", "#ed105f")) +
    plot_theme + plot_guide

save_file <- paste("philr_plot_batch.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

# label PhILR PCA batch
philr_plot_batch_label <- philr_plot_batch +
    geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)
philr_plot_batch_label

save_file <- paste("philr_plot_batch_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 8, height = 5, units = c("in"), dpi = 300)

## Sediment Samples
philr_plot_final <- ggplot(ordi_data, aes(x=Axis.1philr, y = Axis.2philr)) +
    geom_hline(yintercept=0, size=.2, linetype = "dashed", color="black") + geom_vline(xintercept=0, size=.2, linetype = "dashed", color="black") +
    geom_point(color="black", size=4, aes(fill=Location_description, shape=Depth_desc)) +
    xlab(paste("PC1: 52.7%")) +
    ylab(paste("PC2: 8.7%")) +
    scale_shape_manual(name = "Depth layer", values=c(25, 21, 22)) +
    scale_fill_manual(name = "Location", values=c("#dcab6b", "#9be564")) +
    plot_theme + plot_guide
philr_plot_final

# save file
save_file <- paste("PCA_philr.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 9, height = 5, units = c("in"), dpi = 300)

# label plot
philr_plot_label <- philr_plot_final +
geom_label_repel(aes(label = SampleID), box.padding = 0.35, point.padding = 0.5, segment.color = 'grey50', max.overlaps=Inf)
pca_philr_label

# save file
save_file <- paste("PCA_philr_labelled.pdf", sep="")
ggsave(save_file, path = beta, scale = 1, width = 9, height = 5, units = c("in"), dpi = 300)

### combine CLR and PhILR PCA plots (Figure 3c, Figure 5c, Figure S6, Figure S10)
both <- plot_grid(clr_plot_final + theme(legend.position="none"),
                 philr_plot_final + theme(legend.position="none"),
                 ncol=2, align = "v", axis="b")

save_file <- paste("Combo_ordination.pdf", sep="")
ggsave(save_file, path = beta, plot = both, scale = 1, width = 10, height = 5, units = c("in"), dpi = 300)

# Water Samples Labelled
both <- plot_grid(clr_plot_batch_label + theme(legend.position="none"),
                 philr_plot_batch_label + theme(legend.position="none"),
                 ncol=3, align = "v", axis="b")

# Sediment Samples Labelled
both <- plot_grid(clr_plot_label + theme(legend.position="none"),
                 philr_plot_label + theme(legend.position="none"),
                 ncol=3, align = "v", axis="b")

save_file <- paste("Combo_ordination_batch_labelled.svg", sep="")
ggsave(save_file, path = beta, plot = both, scale = 1, width = 15, height = 5, units = c("in"), dpi = 300)

#### Stats on beta diversity ####

# obtain distance matrix CLR
ordi_clr_dist <- as.matrix(phyloseq::distance(ps_clr, method="euclidean"))
head(ordi_clr_dist)

# obtain distance matrix PhILR
ordi_philr_dist <- as.matrix(gp.dist)
head(ordi_philr_dist)

# Water ADONIS
adonis2(ordi_clr_dist~DATA_PHYLOSEQ_FIXED$Depth_cat + DATA_PHYLOSEQ_FIXED$Location_description + DATA_PHYLOSEQ_FIXED$Season, permutations=999, by="margin", method="euclidean")
adonis2(ordi_philr_dist~DATA_PHYLOSEQ_FIXED$Depth_cat + DATA_PHYLOSEQ_FIXED$Location_description + DATA_PHYLOSEQ_FIXED$Season, permutations=999, by="margin", method="euclidean")

# Sediment ADONIS
adonis2(ordi_clr_dist~DATA_PHYLOSEQ_FIXED$Location + DATA_PHYLOSEQ_FIXED$Depth_cat, permutations=999, by="margin", method="euclidean")
adonis2(ordi_philr_dist~DATA_PHYLOSEQ_FIXED$Location + DATA_PHYLOSEQ_FIXED$Depth_cat, permutations=999, by="margin", method="euclidean")

# Water Geochem ADONIS
adonis2(ordi_clr_dist~
        DATA_PHYLOSEQ_FIXED$Fe_mg_L+
        DATA_PHYLOSEQ_FIXED$ChlA_RFU+
        DATA_PHYLOSEQ_FIXED$DO_percSat+
        DATA_PHYLOSEQ_FIXED$TDS_ppt+
        DATA_PHYLOSEQ_FIXED$pH+
        DATA_PHYLOSEQ_FIXED$Temp_C+
        DATA_PHYLOSEQ_FIXED$Fe_mg_L, permutations=999, by="margin", method="euclidean")

adonis2(ordi_philr_dist~
    DATA_PHYLOSEQ_FIXED$Fe_mg_L+
    DATA_PHYLOSEQ_FIXED$ChlA_RFU+
    DATA_PHYLOSEQ_FIXED$DO_percSat+
    DATA_PHYLOSEQ_FIXED$TDS_ppt+
    DATA_PHYLOSEQ_FIXED$pH+
    DATA_PHYLOSEQ_FIXED$Temp_C+
    DATA_PHYLOSEQ_FIXED$Fe_mg_L, permutations=999, by="margin", method="euclidean")


# Prediction efficiency in two ways, plus identity of taxa for which we obtain a, b, c or d
prediction_accuracy_id <- function(predicted, empirical) {
    # Parameters:
    #   predicted   matrix of predicted interactions
    #   empirical   matrix of empirical interactions

    #   Output      vector of a, b, c, d, and TSS
    #       a       number of links predicted (1) and observed (1)
    #       b       number predicted (1) but not observed (0)
    #       c       number predicted absent (0) but observed (1)
    #       d       number of predicted absent (0) and observed absent (0)
    #       TSS     TSS = (ad-bc)/[(a+c)(b+d)]
    #                   "[...] quantifies the proportion of prediction success relative to false predictions
    #                   and returns values ranging between 1 (perfect predictions) and 1 (inverted forecast)
    #                   (Allouche, Tsoar & Kadmon 2006)." Gravel et al. 2013
    #       ScoreY1 Fraction of 1 correctly predicted a / (a + c)
    #       ScoreY0 Fraction of 0 correctly predicted d / (b + d)
    #       FSS     FSS = ScoreY1 + ScoreY0 / sum(a, b, c, d)^2

    if(identical(colnames(predicted), colnames(empirical)) == FALSE ||
        identical(rownames(predicted), rownames(empirical)) == FALSE ||
        identical(dim(predicted), dim(empirical)) == FALSE) {
            print('matrices need to have same dimensions and row and column names')
            break
    }

    efficiency <- numeric(8)
    aa <- bb <- cc <- dd <-  numeric(2)
    names(efficiency) <- c('a','b','c','d','TSS','ScoreY1','ScoreY0','FSS')

    for(i in 1:ncol(predicted)){
        for(j in 1:nrow(predicted)) {
            if(predicted[i,j] == 1 && empirical[i,j] == 1) {
                efficiency[1] <- efficiency[1] + 1
                aa <- rbind(aa,c(j,i))
            } else if(predicted[i,j] == 1 && empirical[i,j] == 0) {
                efficiency[2] <- efficiency[2] + 1
                bb <- rbind(bb,c(j,i))
            } else if(predicted[i,j] == 0 && empirical[i,j] == 1) {
                efficiency[3] <- efficiency[3] + 1
                cc <- rbind(cc,c(j,i))
            } else if(predicted[i,j] == 0 && empirical[i,j] == 0) {
                efficiency[4] <- efficiency[4] + 1
                dd <- rbind(dd,c(j,i))
            }
        }
    }

    a <- efficiency[1]
    b <- efficiency[2]
    c <- efficiency[3]
    d <- efficiency[4]

    efficiency[5] <- ((a * d) - (b * c)) / ((a + c) * (b + d))  # TSS
    efficiency[6] <- a / (a + c)                                # ScoreY1
    efficiency[7] <- d / (b + d)                                # ScoreY0
    efficiency[8] <- (a + d) / sum(a, b, c, d)    # FSS

    efficiency.id <- vector('list',5)
    efficiency.id[[1]] <- efficiency
    efficiency.id[[2]] <- aa
    efficiency.id[[3]] <- bb
    efficiency.id[[4]] <- cc
    efficiency.id[[5]] <- dd

    return(efficiency.id)
}


khat.new=function(h,p){
num=(1-((h^2+2)/h^2)^(-p/2))^2
din = ((h^2 + 4)/h^2)^(-p/2) - 2 * ((h^2 + 1)/h^2)^(-p/2) *
        ((h^2 + 3)/h^2)^(-p/2) + ((h^2 + 2)/h^2)^(-p)
dof=num/din
return(p * (dof^(1/p) - 1)/2)
}

khat.direct=function(h,p,k) khat.new(h,p)-k

hvec=function(p,len=10){
kvec=seq(2,15,length.out=len)
h=rep(0,length=len)
for (i in 1:len){
h[i]=uniroot(khat.direct, c(0.1,7), p=p,k=kvec[i])$root
}
return(h)
}