#' @title findMoments
#' @description to find the first two moments of a distrbution from quantile breaks (defined by the upper and lower percent)
#' @note Gamma distribution returns shape and scale rather than rate (as per winbugs distribution) for use in r rate=1/scale lo and l.perc are the value and percentile for the low end of the distribution, up and u.perc are the upper values and percentiles
#' @family abysmally documented
#' @author  Adam Cook, \email{Adam.Cook@@dfo-mpo.gc.ca}
#' @export
#source('C:/Documents and Settings/cooka/Desktop/Scripts/Surplus Production dec 2011/bugs/finding moments of distributions.R')
####Date:			February 10, 2012

findMoments <- function(lo=0.1,up=0.8,l.perc=0.025,u.perc=0.975,dist=c('norm','lnorm','weibull','gamma','inv.gamma'),plot=T) {
	if(dist=='norm') {
			 sig2 = ((up-lo)/(qnorm(u.perc)-qnorm(l.perc)))^2
			 xbar = (lo*qnorm(u.perc)-up*qnorm(l.perc))/(qnorm(u.perc)-qnorm(l.perc))
			 if(plot) {
			 plot(density(rnorm(10000,xbar,sqrt(sig2))),main='')
			 abline(v=lo)
			 abline(v=up)
			 }
			 return(list(xbar=xbar,sig2=sig2))
	  }
	if(dist=='lnorm') {
			 sig2 = ((log(up)-log(lo))/(qnorm(u.perc)-qnorm(l.perc)))^2
			 xbar = (log(lo)*qnorm(u.perc)-log(up)*qnorm(l.perc))/(qnorm(u.perc)-qnorm(l.perc))
			 if(plot) {
			 plot(density(rlnorm(10000,xbar,sqrt(sig2))),main='')
			 abline(v=lo)
			 abline(v=up)
			 }
			  return(list(xbar=xbar,sig2=sig2))
	 }
	if(dist=='weibull') {
			gam = (log(-log(1-u.perc))-log(-log(1-l.perc)))/(log(up)-log(lo))
			beta = lo/(-log(1-l.perc))^(1/gam)
			if(plot) {
		 	plot(density(rweibull(10000,gam,beta)),main='')
		 	abline(v=lo)
		 	abline(v=up)
		 }
			return(list(shape=gam,beta=beta))
	}
	if(dist=='gamma') {
			a=mean(c(lo,up))
			alpha <- function(a) {
			b <- qgamma(u.perc,a,1) / qgamma(l.perc,a,1)
			o = (b-(up/lo))^2
			return(list(a=a,o=o))
			}
			op<-function(a) alpha(a)$o
			ot <- optimize(f=op,interval=c(0,up))
			alp <- ot$minimum
			en <- lo/qgamma(l.perc,alp,1)
			if(plot) {
		 	plot(density(rgamma(10000,alp,scale=en)),main='')
		 	abline(v=lo)
		 	abline(v=up)
		 }
			return(list(shape=alp,scale=en))
	}
		if(dist=='inv.gamma') {
			a=mean(c(1/lo,1/up))
			ilo<-1/lo
			iup<-1/up
			alpha <- function(a) {
			b <- qgamma((1-u.perc),a,1) / qgamma((1-l.perc),a,1)
			o = (b-(iup/ilo))^2
			return(list(a=a,o=o))
			}
			op<-function(a) alpha(a)$o
			ot <- optimize(f=op,interval=c(0,up))
			alp <- ot$minimum
			en <- ilo/(1/qgamma((1-l.perc),alp,1))
			if(plot) {
		 	plot(density(1/rgamma(10000,alp,scale=1/en)),main='')
		 	abline(v=lo)
		 	abline(v=up)
		 }
			return(list(shape=alp,scale=en))
	}
}


#' Probability of path choices
#'
#' This function calculates probabilities for selection of each path on the network based on set of path disutilities (costs). The function uses either a logit or probit random utility model.
#' @param u Vector of utlities on each path
#' @param ODpair Vector indicating the OD pair serviced by each route (ordered by columns of the path-link incidence matrix, A).
#' @param A Path-link incidence matrix
#' @param RUM Choice of random utility model. Can be "logit" (the default) or "probit".
#' @param theta A dispersion parameter. For the logit model, a single value specifying the logit parameter. For the probit model, a vector of standard deviations for the individual link cost errors. Defaults to 1.
#' @return Vector of route choice probabilities
#' @keywords path route probability
#' @examples
#' A <- matrix(c(0,1,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0,1),ncol=4,byrow=T)
#' ODpair <- c(1,1,2,2)
#' Alpha <- rep(10,7)
#' Beta <- rep(2,7)
#' pow <- rep(4,7)
#' path_flow <- c(10,20,15,15)
#' x <- A%*%path_flow
#' u <- PathCost(x,A,Alpha,Beta)
#' PathProb(u,ODpair,A,RUM="logit",theta=0.7)
#' @export

PathProb <- function(u,ODpair,A,RUM="logit",theta=1){
	if(RUM=="logit"){
		p <- LogitPathProb(u=u,ODpair=ODpair,theta=theta)
	}
	if(RUM=="probit"){
		p <- ProbitPathProb(u=u,ODpair=ODpair,A=A,theta=theta)
	}
	p
}


#' f_loss
#'
#' Return the quantile loss criteria
#'
#' @param til_beta the current estimation fro $\tilde{\beta}$
#' @param taustar vector of estimated tau for each observations
#' @param v_y vector of y
#'
#' @param m_sigma $K_1K_2 \times K_1K_2 \Sigma$ diagonal block matix.
#' @param h1 $K_1K_2$ vector $H_1$
#' @param h2 $K_1K_2$ vector $H_2$
#'
#' @return the quantile loss
#'
f_loss <- function(til_beta, taustar, v_y, m_sigma, h1, h2) {
    loss <- crossprod((taustar - 0.5), v_y)
    loss <- loss - crossprod((h1 + h2), m_sigma %*% til_beta)
    loss <- loss / length(v_y)
    return(c(loss))
}

#' f_criteria
#'
#' Return the QR criteria
#'
#' @param beta the current estimation for $\beta$
#' @param til_beta the current estimation fro $\tilde{\beta}$
#' @param taustar vector of estimated tau for each observations
#' @param v_y vector of y
#'
#' @param m_sigma $K_1K_2 \times K_1K_2 \Sigma$ diagonal block matix.
#' @param h1 $K_1K_2$ vector $H_1$
#' @param h2 $K_1K_2$ vector $H_2$
#' @param s $K_1K_2 \times K_1K_2$ $S$ matrix
#'
#' @return the quantile loss
#'
f_criteria <- function(beta, til_beta, taustar, v_y, m_sigma, h1, h2, s) {
    loss <- f_loss(til_beta, taustar, v_y, m_sigma, h1, h2)
    criteria <- loss + crossprod(beta, s %*% beta)
    return(c(criteria))
}


library(rstudioapi)
library(ellipse)
this.dir <- dirname(rstudioapi::getActiveDocumentContext()$path)
setwd(this.dir)

##### DATA #####

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

##### 8.3 ######
eigen(as.matrix(rbind(c(2,0,0),c(0,4,0),c(0,0,4))))

##### 8.6 #####
s = as.matrix(cbind(c(7476.45,303.62),c(303.62,26.19)))
eigen = eigen(s)

xbar =c(155.6,14.7)
plot(ellipse(s,centre =xbar),type = 'l',xlim=c(-100,400),ylim=c(0,30),xlab = "X1",ylab = "X2",main = "constant density ellipse")
points(xbar[1],xbar[2],pch = 17)
c = sqrt(1.4)
ax1=c*sqrt(eigen$values[1])*eigenS$vectors[,1]
ax2=c*sqrt(eigen$values[2])*eigenS$vectors[,2]
lines(c(xbar[1]-ax1[1],xbar[1]+ax1[1]),c(xbar[2]-ax1[2],xbar[2]+ax1[2]),lty=1)
lines(c(xbar[1]-ax2[1], xbar[1]+ax2[1]),c(xbar[2]-ax2[2],xbar[2]+ax2[2]),lty=2)
legend(x = "topleft", c("y1","y2"), lty = c(1,2))

##### 8.7 #####
p  = cov2cor(s)
eigen = eigen(p)

##### 8.18 #####
e8_18 = read.table("e8_18.txt",header = TRUE)
#assuming PCA output is based on correlation matrix (or variables of unit variance)
pc_correlations <- function(pca_output) {
  p <- ncol(pca_output$rotation)
  pccor=matrix(NA, nrow=p, ncol=p)
  for(i in 1:p){
    for(k in 1:p){
      pccor[k,i]=pca_output$rotation[k,i]*pca_output$sdev[i]
    }
  }
  colnames(pccor) <- paste0("PC", 1:p)
  rownames(pccor) <- rownames(pca_output$rotation)
  pccor
}
data("iris")
pca <- prcomp(iris[,1:4])
summary(pca)
pc_correlations(pca)


# Authors: Grzegorz Protaziuk, Robert Bembenik
# Script EDAMI lab6
# Clustering

#setting working directory - adjust a path to your directory with a dataset

install.packages("fpc")

library(dbscan)
library(fpc)
library(cluster)
library(factoextra)

##### kmeans ##################
set.seed(7777)

data("iris")
summary(iris)
iris2 = iris[,-5]
iris2

?kmeans
iris2.kmeans = kmeans(iris2,3, iter.max = 20, nstart=20)

#getting information about clustering
print(iris2.kmeans)
print(iris2.kmeans$iter)
print(iris2.kmeans$centers)

#compare clusters with original class labels
table(iris$Species,iris2.kmeans$cluster)

#plot clusters
plot(iris2[,1:2], col = iris2.kmeans$cluster)
#add cluster centers
points(iris2.kmeans$centers[,1:2], col = 1:3, pch = 8, cex=2)

# Quality of the clustering

km<-kmeans(iris2,3)

#alternative execution of kmeans
km_alt<-eclust(iris2, "kmeans", k=3, graph=FALSE)
fviz_silhouette(km_alt, palette="jco")

# From the output, avg.silwidth represents the average silhouette width. A silhouette is a measurement
# that considers how closely related objects are within the cluster and how clusters are separated
# from each other. The silhouette value usually ranges from 0 to 1; a value closer to 1 suggests
# the data is better clustered.

silinfo<-km_alt$silinfo
names(silinfo)

#silhouette length for each observation
head(silinfo$widths[,1:3],10)
#silhouette length for each cluster
silinfo$clus.avg.widths
#average silhouette length
silinfo$avg.width

# Rand index
# The corrected Rand index provides a measure for assessing the similarity between
# two partitions, adjusted for chance. Its range is -1 (no agreement) to 1 (perfect agreement).
species <- as.numeric(iris$Species)
clust_stats<-cluster.stats(d=dist(iris2), species, km_alt$cluster)
clust_stats$corrected.rand

#### data scaling
?scale
irisScale <- scale(iris2, center = FALSE)
str(irisScale)
iris2.kmeansS = kmeans(irisScale,3, iter.max = 20)
str(iris2.kmeansS)
table(iris$Species,iris2.kmeansS$cluster)

plot(irisScale[,3:4], col = iris2.kmeansS$cluster)
#add cluster centers
points(iris2.kmeansS$centers[,3:4], col = 1:3, pch = 8, cex=2)

###############################################################
# finding the optimal number of groups with the "elbow" method
###############################################################

wss <- vector(mode = "integer" ,length = 15)

#  1 to 15 clusters
for (i in 1:15) {
  kmeans.group <- kmeans(irisScale, centers = i, nstart=20)
  # total within-cluster sum of squares
  wss[i] <- kmeans.group$tot.withinss
}

# total within-cluster sum of squares per number of groups
plot(1:15, wss, type = "b",
     xlab = "number of groups",
     ylab = "total within-cluster sum of squares")

####################################
# PAM - partitioning around medoids#
####################################

# deciding on the optimal number of clusters
fviz_nbclust(iris2, pam, method = "silhouette")+theme_classic()

# division into 2 clusters
pam.res <- pam(iris2, 2)

# clustering results together with information on objects being cluster centers
print(pam.res)

#adding information on cluster assignment
iris_clus<-cbind(iris2, pam.res$cluster)
head(iris_clus)

#cluster centers
print(pam.res$medoids)

#cluster assignment
pam.res$clustering

#clustering visualization
fviz_cluster(pam.res,
             palette = c("#00AFBB", "#FC4E07"), # color palette
             ellipse.type = "t", # ellipse of concentration
             repel = TRUE, # avoid overlapping (slows down)
             ggtheme = theme_light() #background color
)

#### hierarchical clustering
#sample data
idx <- sample(1:nrow(iris), 50)
irisSample <- iris[idx,1:4]

?hclust
#calculation of a distance matrix
?dist
distM = dist(irisSample)
distT = as.matrix(distM)

dim(distT)
distT[1:5,1:5]

#hierarchical clustering for different linkage methods
iris2.hc_complete <- hclust(distM, method="complete")
iris2.hc_single <- hclust(distM, method="single")
iris2.hc <- hclust(distM, method="average")
iris2.hc_centroid <- hclust(distM, method="centroid")

#dendrograms for different clustering
?plot
par(mfrow=c(2,2))
plot(iris2.hc, hang = -1, labels=iris$Species[idx])
rect.hclust(iris2.hc, k=3, border=2:4)

plot(iris2.hc_complete, hang = -1, labels=iris$Species[idx])
rect.hclust(iris2.hc_complete, k=3, border=2:4)

plot(iris2.hc_single, hang = -1, labels=iris$Species[idx])
rect.hclust(iris2.hc_single, k=3, border=2:4)

plot(iris2.hc_centroid, hang = -1, labels=iris$Species[idx])
rect.hclust(iris2.hc_centroid, k=3, border=2:4)
par(mfrow=c(1,1))

#generates clusters
?cutree
iris2.hc.groups <- cutree(iris2.hc, k=3)
iris2.hc.groups

#compare clusters with original class labels
table(iris$Species[idx], iris2.hc.groups)

##### dbscan algorithm ##########################

?dbscan

# MinPts parameter estimation
# The idea is to calculate the average of the distances of every point to its k nearest
# neighbors. The value of k will be specified by the user and corresponds to MinPts.
# Next, these k-distances are plotted in an ascending order. The aim is to determine
# the “knee”, which corresponds to the optimal eps parameter.
# A knee corresponds to a threshold where a sharp change occurs along the k-distance
# curve.

dbscan::kNNdistplot(iris2, k=5)
abline(h=0.5, lty="dashed")

# dbscan alg. execution

iris2.dbscan <- dbscan(iris2, eps=0.5, MinPts=5)

#compare clusters with original class labels
#cluster 0 means noise
table(iris$Species, iris2.dbscan$cluster)

iris2.dbscan <- dbscan(iris2, eps=0.4, MinPts=5)
table(iris$Species, iris2.dbscan$cluster)

# plot clusters
plot(iris2.dbscan, iris2)
plot(iris2.dbscan, iris2[c(1,4)])

############ Laboratory task ###################
#calculation of accuracy
accuracyCalc <- function(confTbl, startCol)
{
  corr = 0;
  for(i in startCol:ncol(confTbl))
  {
    corr = corr + max(confTbl[,i])
  }
  accuracy = corr/sum(confTbl)
  accuracy
}

#data set for the laboratory task
#http://archive.ics.uci.edu/ml/datasets/Cardiotocography

download.file('http://staff.ii.pw.edu.pl/~gprotazi/dydaktyka/dane/cardioto_noClass_corr.csv','cardioto_noClass_corr.csv')
ctg_noClass <- read.csv("cardioto_noClass_corr.csv",row.names = 1)

download.file('http://staff.ii.pw.edu.pl/~gprotazi/dydaktyka/dane/cardioto_all_corr.csv','cardioto_all_corr.csv')
ctg_all <- read.csv("cardioto_all_corr.csv",row.names = 1)

#example
card.kmeans = kmeans(ctg_noClass,10)
res3 = table(ctg_all$CLASS,card.kmeans$cluster )
res3
accuracyCalc(res3,1)

#wines
download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-red.csv', 'wine_red.csv');
download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-white.csv', 'wine_white.csv');
wineRed_ds = read.table("wine_red.csv", header = TRUE, sep=";", na.strings= "*")
wineRed_dsC <- wineRed_ds[,-12]

#example - wines
card.kmeans = kmeans(wineRed_dsC,6)
res3 = table(wineRed_ds$quality,card.kmeans$cluster )
res3
accuracyCalc(res3,1)


#' Iterator of numeric sequence with initial value and step size
#'
#' Constructs an iterator that generates a sequence of evenly spaced values
#' starting with \code{icount}. The step size is given by \code{step}. By
#' default, the sequence is neverending unless the optional \code{stop} is
#' provided.
#'
#' NOTE: Use a negative \code{step} size to generate decreasing sequences.
#'
#' Often used as an argument to \code{\link[itertools2]{imap}} to
#' generate consecutive data points.
#'
#' @export
#' @param start sequence's initial value
#' @param step sequence's step size
#' @param stop optional stopping point to sequence
#' @return sequence's iterator
#'
#' @examples
#' it <- icount()
#' iterators::nextElem(it)
#' iterators::nextElem(it)
#' iterators::nextElem(it)
#'
#' it2 <- icount(start=5.5, step=1.5)
#' iterators::nextElem(it2)
#' iterators::nextElem(it2)
#' iterators::nextElem(it2)
#'
#' it3 <- icount(start=1, stop=3)
#' iterators::nextElem(it3)
#' iterators::nextElem(it3)
#' iterators::nextElem(it3)
#'
icount <- function(start=0, step=1, stop=NULL) {
  start <- as.numeric(start)
  step <- as.numeric(step)

  if (length(start) != 1) {
    stop("'start' must be a numeric value of length 1")
  }
  if (length(step) != 1) {
    stop("'step' must be a numeric value of length 1")
  }

  if (!is.null(stop)) {
    stop <- as.numeric(stop)
    if (length(stop) != 1) {
      stop("'stop' must be a numeric value of length 1")
    }
  }

  current_val <- start - step
  nextElem <- function() {
    current_val <<- current_val + step

    if (!is.null(stop) && current_val > stop) {
      stop("StopIteration", call.=FALSE)
    }

    current_val
  }

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


# The algorithm is written in R. The lines starting with or followed by "#" are comments for functions, command lines, or delimiters of separate functions.
###### Load packages
###### Author: Qingyuan Yang and Marcus Bursik
###### License: GPL. Use at your own risk.
###### Requires: to run the examples, the appropriate CSV files are needed.
library(gstat)
library(sp)
library(rgdal)
library(RandomFields)
library(maptools)
library(raster)
library(deldir)
library(ggplot2)
library(segmented)
library(poweRlaw)
library(segmented)
library(geoR)
library(combinat)

###### Workflow #########################################################################################################################################
######(1) Calculate the distances, downwind distances of sample sites with respect to the input       <------ function "prep"				######
######    source vent location and wind direction.	 															######
######																								######
######(2) Apply segmented/simple linear regression to the datasets: the log-thickness is the linear   <------ function "sample.reg"			######
######    combination of distance and downwind distance plus a constant.													######
######																								######
######(3) Record the fitted values and residuals from the fitting in step (2)                         <------ implemented by command lines		######
######																								######
######(4) Form a grid for mapping of the trend and the final result		            		          <------ function "form.grid"			######
######																								######
######(5) Form the trend model 											                              <------ function "prep2" and "trendmodel"	######
######																								######
######(6) Form and fit the variogram function of the residuals recorded in step (3)	                  <------ function "var.read"			######
######																								######
######(7) Implemnt ordinary kriging using the residuals in step (3) and the variogram models          <------ function "prediction"			######
######    from step (6) to form the local thickness variation. We take the sum of 			                    							######
######    the trend model in step (5) and the local variation to form the final thickness distribution								######
######																								######
###### End of workflow ##################################################################################################################################

###### Functions ########################################################################################################################################
prep <- function(sv, td, ang){

### See step (1) in the workflow above
### Input variables: 									  ### Data type			  ### Column naes
###		sv: the source vent location							dataframe				"x" and "y"
###		td: the tephra thickness dataset						dataframe				"x", "y", "rz" (real thickness), "z"(log-transformed thickness)
###		ang: the inferred wind direction (from north clockwise)		a single value			     	   -

### Intermediate variables:
###		pts: the coordinates of sample sites
###		nr: the number of observations
###		sv.mtx: the matrix prepared for the computation of distance and downwind distance
###		disp.mtx: the unit vector pointing along the wind direction for the computation of downwind distance
###		dist, dd, cd: computed distances, downwind distances, and crosswind distances from the sample sites to
###		the source vent with the inferred wind direction

### Output:
###		The output is a dataframe that contains the original thickness dataset and the calculated distances, downwind
###		distances, and the crosswind distances of the sample sites.

### Method:
###		This function uses a simple dot product to calculate the downwind distance

	pts <- as.matrix(td[,c(1,2)])									### Extract the coordinates of sample sites
	sv <- as.matrix(sv)
	nr <- nrow(pts)

	sv.mtx <- matrix(ncol=2, nrow=nr)								### Repeated rows of the coordinates of the source vent
	sv.mtx[,1] <- rep(sv[1], nr)
	sv.mtx[,2] <- rep(sv[2], nr)

	disp.mtx <- c(sin(ang*pi/180),cos(ang*pi/180))						### Form the unit vector pointing to the wind direction

	pts.mtx <- pts-sv.mtx										### Calculate the distances, downwind distances, and crosswind distances
	pts.sq <- (pts.mtx)^2										### of the sample sites
	dist<- (pts.sq[,1]+pts.sq[,2])^0.5
	dd <- pts.mtx %*% disp.mtx
	cd <-(dist^2-dd^2)^0.5

	output <- as.data.frame(cbind(pts, dist, dd, cd, td[, c(3,4)]))			### Reorganize the data for output
	colnames(output) <- c("x", "y", "dist", "dd", "cd", "rz", "z")

	return(output)
}

###-----------------

prep2 <- function(sv, td, ang){

### This function is written for the computation of the trend model, which requires distances and
### downwind distances of all the cells within the region of interest. Therefore this function works
### exactly the same way as function "prep", except that the trend thicknesses of these cells are to
### be computed. This function is called in the function "trendmodel" for further calculation of trend thickness.

### Input variables: 									  ### Data type			  ### Column names
###		sv: the source vent location			     				dataframe				"x" and "y"
###		td: the coordinates of the cells of the grid				dataframe or matrix		does not matter, as they are transfered into matrix in this function
###		ang: the inferred wind direction (from north clockwise)		a single value			     -

### Output variables:
### 		The output is a dataframe that records the coordinates, distances, downwind distances, and crosswind distances
###		of the cells of the grid.

	pts <- as.matrix(td[,c(1,2)])
	sv <- as.matrix(sv)
	nr <- nrow(pts)

	sv.mtx <- matrix(ncol=2, nrow=nr)
	sv.mtx[,1] <- rep(sv[1], nr)
	sv.mtx[,2] <- rep(sv[2], nr)
	disp.mtx <- c(sin(ang*pi/180),cos(ang*pi/180))

	pts.mtx <- pts-sv.mtx
	pts.sq <- (pts.mtx)^2
	dist<- (pts.sq[,1]+pts.sq[,2])^0.5
	dd <- pts.mtx %*% disp.mtx
	cd <-(dist^2-dd^2)^0.5

	output <- as.data.frame(cbind(pts, dist, dd, cd))
	colnames(output) <- c("x", "y", "dist", "dd", "cd")

	return(output)
}

###-----------------

sample.reg <- function(td, segdist, segdd){

### See step (2) of the workflow above
### This function provides two alternative fitting schemes for the fitting of thickness with distance and downwind distance:
### 	(1) Use linear regression with the "segmented" fitting function to simulate
###	    the different decay rates of tephra thickness within and outside the plume corner.

###	(2) Use simple linear regression for the fitting.

###	This method will tend to use the segmented fitting option as it is better reconciled with the physics of tephra settling.
###   If error occurs, meaning that the data are inappropriate for option(1), a "tryCatch" function is set up to switch to
###	option(2).

###	Input variables:
###		td: the output from function "prep"
###		segdist: the inferred breakpoint for distance, this can be estimated by plotting the thickness against distance of the observations.
###		segdd: the inferred breakpoint for downwind distance.

### 	Intermediate functions:
###		segfit: segmented fitting function
###		simplefit: simple linear regression

### 	Output variables:
###		An object that can be regarded as the fitted model. It contains the fitted values, residuals and the
###		coefficients of the fitting. It can be used to predict the trend thickness for the grid and also store the residuals
###		for ordinary kriging.

###	*** NOTES ***
###		The segemented fitting runs iterative processes. Sometimes even with the same "segdist" and "segdd" inputs, it still
###		comes up with different breakpoints and consequently slightly different coefficients. Most of the time, such variation
###		in the models is negligible, but we still suggest users to be careful when dealing with the segmented fitting.
###		The goodness of fit can be examined by printing or plotting the residuals, which are stored in the output.
### 		If option (1) is being used, the output also contains the values of the breakpoints for the two variables.

	segfit <-function(segdist, segdd){															### Segmented fitting function
		reg.mod <- lm(z~ dist + dd,data=td)
			seg.lmmodel <- segmented(reg.mod, seg.Z = ~dist + dd, psi = list(dist = c(segdist), dd = c(segdd)))
      	return(seg.lmmodel)
	}

	simplefit <-function(){																	### Simple linear regression function
		reg.mod <- lm(z ~ dist + dd ,data=td)
      	return(reg.mod)
	}

	result = tryCatch(segfit(segdist, segdd),error=function(e){simplefit()})									### TryCatch structure to automatically switch to simple linear regression

  return(result)																			### when error occurs
  }

###-----------------

form.grid <- function(td, cellsize, displacement.coef, expanding.coef){
### See step (4) in the workflow above
### This function first finds the bounding box of the sample sites. It can be used as the extent of the grid.
### However, sometimes one needs a larger extent. To do that, "displacement.coef" and "expanding.coef" are set.
### "displacement.coef" determines if the lowerleft corner of the bounding box should be further shifted to
### the lower left. "expanding.coef" determines if the length and width of the bouding box should be expanded.
### These two values are all ratios. For example, for a 500*500 squared bounding box, if the 'displacement.coef"
### is set to be 1, then the lowerleft corner (if it was 0,0), will be moved to -500, -500. If the "expanding.coef"
### is set to be 2, then the size of the new bounding box will be 1000*1000.

### Input variables:
### td: the output from function "prep"
### cellsize: cellsize (a single value, as they are squared cells)
### displacement.coef: explained above (a single value)
### expanding.coef: explained above (a single value)

### Output variables:
### An empty grid

  td.sp <- SpatialPoints(cbind(td$x, td$y))
  bbox <- bbox(td.sp)
  cs <- c(cellsize, cellsize)
  cc <- as.numeric(ceiling(bbox[,1] + (cs / 2) - diff(t(bbox)) * displacement.coef))
  cd <- ceiling(diff(t(bbox)) / cs) * expanding.coef
  td.temp.grid <- GridTopology(cellcentre.offset = cc, cellsize = cs, cells.dim = cd)
  td.grid <- SpatialGrid(td.temp.grid)
  return(td.grid)
}

###-----------------

trendmodel <- function(td, sv, grid, ang, ftng.rslt){
### See step (5) in the workflow above
### This function calculates the distances, downwind distances of the cells of the grid, and makes the
### prediction of trend thickness using the model from function "sample.reg".

### Input variables:
###		td: the output from function "prep"
###		sv: the source vent coordinate
###		grid: the output from function "form.grid"
###		ang: the inferred wind direction (from north clockwise)
###		ftng.rslt: the output from function "sample.reg"

### Output variables:
### A dataframe that contains the coordinates, distances, downwind and crosswind distances, trend thicknesses and
### trend thicknesses in logarithm form for all the cells within the grid.

	td.grid <- SpatialPoints(as(grid, "SpatialPixels"))
	td.grid.coord <- coordinates(td.grid)

		grided<- prep2(sv, td.grid.coord, ang)

		gridz <- predict(ftng.rslt, data.frame(cbind(dist = grided$dist, dd = grided$dd)))
		gridrz <- 10^gridz

	output <- as.data.frame(cbind(grided, gridrz, gridz))
	colnames(output) <- c("x", "y", "dist", "dd", "cd", "zr", "z")

	return(output)
}

###-----------------

var.read <- function(td, width.val, cutoff.val, var.par, var.model){
### This function reads the locations of the sample sites and the residuals from the fitting in function "sample.reg" to
### form and fit a variogram model. This function serves as a preparation for ordinary kriging.

### Input variables:
###		td: the output from function "prep"
###		width.val & cutoff.val: the parameters to calculate the experimental variogram. "width.val" denotes the
###		averaged lag for the computation, and "cutoff.val" is the maximum lag that is taken into consideration for the
###		calculation.
###		var.par: the parameters required for fitting variogram models. It includes three values, namely sill, range, and nugget.
###		Detailed explanations of these parameters can be found in any geostatistics reference.
###		var.model: a text variable which describes the shape of different variogram models, type the command line "show.vgms()" to view a list
###		of variogram models.

### Output variables:
###		The output is a list, the first object of the list is the variogram model, which is the main output.
###		The second object is the plot of the experimental variogram and the fitted variogram curve.
###		The third  object is the values of the experimental variogram

  td.sp <- SpatialPointsDataFrame(cbind(td$x, td$y), td)
  td.var <- variogram(res ~ 1, td.sp, width=width.val, cutoff = cutoff.val)

  td.vgm <- vgm(psill=var.par[1], model=var.model, range=var.par[2], nugget=var.par[3])
  td.fit <- fit.variogram(td.var, td.vgm, fit.sills = c(TRUE, TRUE))
  return(list(td.fit,plot(td.var,td.fit),td.var))
}

###-----------------

prediction <- function(td, max, min, maxdist, grid, trend, variog){
### This function first implements ordinary kriging on the residuals to construct the local variation map, and then
### takes the sum of trend and local variation to present the final result.

### Input variables:
###		td: the output from function "prep"
###		max:
###		min:
###		maxdist:
###			The "max" and "min" variables describe the maximum and minimum number of observations taken into account
###			for the kriging estimation at a single cell. "maxdist" is used to define a maximum radius beyond which the
###			sample sites are assumed non-related to a particular cell.
###		grid: the output from function "form.grid"
###		trend: the output from function "trendmodel"
###		variog: the first object of the output from function "var.read"

### Output variables:
###		The output is a dataframe that contains the columns of the output of function "trendmodel". In addition to that,
###		it also has the predicted thickness and its logarithm, and the variance of kriging estimation.
###		Here the variance only represents the variance from kriging the log-residuals of the observations and thus cannot
###		be used to characterize the total variance of this method.

	td.sp <- SpatialPointsDataFrame(cbind(td$x, td$y), td)
	td.temp.k <- krige(res ~ 1, td.sp, nmax = max, nmin = min, maxdist = maxdist, grid, variog)
	k.result <- td.temp.k$var1.pred
	k.result[is.na(k.result)] <- 0
	k.variance <- td.temp.k$var1.var
	k.rz <- 10^(k.result + trend$z)

	output <- cbind(trend, k.result, k.variance, k.rz)

return(output)
}

###### End of functions ####################################################################################################

###### Demo ################################################################################################################

setwd("C:\\Users\\working directory")										### Set working directory, "\" has to be replaced by "\\".  Change to "/" for *nix, mac.
td <- read.table("thickness dataset.csv", header=TRUE, sep=",")						### Read the thickness dataset
sv <- read.table("source vent.csv", header=TRUE, sep=",")							### Read source vent location

td <- prep(sv, td, 20)													### Calculate the distances, downwind distances, and crosswind distances of the sample sites,
																### here the wind direction is 20 degree from north clockwise.

model <- sample.reg(td, 3000,3000)											### Form either the segmented or the simple linear regression model of thickness against
																### distance and downwind distance. The breakpoints for the two variables are set as
																### 3000 and 3000 meters.

td$fit <- model$fitted.values												### Expand "td" by storing the fitted values and
td$res <- model$residuals												### residuals from the fitting in the last command line

grid <- form.grid(td, 500, 0.1, 1.2)											### Form the grid.

trend <- trendmodel(td, sv, grid, 20, model)									### Form the trend. Note the wind direction has to be set again for
																### the calculation of grid cells, and the two wind directions have to be the same.

var <- var.read(td, 300,10000, c(0.04,5000,0.01), "Cir")							### Form the variogram model. The parameters are explained in the
																### description of function "var.read"

result <- prediction(td, 50,20, 5000, grid,trend, var[[1]])							### Calculate the local variation, and take its sum and trend thickness for final result.

result.sp <- SpatialPixelsDataFrame(cbind(trend$x, trend$y), result)					### Turn the final result into "SpatialPixelsDataFrame" for visualization.
spplot(result.sp["k.rz"])	or	spplot(result.sp["zr"])							### Plot the final result or the trend model.

levels <- c(0,250,500,1000,2000,3000,5000,10000,20000)								### Set up the levels for plotting the isopach map.
isomap <- ContourLines2SLDF(contourLines(as.image.SpatialGridDataFrame(result.sp["k.rz"]), levels = levels))
																### Form the isopach map

plot(isomap)															### Plot the isopach map
																### Note: "isomap" is a "SpatialLinesDataFrame" and can be used in GIS programs for further mapping purposes.
																### Geo-referencing can be done in R or GIS programs.

																### ***Notes on infer the extent of tephra fall deposits:
																### (1) Add one unit thickness to all the observations and log-transform them.
																### (2) Apply these transformed log-thickness to the method
																### (3) Specify the "levels <- c(1)" and apply it to "ContourLines2SLDF" function to find the unit thickness isopach
																### (4) The resultant contour is the inferred extent.
																### ***
																### The resultant contour is strongly influenced by the trend model,
																### as normally fewer observations are made on the distal and thin parts of a tephra fall deposit

###### End of demo ##########################################################################################################


# Selection of matrix elements
# my_matrix[1,2]: selects the element at the first row and second column.
# my_matrix[1:3,2:4]: results in a matrix with the data on the rows 1, 2, 3 and columns 2, 3, 4.
# my_matrix[,1]: selects all elements of the first column.
# my_matrix[1,]: selects all elements of the first row.

# all_wars_matrix is available in your workspace
all_wars_matrix

# Select the non-US revenue for all movies
non_us_all <- all_wars_matrix[,2]

# Average non-US revenue
mean(non_us_all)

# Select the non-US revenue for first two movies
non_us_some <- all_wars_matrix[1:2, 2]

# Average non-US revenue for first two movies
mean(non_us_some)


x_values <- c(9,11,15)

y_values <- c(-15,-8,2,8)

prxs <- c(0.38, 0.29, 0.33)

prys <- c()

prCongiunta <- c()

pry_x <- c(0.25, 0.30, 0.20, 0.25,
           0.22, 0.27, 0.25, 0.26,
           0.20, 0.30, 0.23, 0.27)

matrixy_x <- matrix(data = pry_x, ncol = length(y_values), nrow = length(x_values), byrow = TRUE);

valoreAttesoX <- 0

for( i in 1:length(x_values) ){

  valoreAttesoX <- valoreAttesoX + prxs[i] * x_values[i];

}

varianzaX <- 0

for( i in 1:length(x_values) ){

  varianzaX <- varianzaX + prxs[i] * (x_values[i] - valoreAttesoX)^2;

}

for( i in 1:length(x_values) ){

  for( j in 1:length(y_values) ){

    prCongiunta <- c(prCongiunta, matrixy_x[i,j] * prxs[i]);

  }

}

matrixCongiunta <- matrix(data = prCongiunta, nrow = length(x_values), ncol = length(y_values), byrow = TRUE);

for( i in 1:length(y_values) ){

  prys <- c(prys, sum(matrixCongiunta[,i]));

}

prx_y <- c()

for( i in 1:length(x_values)){

  for( j in 1:length(y_values)){
    prx_y <- c(prx_y, matrixCongiunta[i,j] / prys[j] )
  }

}

matrixx_y <- matrix(data=prx_y, nrow = length(x_values), ncol = length(y_values), byrow = TRUE);

valoreAttesoX_Y <- c();

for( j in 1:length(y_values) ){

  somma <- 0
  for( i in 1:length(x_values) ){

    somma <- somma + x_values[i] * matrixx_y[i,j];

  }

  valoreAttesoX_Y <- c(valoreAttesoX_Y, somma);

}

varianzaValoreAttesoX_Y <- 0

for( j in 1:length(y_values) ){

  varianzaValoreAttesoX_Y <- varianzaValoreAttesoX_Y + (valoreAttesoX_Y[j] - valoreAttesoX)^2 * prys[j];

}

valoreAttesoVarianzaX_Y <- varianzaX - varianzaValoreAttesoX_Y;

cat("X\n")
print(matrix(data=c(x_values,prxs), ncol = length(x_values), byrow = TRUE))

cat("\nY\n")
print(matrix(data=c(y_values,prys), ncol = length(y_values), byrow = TRUE))

cat("\nProbabilita congiunta\n")
print(matrixCongiunta)

cat("\nX|Y\n")
print(matrixx_y)

cat("\nY|x\n")
print(matrixy_x)

cat("\nRisposte\n")
print(valoreAttesoX);
print(varianzaX)
print(varianzaValoreAttesoX_Y)
print(valoreAttesoVarianzaX_Y)


=begin
  # sample-m-factorize02.rb

  require "algebra"

  Z7 = ResidueClassRing(Integer, 7)
  P = MPolynomial(Z7)
  x, y, z = P.vars("xyz")
  f = x**3 + y**3 + z**3 - 3*x*y*z
  p f.factorize #=> (x + 4y + 2z)(x + 2y + 4z)(x + y + z)
((<_|CONTENTS>))
=end


# MULTIPLY transaction rates in a given cycle to obtain possible profit
bf.mult <- function(edges, rates, cycle) {

    profit = 1

    # find and multiply by pairs
    for (i in 1:(NROW(cycle)-1)) {
        next_value = rates[which(edges[,1]==cycle[i] & edges[,2]==cycle[i+1])]
        profit = profit * as.numeric(next_value)
    }

    # as number
    return(profit)
}

# RETRIEVE a path given a predecessor array and a source/target pair of nodes
bf.path <- function(nodes, prevs, terminal) {

    path = as.matrix(c(terminal))
    prev = nodes[prevs[which(nodes==terminal)]]

    # track util repeated element
    while (sum(path==prev) == 0) {
        path = rbind(path, prev)
        prev = nodes[prevs[which(nodes==prev)]]
    }

    # add repeated element
    path = rbind(path, prev)

    # trim the fat
    trim.bound = which(path==prev)[1]
    path = path[trim.bound:NROW(path)]
    path = as.matrix(rev(path))

    # as matrix
    return(path)
}

# APPLY classic Bellman-Ford Algorithm
bf.find <- function(graph, summary, debug=T) {

    # receive an EDGE LIST with the following format:
    #
    #        [,1]    [,2]    [,3]
    # [1,]  node 1  node 2  weight
    # [1,]  node 1  node 3  weight
    # [1,]  node 2  node 1  weight
    #   .     .       .       .
    #   .     .       .       .
    #   .     .       .       .

    # ready data
    edges = as.matrix(graph)
    nodes = unique(matrix(edges[,1:2], ncol=1))
    weights = as.numeric(as.character(edges[,3]))

    # ready state
    dists = rep(Inf, NROW(nodes))
    prevs = rep(NULL, NROW(nodes))

    # distance from source is zero
    # source is always the artificial node
    dists[1] = 0

    if (debug) {
        cat("Applying Bellman-Ford algorithm\n")
    }

    for (i in 1:(NROW(nodes)-1)) { # this can STILL stop earlier

        if (debug) {
            cat("  exploring paths with", i, "steps away from source\n")
        }

        for (j in 1:NROW(edges)) {
            if (dists[which(nodes==edges[j,1])] + weights[j] < dists[which(nodes==edges[j,2])]) {
                dists[which(nodes==edges[j,2])] = dists[which(nodes==edges[j,1])] + weights[j]
                prevs[which(nodes==edges[j,2])] = which(nodes==edges[j,1])
            }
        }
    }

    # test for negative cycles
    cycle = NULL
    for (i in 1:NROW(edges)) {

        # a path with NROW(nodes) steps can only occur via a negative cycle
        if (dists[which(nodes==edges[i,1])] + weights[i] < dists[which(nodes==edges[i,2])]) {
            cycle = bf.path(nodes, prevs, edges[i,1])

            if (debug) {
                cat("Arbitrage cycle found!\n")
                print(cycle)
            }

            break
        }
    }

    # then find possible profit
    profit = NULL
    if (NROW(cycle) > 0) {
        rates = as.numeric(as.character(summary[,3]))
        profit = bf.mult(edges, rates, cycle)

        if (debug) {
            cat("Possible profit:", profit, "\n")
        }
    } else {

        if (debug) {
            cat("No negative cycles found :(\n")
        }
    }

    ret = list()
    ret$nodes = nodes
    ret$cycle = cycle
    ret$profit = profit

    return(ret)
}

# APPLY Bellman-Ford SPFA variation algorithm
bf.spfa <- function(graph, summary, SLF=F, debug=T) {

    # This implementation improves upon the traditional Bellman-Ford algorithm:
    #  - Nodes are only explored if edges connecting to it could be relaxed in
    #    the previous step, severely improving average case runs
    #  - Small Label First induces exploration of closer nodes first, improving
    #    further even the average case performance

    # ready data
    edges = as.matrix(graph)
    nodes = unique(matrix(edges[,1:2], ncol=1))
    weights = as.numeric(as.character(edges[,3]))

    # ready state
    dists = rep(Inf, NROW(nodes))
    prevs = rep(NULL, NROW(nodes))

    # worst case iter count
    max_iters = NROW(nodes) - 1

    # distance from source is zero
    # source is always the artificial node
    dists[1] = 0

    # Q behaves as a FIFO queue
    # ...also, add source to it
    Q = c(1)

    if (debug) {
        cat("Applying Bellman-Ford SPFA variation\n")
    }

    while (NROW(Q) > 0) {
        # get front
        node = Q[1]
        Q = Q[-which(Q==node)]

        if (debug) {
            cat("  currently exploring node", node, "\n")
        }

        # neighbor node edge ids
        edge.ids = which(edges[,1]==nodes[node])

        for (i in 1:NROW(edge.ids)) {

            # distance inbetween
            distance = weights[edge.ids[i]]

            # neighbor node number
            neighbor = which(nodes==edges[edge.ids[i], 2])

            if (dists[node] + distance < dists[neighbor]) {
                dists[neighbor] = dists[node] + distance
                prevs[neighbor] = node

                # add to queue (only once)
                if (sum(Q==neighbor) == 0) {
                    Q = c(Q, neighbor)

                    # >>> Optimization: SLF <<<
                    if ((SLF) & (dists[neighbor] < dists[Q[1]])) {
                        Q = c(neighbor, Q[1:(NROW(Q)-1)])
                    }
                }
            }
        }

        # necessary for worst case
        max_iters = max_iters - 1
        if (max_iters == 0) {
            break
        }
    }

    # find negative cycle
    cycle = NULL
    profit = NULL
    for (i in 1:NROW(edges)) {

        u = which(nodes==edges[i, 1]) # node
        v = which(nodes==edges[i, 2]) # neighbor

        # only possible in the presence of negatie cycles
        if (dists[u] + weights[i] < dists[v]) {

            # cycle path
            cycle = bf.path(nodes, prevs, edges[i,1])

            # cycle mult
            rates = as.numeric(as.character(summary[,3]))
            profit = bf.mult(edges, rates, cycle)

            if (debug) {
                cat("Arbitrage cycle found!\n")
                print(cycle)
                cat("Possible profit:", profit, "\n")
            }

            break
        }
    }

    # case of "failure"
    if (NROW(cycle) == 0) {
        if (debug) {
            cat("No negative cycles found :(\n")
        }
    }

    ret = list()
    ret$nodes = nodes
    ret$cycle = cycle
    ret$profit = profit

    return(ret)
}


# vector c attached to each node in the modwpt transform (Percival and Walden, page 215)
# vector c will be used to align LA wavelet coefficients
getC=function(j,n)
{
  vectorC=c();
  if (j==1)
  {
    if (n==0) vectorC=0
    else vectorC=1
    return(vectorC)

  }
  else
  {
    if (((n%%4)==0)||((n%%4)==3))
      return(c(getC(j-1,floor(n/2)),0))
    else
      return(c(getC(j-1,floor(n/2)),1))
  }

}

# Auxiliary function used to calculate time shifts for wavelets(Percival and walden,229-230)
# This function will return c(Sjn0,Sjn1)
getSc=function(j,n)
{
  vectorC=getC(j,n)
  Sjn1=(sum(vectorC*2^(0:(j-1))))
  Sjn0=2^j-1-Sjn1
  return (c(Sjn0,Sjn1))

}
# Auxiliary function used to calculate time shifts for LA wavelets(Percival and walden,229-230)
getLj=function(j,wf)
{
  #length of the wave filter
  L=length(wave.filter(wf)$lpf)
  Lj=(2^j-1)*(L-1)+1
  return(Lj)
}

#getVjnLA returns time shifts for la8,la16 and la20 wavelets in modwpt
getVjnLA=function(j,n,wf)
{
  aux=getSc(j,n);
  Sjn1=aux[2];
  return(abs(-getLj(j,wf)/2+(2^(j-1)-Sjn1)))
}

#performs left circular shift
circularShift=function(x,n)
{
  l=length(x)
  if ((n==0)||(n==l)) return(x)
  if ((n<0)||(n>l)) {n=n%%l}
  return(c(x[(n+1):l],x[1:n]))
}
# aligns <<x>> wavelet coefficients from modwpt using <<wf>> wavelet. <<x>> are the
# (j.n) node wavelet coefficients. <<wf>> should be "l8","l16" or "l20". If not, not
# alignment is perform
align=function(x,j,n,wf)
{
  #return(x)
  if ((wf!="la8")&&(wf!="la16")&&(wf!="la20"))
  {
    #general method
    return(circularShift(x,CenterOfEnergyAdvances(j,n,wf)))
  }
  else
  { #specific method for LA wavelets
    return(circularShift(x,getVjnLA(j,n,wf)))
  }
}

#shift applicable to (almost) every filter using the notion of the 'center of
#energy' by Hess-Nielsen and Wickerhauser.
# Walden page 231

# gets the appropiate advance for the (j.n) node of the <<wf>> wavelet.
CenterOfEnergyAdvances=function(j,n,wf)
{
  #variables for the computation
  S=getSc(j,n)
  E=CenterEnergies(wf)
  advance=round(  S[1]*E[1]+S[2]*E[2]  )

  return (advance)
}

# gets the center of energy for both wf filters
CenterEnergies=function(wf)
{
  waveletFilter=wave.filter(wf)
  #Center ofEnergy of the scaling filter
  cesf=computeCenterEnergy(waveletFilter$length,waveletFilter$lpf);
  #Center ofEnergy of the wavelet filter
  cewf=computeCenterEnergy(waveletFilter$length,waveletFilter$hpf);
  return (c(cesf,cewf))

}

#auxiliar function: gets the center of energy of coefs. length(coefs)=l
computeCenterEnergy=function(l,coefs){
  auxVector=0:(l-1)
  coefs2=(coefs)^2
  a=coefs2%*%auxVector
  b=sum(coefs2)
  return (a/b)
}


svdopt <- function(R, k, lr = 0.05, reg = 0.002, miter = 10) {
	global_mean <- mean(as.matrix(R[,3]), na.rm = TRUE)
	bu <- rep(0, max(R[,1]))
	bi <- rep(0, max(R[,2]))
	nusers <- max(R[,1])
	nitems <- max(R[,2])
	P <- matrix(rnorm(nusers*k, mean=0, sd=0.1), nusers, k)
	Q <- matrix(rnorm(nitems*k, mean=0, sd=0.1), nitems, k)
	error <- list()

	for(l in 1:miter) {
		sq_error <- 0
		for(j in 1:nrow(R)) {
			u <- R[j,1]
			i <- R[j,2]
			r_ui <- R[j,3]
			pred <- global_mean + bu[u] + bi[i] + P[u, ] %*% Q[i,]
			e_ui <- r_ui - pred
			sq_error <- sq_error + e_ui^2
			bu[u] <- bu[u] + lr * e_ui
			bi[i] <- bi[i] + lr * e_ui
			for(f in 1:k) {
				temp_uf <- P[u,f]
         		P[u,f] <- P[u,f] + lr * (e_ui * Q[i,f] - reg * P[u,f])
			    Q[i,f] <- Q[i,f] + lr * (e_ui * temp_uf - reg * Q[i,f])
			}
		}
		error <- c(error, sqrt(sq_error/nrow(R)))
	}

	return(list(bu = bu, bi = bi, P = P, Q = Q, error = error))
}


pravd.f = function(x,p){
    plot(x, p, # plna kolecka - v skutecnych hodnotach
        ylab='p(x)',xaxt='n',pch=19,ylim=c(0,max(p)),main="Pravdepodobnostni funkce")
    lines(c(min(x)-100,max(x)+100),c(0, 0))
    for(i in 1:length(x)){
        lines(c(min(x)-100,max(x)+100), c(p[i],p[i]),
              type = 'l', lty = 3, lwd=0.5) # horizontalni grid
        lines(c(x[i],x[i]), c(-0.1,1.1),
              type = 'l', lty = 3, lwd=0.5) # vertikalni grid
    }
    par(new=TRUE) # ze chceme kreslit do jednoho grafu
    plot(x, p*0, # prazdna kolecka - tam kde je definovana nenulova hodnota
        ylab='p(x)', xaxt='n', ylim=c(0,max(p)))
    axis(1, at=x,labels=x) # nastaveni hodnot na X
    axis(4, at=p,labels=p, las=2, cex.axis=0.7, tck=-.01) # a Y
}

dist.f = function(x,p){
    F = cumsum(p)
    F_ext = c(0, F) # natahneme F o 0 na zacatku
    x_ext = c(x[1]-1, x, x[length(x)]+1) # a x z obou stran

    plot(x, F, ylab="F(x)", xaxt='n', ylim=c(0,1), # prazdna kolecka
         type='p', main="Distribucni funkce")
    par(new=TRUE) # ze chceme kreslit do jednoho grafu
    plot(x, F_ext[1:(length(F_ext)-1)], # plna kolecka
         ylab="F(x)", xaxt='n', ylim=c(0,1), type='p', pch=19)

    for(i in 1:(length(x_ext)-1)){
        lines(c(min(x)-100,max(x)+100), c(F_ext[i],F_ext[i]),
              type = 'l', lty = 3, lwd=0.5) # horizontalni grid
        lines(c(x_ext[i],x_ext[i]), c(-0.1,1.1),
              type = 'l', lty = 3, lwd=0.5) # vertikalni grid
        lines(x_ext[i:(i+1)], c(F_ext[i],F_ext[i])) # graf - cary
    }
    axis(1, at=x,labels=x) # nastaveni hodnot na X
    axis(4, at=F,labels=F, las=2, cex.axis=0.7, tck=-.01) # a Y
    #return(F)
}

souhrn=function(x,p){
  EX = sum(x*p)
  EX2 = sum(x*x*p)
  DX = EX2-EX^2
  sigma.X = sqrt(DX)
  modus = x[match(max(p),p)]
  # zapis vysledku do tabulky
  tab = rbind(EX, DX, sigma.X, modus)
  tab.popis = c("str. hodnota","rozptyl","smer. odchylka", "modus")
  rownames(tab) = tab.popis
  colnames(tab) = ""
  return(tab)
}

# 1A
# Pouzijeme Hypergeometrickou vetu, kde vybirame pocet uspechu v n zavislych pokusech
# X ... pocet projektu bez chyb mezi 4 vybranymi
# X ~ H(N = 9, M = 6, n = 4)

x = 0:4 #pocet projektu, ktere nas zajimaji
N = 9 #celkem 9 projektu
M = 6 #celkovy pocet projektu, ktere nas zajimaji
n = 4 #pocet projektu ve vyberu

# graf pravdepodobnostni funkce pro P(X = 0 az 4)
p = dhyper(x, M, N - M, n) # hodnoty pravdepodobnostni funkce pro x
#kontrola - melo by dat 1
#sum(p) == 1
#plot(x, p)

#jednotlive pravdepodobnosti p priradime k odpovidajicim hodnotam vytyhnutemu poctu spravnych projektu
pravdep = rbind(c("P(xi)",p))
colnames(pravdep) = c("xi",0:4)
rownames(pravdep) = ""
pravdep #tabulka pravdepodobnostni funkce
pravd.f(x, p) #vykresleni

#pravdepodobnosti prubezne scitame a priradime k nim omezeni
distrib = cbind(cumsum(p),c("x<=0","0<x<=1","0<x<=1","1<x<=2","x>3"))
colnames(distrib) = c("","")
rownames(distrib) = c("","","F(x) = ","","")
distrib #predpis distribucni funkce
dist.f(x,p) #vykresleni

# 1B
# stredni hodnota je soucet vsech hodnot vynasobenych jejich pravdepodobnosti
# rozptyl pomoci E(x^2) - E(x)^2
# smerodatna odchylka je odmocnina rozptylu
# modus je hodnota nejvetsi pravdepodobnosti
# vypocet modus by bylo treba nahradit y[matchAll(max(p),p)] misto y[match(max(p),p)],
# ale chtel jsem to mit spustitelne bez knihoven (matchAll je asi v knihovne tuple?)
souhrn(x,p)

# 1C
# vybirame alespon jeden spatny projekt, takze 1 nebo 2 nebo 3 spravne (4 spatne neexistuji)
# P(x<=3)
sum(p[1:4])

# 1D
(4 - sum(x*p)) * 200000 # celkem 4 projekty a odecteme sanci na vytazeni spravnych projektu

# 1E
# vetsi nez 250 tisic bude v pripade, ze vybereme alespon dva spatne projekty
# P(x<3)
sum(p[1:3])

# 2A
# definujeme distribucni funkci
F = c(0, 0.3, 0.5, 0.9, 1)
y = c(1,10,100,1000)

# z distribucni funkce zjistime pravdepodobnosti pro omezeni
p = diff(F)
pravd.f(y, p) #vykreslime pravdepodobnosti funkci
dist.f(y, p) #vykreslime distribucni funkci

# 2B
# P(Y=100)
p[match(100,y)] #dohledame hodnotu pro 100
# P(Y >= 10)
1-F[match(10,y)] #hledame vetsi nez, takze musime odecist pravdepodobnost 10 od jednicky
p[match(10,y)] + p[match(100,y)] + p[match(1000,y)] # nebo by jsme mohli secist zmeny vetsich nez

# 2C
souhrn(y, p) # podobne jako 1B

# 2D
R = log10(y) # prepocteme si omezeni podle logaritmu

# mohlo by dojit k nesetrizenym omezenim, takze je treba setridit
idx_sorted = order(R)
R = R[idx_sorted]
p_R = p[idx_sorted]

souhrn(R, p_R)

# 3A
# integral od -2/3 do 0 pro f(x)dx = 1 kde f(x) = c(6x+8)
# c(3*x^2+8*x) => c(0*0)-c(3*(-2/3)^2+8*(-2/3)) => c(0) - c(-4) => c*4 dame rovno jedne => c = 0.25
f = function(x){return(6*x+8)} # f(x) = 6x+8
dolniMez = -2/3
horniMez = 0
1/integrate(f, dolniMez, horniMez)$value

# kdybych pocital rucne, tak si vyberu dva krajni body -2/3 a 0 a vypocitam jejich hodnoty
# jelikoz jde o primku tak tyto dva body bych spojil a dal do uzavreneho intervalu
# zbytek grafu hustoty bude na nule do nekonecen s otevrenymi intervaly

f.dens = function(x){
    res = 6/4*x+2 # 1/4(6*x+8)
    res[x < -2/3] = 0
    res[x > 0] = 0
    return(res)
}

x = seq(from = -1, to = 0.5, by = 0.01)
FX = f.dens(x)
plot(x, FX, cex = 0.2, main="Graf hustoty")

# 3B
# integral od -2/3 do 0 pro F(t) = f(x)dx
#       0                   t < -2/3
# F(t)  6/8*t^2 + 2*t + 1   t <-2/3;0>
#       1                   t > 0
# pocitam integral od -2/3 do t, kde t je mensi nez 0, pro f(x)dx
# 6/4*x+2
# 6/8*x^2+2*x
# 6/8*t^2+2*t - (6/8*(-2/3)^2+2*(-2/3)) => 6/8*t^2 + 2*t + 1 => dosadim do F(t)

F.dist = function(x){
    res = 6/8*x^2 + 2*x + 1
    res[x < -2/3] = 0
    res[x > 0] = 1
    return(res)
}

x = seq(from = -1, to = 0.5, by = 0.01)
FX = F.dist(x)
plot(x, FX, type = 'l', main="Distribucni funkce")

# 3C
# vypocet se provadi integraci hustoty pravdepodobnosti v limitach danych zadanim pripadne oseknutou limitami hustoty
# integrace provedena v 3B, pouze dosazujeme (6/8*(-1/3)^2 + 2*(-1/3) + 1) - (6/8*(-2/3)^2 + 2*(-2/3) + 1)
# P(-1 <= X <= -1/3)
integrate(f.dens, -2/3, -1/3)$value

# P(X > -1/3)
# integrace provedena v 3B, pouze dosazujeme (6/8*(0)^2 + 2*(0) + 1) - (6/8*(-1/3)^2 + 2*(-1/3) + 1)
integrate(f.dens, -1/3, 0)$value

# 3D
x_fx = function(x){
    fx = f.dens(x)
    return(x*fx)
}
xx_fx = function(x){
    fx = f.dens(x)
    return(x*x*fx)
}

# pouzijeme vzorce E(x) = integral x*f(x)dx na celem nenulovem intervalu
# E(x^2) = integral x^2*f(x)dx, pro D(x) = E(x^2) - E(x)^2
E_X = integrate(x_fx, -2/3, 0)$value
E_XX = integrate(xx_fx, -2/3, 0)$value

D_X = E_XX - E_X^2
std_X = sqrt(D_X)

cbind(c("E(X)","D(X)","sigma x"),c(E_X,D_X,std_X))

# 3E
# pro Y = 4-2x vyuzijeme vzorecku
# E(aX + b) = a*E(x)+b
# D(aX + b) = a^2*D(x)
# a hodnot, ktere jsme vypocitali v 3D
E_Y = 4 - 2*E_X # E(4-2x)
D_Y = (-2)^2*D_X # D(4-2x)
std_Y = sqrt(D_Y)

cbind(c("E(Y)","D(Y)","sigma y"),c(E_Y,D_Y,std_Y))

# 4A
# hustota se pocita derivaci distribucni funkce
# zderivujeme sin x => cos x
# f(x)  cos x <0,pi/2>
#       0 (-inf,0) nebo (pi/2,inf)
f = function(x){
    res = cos(x)     # x^2+2x+1
    res[x < 0] = 0 # 0 pro x<=0
    res[x > pi/2] = 0  # 1 pro x>1
    return(res)
}

x = seq(from = -0.5, to = 2, by = 0.01)
FX = f(x)
plot(x, FX, cex = 0.2, main="Graf hustoty")

# 4B
# median nalezi do <0,pi/2> a pocita se z distribucni funkce
F.dist = function(x){
    res = sin(x)     # x^2+2x+1
    res[x <= 0] = 0 # 0 pro x<=0
    res[x > pi/2] = 1  # 1 pro x>1
    return(res)
}

x = seq(from = -0.5, to = 2, by = 0.001)
FX = F.dist(x)
plot(x, FX, type='l', main="Pravdepodobnostni funkce a median")
lines(c(-0.5, 2),c(0.5, 0.5))

asin(0.5)
x[FX >= 0.5][1]

# 4C
# podobne jako median spocitame i pravdepodobnost 60%, akorat musime pocitat s 1-0.6
x = seq(from = -0.5, to = 2, by = 0.001)
FX = F.dist(x)
plot(x, FX, type='l', main="Pravdepodobnostni funkce a pravdepodobnost 60%")
lines(c(-0.5, 2),c(0.4, 0.4))

asin(0.4)
x[FX >= 0.4][1]

#BONUS
F = c(0, 0.1, 0.3, 0.6, 1)
y = c(0,1,2,3)

# z distribucni funkce zjistime pravdepodobnosti pro omezeni
p = diff(F)
pravd.f(y, p) #vykreslime pravdepodobnosti funkci
dist.f(y, p) #vykreslime distribucni funkci

# 2B
# P(Y=100)
p[match(2,y)] #dohledame hodnotu pro 100
# P(Y >= 10)
1-F[match(1,y)] #hledame vetsi nez, takze musime odecist pravdepodobnost 10 od jednicky

# 2A
F = c(0, 0.2, 0.4, 0.7, 1)
y = c(0,1,2,3)

p = diff(F)
pravd.f(y, p)
dist.f(y, p)

# 2B
p[match(2,y)]
1-p[match(1,y)]

# 2C
souhrn(y, p)

# 2D
R =  y-y^2
idx_sorted = order(R)
R = R[idx_sorted]
p_R = p[idx_sorted]

#souhrn(R, p_R)
EX = sum(R*p_R)
EX
DX = sum(R*R*p_R)-EX^2
DX
sigma = sqrt(DX)
sigma

#A
#c(4x-3/2x^2)
f = function(x){return(4-3*x)}
a = 0
b = 2/3
1/integrate(f, a, b)$value # obsah pod primkou je 1 a pocitame kolik je c

#vyberu si dva body v intervalu abych vedel kde jde primka hustoty
#2-3/2*0
#2-(3/2)*(2/3)

f.dens = function(x){
    res = 2 - 3/2*x
    res[x < 0] = 0
    res[x > 2/3] = 0
    return(res)
}

x = seq(from = -0.5, to = 1, by = 0.01)
FX = f.dens(x)
plot(x, FX, cex=0.2, main="Hustota")

#B
#2-3/2*x #udelam integral od 0 do 2/3 s tckama - 3 hodnoty 0, x, 1
#       0               t < 0
# F(t)  2*t - 3/4*t^2   t <0;2/3>
#       1               t > 2/3
#2 - 3/2*x
#2x - 3/4*x^2
#2t - 3/4*t^2 - (0) => dosadim do F(t)

F.dist = function(x){
    res = 2*x - 3/4*x^2     # x^2
    res[x<=0] = 0 # 0 pro x<=0
    res[x>2/3] = 1  # 1 pro x>1
    return(res)
}

x = seq(from = -0.5, to = 1, by = 0.01)
FX = F.dist(x)
plot(x, FX, type = 'l', main="Distribucni funkce") # vykreslit jako caru

#C
f.dens = function(x){
  res = 2-(3/2)*x
  res[x < 0] = 0
  res[x > 2/3] = 0
  return(res)
}

# P(-1/3 ≤ X ≤ 1/3)
integrate(f.dens, -1/3, 1/3)$value

# P(X >0.3)
integrate(f.dens, 1/3, 2/3)$value # tohle nebude vzdy fungovat

#D
x_fx = function(x){
    fx = f.dens(x)
    return(x*fx)
}
xx_fx = function(x){
    fx = f.dens(x)
    return(x*x*fx)
}

# integrujeme jen tam kde vime, ze je f(x) nenulova
E_X = integrate(x_fx, 0, 2/3)$value
E_XX = integrate(xx_fx, 0, 2/3)$value

D_X = E_XX - E_X^2
std_X = sqrt(D_X)

cbind(c("E(X)","D(X)","sigma x"),c(E_X,D_X,std_X))

#E Y = 2-4x
E_Y = 2 - 4*E_X # E(2-4x)
D_Y = (-4)^2*D_X # D(2-4x)
std_Y = sqrt(D_Y)

cbind(c("E(Y)","D(Y)","sigma y"),c(E_Y,D_Y,std_Y))

x = 0:4 #pocet projektu, ktere nas zajimaji
N = 100000 #celkem 9 projektu
M = 20000 #celkovy pocet projektu, ktere nas zajimaji
n = 4 #pocet projektu ve vyberu

# graf pravdepodobnostni funkce pro P(X = 0 az 4)
p = dhyper(x, M, N - M, n) # hodnoty pravdepodobnostni funkce pro x
#kontrola - melo by dat 1
#sum(p) == 1
#plot(x, p)

#jednotlive pravdepodobnosti p priradime k odpovidajicim hodnotam vytyhnutemu poctu spravnych projektu
pravdep = rbind(c("P(xi)",p))
colnames(pravdep) = c("xi",0:4)
rownames(pravdep) = ""
pravdep #tabulka pravdepodobnostni funkce
pravd.f(x, p) #vykresleni

#pravdepodobnosti prubezne scitame a priradime k nim omezeni
distrib = cbind(cumsum(p),c("x<=0","0<x<=1","0<x<=1","1<x<=2","x>3"))
colnames(distrib) = c("","")
rownames(distrib) = c("","","F(x) = ","","")
distrib #predpis distribucni funkce
dist.f(x,p) #vykresleni


f <- function(net) {
    return ( 1/(1+exp(-net)) )
}

df_dnet <- function(f_net) {
    return (f_net * (1 - f_net))
}

mlp.architecture <- function(input.length=2,
                             hidden.length=2,
                             output.length=1,
                             activation.function=f,
                             d_activation.function=df_dnet) {

    model = list()
    model$input.length = input.length
    model$hidden.length = hidden.length
    model$output.length = output.length

    model$hidden = matrix(runif(min=-0.5, max=0.5,
            hidden.length*(input.length+1)),
                   nrow=hidden.length, ncol=input.length+1)

    model$output = matrix(runif(min=-0.5, max=0.5,
            output.length*(hidden.length+1)),
                   nrow=output.length, ncol=hidden.length+1)

    model$f = activation.function
    model$df_dnet = d_activation.function

    return (model)
}

mlp.forward <- function(model, Xp) {
    # Hidden layer
    net_h_p = model$hidden %*% c(Xp, 1)
    f_net_h_p = model$f(net_h_p)

   # Output layer
   net_o_p = model$output %*% c(as.numeric(f_net_h_p), 1)
   f_net_o_p = model$f(net_o_p)

   # Results
   ret = list()
   ret$net_h_p = net_h_p
   ret$net_o_p = net_o_p
   ret$f_net_h_p = f_net_h_p
   ret$f_net_o_p = f_net_o_p

   return (ret)
}

mlp.backpropagation <- function(model,
                                dataset,
                                eta=0.1,
                                threshold=1e-4) {

    squaredError = 2 * threshold
    counter = 0

    while(squaredError > threshold) {
        squaredError = 0

        for (p in 1:nrow(dataset)) {
            Xp = as.numeric(dataset[p, 1:model$input.length])
            Yp = as.numeric(dataset[p,
                    (model$input.length+1):ncol(dataset)])

            results = mlp.forward(model, Xp)
            Op = results$f_net_o_p

            # Calculando o erro
            error = Yp - Op

            squaredError = squaredError + sum(error^2)

            delta_o_p = error * model$df_dnet(results$f_net_o_p)

            w_o_kj = model$output[,1:model$hidden.length]
            delta_h_p =
                as.numeric(model$df_dnet(results$f_net_h_p)) *
                    (as.numeric(delta_o_p) %*% w_o_kj)

            model$output = model$output +
                eta*(delta_o_p%*%as.vector(c(results$f_net_h_p,1)))
            model$hidden = model$hidden +
                eta*(t(delta_h_p) %*% as.vector(c(Xp,1)))
        }
        squaredError = squaredError / nrow(dataset)

        cat("Erro médio quadrado = ", squaredError, "\n")

        counter = counter + 1
    }
    cat("Base treinada Daniel, SEU GOSTOSO!\n")
    ret = list()
    ret$model = model
    ret$counter = counter

    return (ret)
}

dataset = read.csv('__dataset.csv', header=F, skip=1)
dataset <- dataset[c(1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 12, 13, 14, 15, 8)]
ids = sample(1:nrow(dataset), size=33)
training = dataset[ids,]
test = dataset[-ids,]
model = mlp.architecture(input.length=14, output.length=1, hidden.length=15)
trained = mlp.backpropagation(dataset=training, model=model, eta=0.5)
write.csv(trained$model$hidden, file="hidden.csv", row.names=FALSE)
write.csv(trained$model$output, file="output.csv", row.names=FALSE)


library(tidyr)
library(ggplot2)
library(dplyr)
library(cowplot)
library(readr)

predict_mean_fitness <- function(Ne, L, s, eps)
{
  k <- c(0:L)
  f <- exp(-s*k^(1-eps))
  p_k <- (f^(2*Ne-2)*choose(L, k))/sum(f^(2*Ne-2)*choose(L, k))
  sum(f*p_k)
}

w_vs_eps <- function(Ne, L, s, epsstart, epsstop, epssteps = 0.01)
{
  eps <- seq(epsstart, epsstop, epssteps)
  w_ave <- vapply(eps, function(eps){predict_mean_fitness(Ne, L, s, eps)}, 1)
  data.frame(s, w_ave, Ne, L, eps)
}

qmin <- function(s, N, L){log(L*log(2)/(2*s*N-2*s))/log(L/2)}

t <- read_csv("../processed_results/varying_eps_N100_max1.csv")

t %>% mutate(q=1-epistasis_coef) %>%
  group_by(q,sel_coef,mu_prob,k_start,rep) %>%
  summarise(mean_f_over_time=mean(mean_fitness)) -> t_sum

for (s in c(0.01, 0.001, 0.0001)){
  t_sum %>% filter(sel_coef==s) -> f
  Ne <- t$Ne[1]
  L <- t$L[1]
  an_f <- w_vs_eps(Ne, L, s, -1, 1) %>% mutate(q=1-eps)
  q_est <- qmin(s,Ne,100)

  p <- ggplot()+
    stat_summary(data=f,
                 inherit.aes=FALSE,
                 aes(x=q,y=mean_f_over_time,color=factor(mu_prob)),
                 fun.y = mean,
                 fun.ymin = function(x) mean(x) - sd(x)/sqrt(length(x)),
                 fun.ymax = function(x) mean(x) + sd(x)/sqrt(length(x)),
                 geom = "pointrange",
                 size=0.4)+
    geom_line(data=an_f, aes(x=q,y = w_ave))+
    #geom_vline(xintercept = q_est, linetype = 2)+
    #draw_text(x = q_est+0.02, y =1, hjust = 0, vjust = 1, text = "predicted q*", size = 12)+
    #scale_y_continuous(breaks=seq(0.2,1,0.2))+
    coord_cartesian(ylim=c(0.7,1),xlim=c(0,2))+
    guides(col = guide_legend(title="\u03BC"))+
    theme(axis.title = element_text(size = 14),
          axis.text = element_text(size = 12),
          legend.text = element_text(size = 11),
          legend.title = element_text(size = 12),
          legend.position = "none")+
    xlab('Q') +
    ylab('Mean fitness')
  save_plot(paste0("../plots/mean_fit_v_Q_s",s,"_N",Ne,"_max1.png"), p)
}

p3 <- make_fig(L = 100, s = 0.001, N = 100)


inverse.logit = function( x ) {
  # x should be the log odds ratio
  oddsratio = exp(x)
  prob = oddsratio / (1 + oddsratio )
  return (prob)
}


#' The zero-truncated compund poisson-lognormal distributions
#'
#' Density function and random generation for Zero-Trauncated Poisson Lognormal
#' distribution with parameters `mu` and sd `sig`.
#'
#' A compound Poisson-lognormal distribution is a Poisson probability
#' distribution where its parameter \eqn{\lambda} is a random variable with
#' lognormal distribution, that is to say \eqn{log\lambda} are normally
#' distributed with mean \eqn{\mu} and variance \eqn{\sigma^2} (Bulmer 1974).
#' The zero-truncated Poisson-lognormal distribution can be derived from a
#' zero-truncated Poisson distribution.
#'
#' Type 1 ZTPLN truncates zero based on Poisson-lognormal distribution and
#' type 2 ZTPLN truncates zero based on zero-truncated Poisson distribution.
#' For mathematical details, please see `vignette("ztpln")`
#'
#' @param n number of random values to return.
#' @param x	vector of (non-negative integer) quantiles.
#' @param mu mean of lognormal distribution.
#' @param sig standard deviation of lognormal distribution.
#' @param log logical; if TRUE, probabilities p are given as log(p).
#' @param type1 logical; if TRUE, Use type 1 ztpln else use type 2.
#' @return dztpln gives the (log) density and rztpln generates
#' random variates.
#' @references Bulmer, M. G. 1974. On Fitting the Poisson Lognormal Distribution to Species-Abundance Data. Biometrics 30:101-110.
#'
#' @seealso \code{\link{dztplnm}}
#'
#' @examples
#' rztpln(n = 10, mu = 0, sig = 1, type1 = TRUE)
#' rztpln(n = 10, mu = 6, sig = 4, type1 = TRUE)
#' dztpln(x = 1:5, mu = 1, sig = 2)
#' @export
dztpln <- function(x, mu, sig, log = FALSE, type1 = TRUE) {
  if (length(mu) > 1 | length(sig) > 1)
    stop("Vectorization of parameters not implemented")
  if (sig < 0) stop("sig needs to be > 0")
  if (any(!DistributionUtils::is.wholenumber(x))) warning("non integer values in x")
  if (min(x) <= 0) warning("zero in x")
  x <- x[x > 0]
  if (type1) {
    lik <- do_dztpln(x, mu, sig)
  } else lik <- do_dztpln2(x, mu, sig)
  if (log) return(log(lik)) else return(lik)
}

#' @rdname dztpln
#' @export
rztpln <- function(n, mu, sig, type1 = TRUE) {
  if (length(mu) > 1 | length(sig) > 1)
     stop("Vectorization of parameters not implemented")
  if (sig < 0) stop("sig needs to be > 0")
  if (sig > 15) stop("standard deviation > 15 in log-scale is too large")
  if (type1) do_vec_rztpln1(n, mu, sig) else do_vec_rztpln2(n, mu, sig)
}


#Developing multivariate normal with covariance. This recovers species abundances and covariance matrix.
#Eventually extend to dirlichet case.
#clear ennvironment, load packages.
rm(list=ls())
library(runjags)

#try with simulated data
y1 <- round(rnorm(100, 100, 5))
y2 <- round(y1*-2 + rnorm(100,0,5)) + 400
y3 <- round(rnorm(100,50,5))
y4 <- round(rnorm(100,50,5))
spp.y <- data.frame(y1,y2,y3,y4)
spp.y <- as.matrix(spp.y)
seqs <- rowSums(spp.y)

#introduce a sequence depth effect.
#Get a integer value to multiply species abundances by.
#effort <- round(runif(100,5,50))
#spp.y2 <- spp.y * effort
#eqs <- rowSums(spp.y2)
#seqs <- rep(1,nrow(spp.y))

jags.model = "
model {
#setup priors for each species
for(j in 1:N.spp){
  m0[j] ~ dnorm(0, .001) #intercept prior
}

#Sigma (covariance matrix) prior
sigma ~ dwish(r,S)

#implement multivariate normal.
for(i in 1:N){
  y.hat[i,1:N.spp] <- (m0[1:N.spp]) * seqs[i]
      y[i,1:N.spp] ~ dmnorm(y.hat[i,1:N.spp], sigma[1:N.spp,1:N.spp])
}

} #close model loop.
"

#Wish prior on covariance - weak covariance.
W = diag(ncol(spp.y))/10000

jags.data <- list(y = spp.y,
                  N = nrow(spp.y),
                  N.spp = ncol(spp.y),
                  r = W,
                  S = ncol(spp.y),
                  seqs = seqs)

jags.out <- run.jags(jags.model,
                     data=jags.data,
                     adapt = 100,
                     burnin = 3000,
                     sample = 2000,
                     n.chains=3,
                     monitor=c('m0','sigma'))

#true relative abundances across samples.
colMeans(spp.y) / sum(colMeans(spp.y))
#estimated relative abundances
summary(jags.out)[grep('m0',rownames(summary(jags.out))),'Median']

#Get estimated covariance matrix
z <- summary(jags.out)[grep('sigma',rownames(summary(jags.out))),'Median']
z.lo.95 <- summary(jags.out)[grep('sigma',rownames(summary(jags.out))),'Lower95']
z.hi.95 <- summary(jags.out)[grep('sigma',rownames(summary(jags.out))),'Upper95']
i.covm <- matrix(z, ncol = sqrt(length(z)))
i.covm.lo <- matrix(z.lo.95, ncol = sqrt(length(z.lo.95)))
i.covm.hi <- matrix(z.hi.95, ncol = sqrt(length(z.hi.95)))
solve(i.covm) #jags returns the inverse of the covariance matrix. This inverts it.

#What is the covariance of real data?
#spp.y.cov <- spp.y2 / seqs
#cov(spp.y.cov)
cov(spp.y)
cov(spp.y2)

cov2cor(cov(spp.y2))
(cov2cor(cov(spp.y)))^2

cov2cor(solve(i.covm))
cov2cor(solve(i.covm.lo))
cov2cor(solve(i.covm.hi))


#' ---
#' subtitle: Exploring incomplete gamma function
#' output: html_document
#' ---
#'
source("notebooks/eda_startup.r")
devtools::load_all(path = ".")
#'
#'
#' Incomplete gamma-function
#'
#' @param n day `n`
daily_lactation_f <- function(n, a, b, c) {
  a * n ** b * exp(-c * n)
}
#' @inheritParams daily_lactation_f
daily_lactation_df <- function(n, a, b, c) {
  #' alternative: `a exp(-c n) (b n^(-1 + b) - c n^b)`
  a * exp(-c * n) * n^(-1 + b) * (b - c * n)
}
#'
#'
#' Source: [Application of the Incomplete Gamma Function to
#' Predict Cumulative Milk Production](https://www.sciencedirect.com/science/article/pii/S0022030280828955)
#'
tibble(lactation = "first",
       a = 13.546, b = 19.575 / 1e2, c = 3.388 / 1e3) %>%
  add_row(lactation = "second",
          a = 18.820, b = 23.576 / 1e2, c = 5.441 / 1e3) %>%
  add_row(lactation = "third and more",
          a = 15.956, b = 30.004 / 1e2, c = 6.067 / 1e3) %>%
  mutate(lactation = fct_inorder(lactation)) %>%

  #' Change `a` to opposite sign just to get the curve that we are exploring
  mutate(a = -a) %>%

  #' Add suggested peaks
  mutate(peak_location = b/c) %>%
  # mutate(peak_level = ???) %>%

  #' Evaluate lactation-curve
  expand_grid(n = seq_len(305)) %>%
  mutate(daily_lactation_f  =
           pmap_dbl(select(., n, a, b, c), daily_lactation_f)) %>%
  mutate(daily_lactation_df  =
           pmap_dbl(select(., n, a, b, c), daily_lactation_df)) %>%
  pivot_longer(starts_with("daily_lactation")) %>%
  identity() %>% {
    ggplot(.) +
      # aes(n, daily_lactation_f,
      aes(n, value,
          groups = interaction(name, lactation),
          color = lactation) +
      geom_line() +

      geom_vline(aes(xintercept = peak_location,
                     color = lactation),
                 data = . %>% distinct(peak_location, lactation)) +
      facet_wrap(~name, ncol = 1, scales = "free_y") +
      NULL
  }
#'
#'
#'


# Master Thesis Project - Extreme Value Theory
# We use here QQ-plots to assess graphically the
# goodness of fit of our extreme distributions for
# the high ( above high quantile) and low (below low
# quantile) log-returns

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("loadStockData_plain.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Loading the original data for the five stocks then
# getting the LVMH and the Total data
df_plain <- loadStockData_plain(CHOICE)

# Fitting

	data_bnp <- diff(log(df_plain[[1]]))
	data_carrefour <- diff(log(df_plain[[2]]))
	data_lvmh <- diff(log(df_plain[[3]]))
	data_sanofi <- diff(log(df_plain[[4]]))
	data_total <- diff(log(df_plain[[5]]))

	# Computing the 95 % - quantiles  [97.5 % - quantile in the case of the LVMH stock]
	# and the 5 % quantiles for each of the stocks
	highQuantiles <- c(quantile(data_bnp,0.99), quantile(data_carrefour,0.995), quantile(data_lvmh,0.995),
					quantile(data_sanofi,0.995), quantile(data_total,0.995))
	lowQuantiles <- c(quantile(-data_bnp,0.01), quantile(-data_carrefour,0.005), quantile(-data_lvmh,0.005),
					quantile(-data_sanofi,0.005), quantile(-data_total,0.005))

	# Getting the data above the high threshold and below the low threshold
	data_bnp_H <- diff(log(df_plain[[1]]))
	data_bnp_H <- data_bnp_H[data_bnp_H > highQuantiles[1]]

	data_bnp_L <- -diff(log(df_plain[[1]]))
	data_bnp_L <- data_bnp_L[data_bnp_L < lowQuantiles[1]]

	data_carrefour_H <- diff(log(df_plain[[2]]))
	data_carrefour_H <- data_carrefour_H[data_carrefour_H > highQuantiles[2]]

	data_carrefour_L <- -diff(log(df_plain[[2]]))
	data_carrefour_L <- data_carrefour_L[data_carrefour_L < lowQuantiles[2]]

	data_lvmh_H <- diff(log(df_plain[[3]]))
	data_lvmh_H <- data_lvmh_H[data_lvmh_H > highQuantiles[3]]

	data_lvmh_L <- -diff(log(df_plain[[3]]))
	data_lvmh_L <- data_lvmh_L[data_lvmh_L < lowQuantiles[3]]

	data_sanofi_H <- diff(log(df_plain[[4]]))
	data_sanofi_H <- data_sanofi_H[data_sanofi_H > highQuantiles[4]]

	data_sanofi_L <- -diff(log(df_plain[[4]]))
	data_sanofi_L <- data_sanofi_L[data_sanofi_L < lowQuantiles[4]]

	data_total_H <- diff(log(df_plain[[5]]))
	data_total_H <- data_total_H[data_total_H > highQuantiles[5]]

	data_total_L <- -diff(log(df_plain[[5]]))
	data_total_L <- data_total_L[data_total_L < lowQuantiles[5]]

	# Fitting the data, and getting the corresponding location, scale and
	# shape parameters respectively, for each stock
	# Fitting the log-returns for the above-high-threshold data
	bnp_fit_H <- (gev.fit(data_bnp_H))
	carrefour_fit_H <- gev.fit(data_carrefour_H)
	lvmh_fit_H <- gev.fit(data_lvmh_H)
	sanofi_fit_H <- gev.fit(data_sanofi_H)
	total_fit_H <- gev.fit(data_total_H)
	# Fitting the minus log-returns for the below-low-threshold data
	bnp_fit_L <- (gev.fit(data_bnp_L))
	carrefour_fit_L <- gev.fit(data_carrefour_L)
	lvmh_fit_L <- gev.fit(data_lvmh_L)
	sanofi_fit_L <- gev.fit(data_sanofi_L)
	total_fit_L <- gev.fit(data_total_L)

	# Saving the GEV parameters for later use
	params_bnp_H <- bnp_fit_H$mle
	params_carrefour_H <- carrefour_fit_H$mle
	params_lvmh_H <- lvmh_fit_H$mle
	params_sanofi_H <- sanofi_fit_H$mle
	params_total_H <- total_fit_H$mle

	params_bnp_L <- bnp_fit_L$mle
	params_carrefour_L <- carrefour_fit_L$mle
	params_lvmh_L <- lvmh_fit_L$mle
	params_sanofi_L <- sanofi_fit_L$mle
	params_total_L <- total_fit_L$mle

# Drawing the QQ-plots
	# BNP stock

		N_bnp_H <- length(data_bnp_H)
		qVect_bnp_H <- (N_bnp_H + 1 - 1:N_bnp_H)/(N_bnp_H + 1)
		N_bnp_L <- length(data_bnp_L)
		qVect_bnp_L <- (N_bnp_L + 1 - 1:N_bnp_L)/(N_bnp_L + 1)

		# Ordering the samples
		data_bnp_H <- sort(data_bnp_H)
		data_bnp_L <- sort(data_bnp_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_bnp_H <- qgev(qVect_bnp_H ,params_bnp_H[3],params_bnp_H[1],params_bnp_H[2])
		gev_bnp_L <- qgev(qVect_bnp_L ,params_bnp_L[3],params_bnp_L[1],params_bnp_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_BNP_High.png")
		plot(qVect_bnp_H,gev_bnp_H, main = "QQ-plot BNP Paribas, above \n99 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_bnp_H~qVect_bnp_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_BNP_Low.png")
		plot(qVect_bnp_L,gev_bnp_L, main = "QQ-plot BNP Paribas, below \n1 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_bnp_L~qVect_bnp_L), col = "blue")
		dev.off()
		graphics.off()

	# Carrefour stock

		N_carrefour_H <- length(data_carrefour_H)
		qVect_carrefour_H <- (N_carrefour_H + 1 - 1:N_carrefour_H)/(N_carrefour_H + 1)
		N_carrefour_L <- length(data_carrefour_L)
		qVect_carrefour_L <- (N_carrefour_L + 1 - 1:N_carrefour_L)/(N_carrefour_L + 1)

		# Ordering the samples
		data_carrefour_H <- sort(data_carrefour_H)
		data_carrefour_L <- sort(data_carrefour_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_carrefour_H <- qgev(qVect_carrefour_H ,params_carrefour_H[3],params_carrefour_H[1],params_carrefour_H[2])
		gev_carrefour_L <- qgev(qVect_carrefour_L ,params_carrefour_L[3],params_carrefour_L[1],params_carrefour_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_Carrefour_High.png")
		plot(qVect_carrefour_H,gev_carrefour_H, main = "QQ-plot Carrefour, above \n99.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_carrefour_H~qVect_carrefour_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_Carrefour_Low.png")
		plot(qVect_carrefour_L,gev_carrefour_L, main = "QQ-plot Carrefour, below \n0.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_carrefour_L~qVect_carrefour_L), col = "blue")
		dev.off()
		graphics.off()

	# LVMH stock

		N_lvmh_H <- length(data_lvmh_H)
		qVect_lvmh_H <- (N_lvmh_H + 1 - 1:N_lvmh_H)/(N_lvmh_H + 1)
		N_lvmh_L <- length(data_lvmh_L)
		qVect_lvmh_L <- (N_lvmh_L + 1 - 1:N_lvmh_L)/(N_lvmh_L + 1)

		# Ordering the samples
		data_lvmh_H <- sort(data_lvmh_H)
		data_lvmh_L <- sort(data_lvmh_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_lvmh_H <- qgev(qVect_lvmh_H ,params_lvmh_H[3],params_lvmh_H[1],params_lvmh_H[2])
		gev_lvmh_L <- qgev(qVect_lvmh_L ,params_lvmh_L[3],params_lvmh_L[1],params_lvmh_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_LVMH_High.png")
		plot(qVect_lvmh_H,gev_lvmh_H, main = "QQ-plot LVMH, above \n99.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_lvmh_H~qVect_lvmh_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_LVMH_Low.png")
		plot(qVect_lvmh_L,gev_lvmh_L, main = "QQ-plot LVMH, below \n0.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_lvmh_L~qVect_lvmh_L), col = "blue")
		dev.off()
		graphics.off()

	# Sanofi stock

		N_sanofi_H <- length(data_sanofi_H)
		qVect_sanofi_H <- (N_sanofi_H + 1 - 1:N_sanofi_H)/(N_sanofi_H + 1)
		N_sanofi_L <- length(data_sanofi_L)
		qVect_sanofi_L <- (N_sanofi_L + 1 - 1:N_sanofi_L)/(N_sanofi_L + 1)

		# Ordering the samples
		data_sanofi_H <- sort(data_sanofi_H)
		data_sanofi_L <- sort(data_sanofi_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_sanofi_H <- qgev(qVect_sanofi_H ,params_sanofi_H[3],params_sanofi_H[1],params_sanofi_H[2])
		gev_sanofi_L <- qgev(qVect_sanofi_L ,params_sanofi_L[3],params_sanofi_L[1],params_sanofi_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_Sanofi_High.png")
		plot(qVect_sanofi_H,gev_sanofi_H, main = "QQ-plot Sanofi, above \n99.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_sanofi_H~qVect_sanofi_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_Sanofi_Low.png")
		plot(qVect_sanofi_L,gev_sanofi_L, main = "QQ-plot Sanofi, below \n0.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_sanofi_L~qVect_sanofi_L), col = "blue")
		dev.off()
		graphics.off()

	# Total stock

		N_total_H <- length(data_total_H)
		qVect_total_H <- (N_total_H + 1 - 1:N_total_H)/(N_total_H + 1)
		N_total_L <- length(data_total_L)
		qVect_total_L <- (N_total_L + 1 - 1:N_total_L)/(N_total_L + 1)

		# Ordering the samples
		data_total_H <- sort(data_total_H)
		data_total_L <- sort(data_total_L, decreasing = TRUE)

		# Getting the quantiles of the fitting distributions
		gev_total_H <- qgev(qVect_total_H ,params_total_H[3],params_total_H[1],params_total_H[2])
		gev_total_L <- qgev(qVect_total_L ,params_total_L[3],params_total_L[1],params_total_L[2])

		# Plotting
		quartz()
    	png(file = "QQ_Total_High.png")
		plot(qVect_total_H,gev_total_H, main = "QQ-plot Total, above \n99.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_total_H~qVect_total_H), col = "red")
		dev.off()
		graphics.off()

		quartz()
    	png(file = "QQ_Total_Low.png")
		plot(qVect_total_L,gev_total_L, main = "QQ-plot Total, below \n0.5 %-quantile data", xlab ="", ylab = "")
		abline(lm(gev_total_L~qVect_total_L), col = "blue")
		dev.off()
		graphics.off()


h = max(10, plantHeight) / 100.0
conductance = (wind * vonKarman** 2) / (log((heightWeatherMeasurements - d * h) / (zm * h)) * log((heightWeatherMeasurements - d * h) / (zh * h)))


## 3. Populations and Samples ##

# question_1 <- ''
# question_2 <- ''
# question_3 <- ''
# question_4 <- ''
# question_5 <- ''
question_1 <- 'population'
question_2 <- 'population'
question_3 <- 'sample'
question_4 <- 'population'
question_5 <- 'sample'

## 4. Explore the Dataset ##

library(readr)
wnba <- read_csv("wnba.csv")

## 5. Sampling Error ##

set.seed(1)
parameter <- max(wnba$Games_Played)
sample <- sample(wnba$Games_Played, size = 30)
statistic <- max(sample)
sampling_error <- parameter - statistic

## 6. Simple Random Sampling ##

set.seed(1)
sample_1 <- mean(sample(wnba$PTS, size = 10))
sample_2 <- mean(sample(wnba$PTS, size = 10))
sample_3 <- mean(sample(wnba$PTS, size = 10))

## 7. Generating Numerous Random Samples ##

set.seed(1)
mean_points <- replicate(n = 100,
          expr = mean(sample(wnba$PTS, size = 10)))
minimum <- min(mean_points)
maximum <- max(mean_points)

## 8. Visualizing Random Samples ##

library(tibble)
library(ggplot2)
set.seed(1)
mean_points <- replicate(n = 100,
          expr = mean(sample(wnba$PTS, size = 10)))
sample_number <- 1:100
df <- tibble(x = sample_number, y = mean_points)
ggplot(data = df,
       aes(x = sample_number, y = mean_points)) +
    geom_point() +
    geom_hline(yintercept = mean(wnba$PTS),
               color = "blue") +
    ylim(90, 310)

Data Analyst in R/Step 5 - Probability and Statistics/1. Statistics Fundamentals in R/1. Simple Random Sampling.r


#' Calculates Future Value
#'
#' @param p numeric
#' @param r numeric
#' @param t numeric
#'
#' @return numeric
#' @export
#'
#' @examples
#' future_value(2500, 0.043, 8/12) #2571.67
future_value <- function(p, r, t) {
  p*(1+r*t)
  # Predicts the future value of the money invested
}


#Define function to allocate integer quantities among categories
#---------------------------------------------------------------
#' Allocate integer quantities among categories
#'
#' \code{splitIntegers} splits a total value into a vector of whole numbers to
#' reflect input vector of proportions
#'
#' This function splits an input total into a vector of whole numbers to reflect
#' an input vector of proportions. If the input total is not an integer, the
#' value is rounded and converted to an integer.
#'
#' @param Tot a number that is the total value to be split into a vector of
#' whole numbers corresponding to the input proportions. If Tot is not an
#' integer, its value is rounded and converted to an integer.
#' @param Props_ a numeric vector of proportions used to split the total value.
#' The values should add up to approximately 1. The function will adjust so that
#' the proportions do add to 1.
#' @return a numeric vector of whole numbers corresponding to the Props_
#' argument which sums to the Tot.
#' @export
splitIntegers <- function(Tot, Props_) {
  #Convert Tot into an integer
  if (!is.integer(Tot)) {
    Tot <- as.integer(round(Tot))
  }
  #If Tot is 0, return vector of zeros
  if (Tot == 0) {
    integer(length(Props_))
  } else {
    #Make sure that Props_ sums exactly to 1
    Props_ <- Props_ / sum(Props_)
    #Make initial whole number split
    Ints_ <- round(Tot * Props_)
    #Determine the difference between the initial split and the total
    Diff <- Tot - sum(Ints_)
    #Allocate the difference
    if (Diff != 0) {
      for (i in 1:abs(Diff)) {
        IdxToChg <- sample(1:length(Props_), 1, prob = Props_)
        Ints_[IdxToChg] <- Ints_[IdxToChg] + sign(Diff)
      }
    }
    unname(Ints_)
  }
}


pascalTriangle <- function(h) {
  for(i in 0:(h-1)) {
    s <- ""
    for(k in 0:(h-i)) s <- paste(s, "  ", sep="")
    for(j in 0:i) {
      s <- paste(s, sprintf("%3d ", choose(i, j)), sep="")
    }
    print(s)
  }
}


sd<-.225
z_foralpha=qnorm(1-0.05)
z_forbeta=qnorm(1-0.01)
zstar<-z_foralpha+z_forbeta
E<-16.37 - 16.27
sample_size<- zstar^2 * sd * sd/ E^2
print(ceiling(sample_size))
#  the manufacturer must obtain a random sample of n = 80 boxes to conduct this test


# Master Thesis Project - Extreme Value Theory
# We assume that the stock prices follow a geometric
# Brownian motion (Black-Scholes model). We plot the
# empirical stock price data as well as the simulated
# geometric Brownian motions associated to them.
# Killian Martin--Horgassan
# 08-06-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("loadStockData_plain.r")
source("firstElement.r")
source("computeApproximateGradient.r")
source("meanAndVariance.r")
source("Visualisation_StockPriceVariations.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Loading the original data for the five stocks then
# getting the LVMH and the Total data
df_plain <- loadStockData_plain(CHOICE)
lvmhData <- df_plain[[3]]
totalData <- df_plain[[5]]
indexes <- Visualisation_StockPriceVariations()
#indexes[1] <- indexes[1] - 100

# Building the Geometric Brownian motion
	N = max(indexes)-1
	M = dim(df)[2]
	simulationLVMH <- rep(0,indexes[1]-1)
	simulationTotal <- rep(0,indexes[2]-1)

	# Computing the mean and Variances of the stocks
	meanAndVarLVMH <- meanAndVariance(lvmhData[1:indexes[1]-1])
	meanAndVarTotal <- meanAndVariance(totalData[1:indexes[2]-1])

	#######################################################################
	# From experience we see that we need to rescale the time steps if we
	# want to be able not to go over the max and min values allowed by the
	# computer
	#######################################################################

	# Time component
	timeSteps = 0:(N-1)
	timeSteps = timeSteps/N ## RESCALING

	# Brownian motion component
    dis = (1/sqrt(N))*rnorm(N,0,1) ## DO NOT FORGET TO RESCALE HERE
    dis = cumsum(dis)

	# LVMH stock
	coeff1 = meanAndVarLVMH[1] - 0.5*meanAndVarLVMH[2]
	coeff1 = coeff1*(1/N) ## Rescale the mean
	coeff2 = sqrt(meanAndVarLVMH[2]) ## The variance has already been rescaled
	cat("****************************************************")
	cat("\nDeterministic coefficient GBM - LVMH simulation:\n")
	print(coeff1)
	cat("\nStochastic coefficient GBM - LVMH simulation:\n")
	print(coeff2)
	exponentLVMH <- rep(0,(indexes[1]-1))
	for (k in 2:(indexes[1] - 1)){
		exponentLVMH[k] <- coeff1*timeSteps[k] + coeff2*dis[k]
	}
	#exponentLVMH[2:(indexes[1]-1)] <- coeff1*timeSteps[2:(indexes[1]-1)] +
		#coeff2*dis[2:(indexes[1]-1)]
	lvmhT0 <- (df_plain[[3]])[1]
	simulationLVMH <- lvmhT0*exp(exponentLVMH)

	# Total Stock
	coeff1 = meanAndVarTotal[1] - 0.5*meanAndVarTotal[2]
	coeff1 = coeff1*(1/N) ## Rescale the mean
	coeff2 = sqrt(meanAndVarTotal[2]) ## The variance has already been rescaled
	cat("\nDeterministic coefficient GBM - Total simulation:\n")
	print(coeff1)
	cat("\nStochastic coefficient GBM - Total simulation:\n")
	print(coeff2)
	cat("****************************************************\n")
	cat("****************************************************\n")
	exponentTotal <- rep(0,(indexes[2]-1))
	for (k in 2:(indexes[2] - 1)){
		exponentTotal[k] <- coeff1*timeSteps[k] + coeff2*dis[k]
	}
	#exponentTotal[2:(indexes[2]-1)] <- coeff1*timeSteps[2:(indexes[2]-1)] +
		#coeff2*dis[2:(indexes[2]-1)]
	totalT0 <- (df_plain[[5]])[1]
	simulationTotal <- totalT0*exp(exponentTotal)

	#######################################################################
	# From experience again we see that we need to clean up a bit the data
	# we have just simulated as there a few points for which the value is
	# extremely high. We will replace them with the closest more 'reasonable'
	# value
	#######################################################################
	# Using the median is a RUBBISH-grade idea
	#simulationLVMH <- replaceExtremes(simulationLVMH,median(simulationLVMH))
	#simulationTotal <- replaceExtremes(simulationTotal,median(simulationTotal))

	 quartz()
     par(mfrow = c(2,4))

	 plot(log(lvmhData[1:(indexes[1]-1)]), type = 'l', main = "LVMH - Actual",
	 	ylab = "Log of the Stock price")
	 plot(exponentLVMH + rep(log(lvmhT0),length(exponentLVMH)), type = 'l',
	  main = "LVMH - simulation", ylab = "Log of the Stock price - simulated")
	 plot(exp(exponentLVMH + rep(log(lvmhT0),length(exponentLVMH))), type = 'l',
	  main = "LVMH - simulation", ylab = "Exp of the Log of the Stock price - simulated")
	 plot(simulationLVMH, type = 'l', main = "LVMH - simulation")
	 cat("\n \n \nMax simulation LVMH\n")
	 print(max(simulationLVMH))

	 plot(log(totalData[1:(indexes[2]-1)]), type = 'l', main = "Total - Actual",
	 	ylab = "Log of the Stock price")
	 plot(exponentTotal + rep(log(totalT0),length(exponentTotal)), type = 'l',
	  main = "Total - simulation", ylab = "Log of the Stock price - simulated")
	 plot(exp(exponentTotal + rep(log(totalT0),length(exponentTotal))), type = 'l',
	  main = "Total - simulation", ylab = "Exp of the Log of the Stock price - simulated")
	 plot(simulationTotal, type = 'l', main = "Total - simulation ")
	 cat("\n \n \nMax simulation Total\n")
	 print(max(simulationTotal))

# Plotting the actual stock prices and the corresponding simulations
x_label <- "Weekly measurements"
y_label1 <- "Log Prices : actual and simulation"
y_label2 <- "Prices : actual and simulation"
title1 <- "LVMH Stock"
title2 <- "Total Stock"

# Rescaling the y-axis by computing the maxima and minima
# and adapting the y-min and y-max
Ymaxima <- c(max((df_plain[[3]])[1:indexes[1]-1],simulationLVMH),
				max((df_plain[[5]])[1:indexes[2]-1],simulationTotal))
Yminima <- c(min((df_plain[[3]])[1:indexes[1]-1],simulationLVMH),
				min((df_plain[[5]])[1:indexes[2]-1],simulationTotal))

quartz()
png(file = "cleanedLVMH_Total_Log.png")
par(mfrow = c(1,2))
plot(log(lvmhData[1:(indexes[1]-1)]), pch = 1, col = "green", type = 'l', xlab = x_label, ylab = y_label1, main = title1, ylim = c(0,10))
lines(exponentLVMH + rep(log(lvmhT0),length(exponentLVMH)), col = "yellow")
print(length(exponentLVMH))
print(length(log(lvmhData[1:(indexes[1]-1)])))
plot(log(totalData[1:(indexes[2]-1)]), pch = 1, col = "red", type = 'l', xlab = x_label, ylab = y_label1, main = title2, ylim = c(0,10))
lines(exponentTotal + rep(log(totalT0),length(exponentTotal)), col = "yellow")
#dev.off()
#graphics.off()

quartz()
png(file = "cleanedLVMH_Total.png")
par(mfrow = c(1,2))
plot(exp(log((df_plain[[3]])[1:(indexes[1]-1)])), pch = 1, col = "green", type = 'l', xlab = x_label, ylab = y_label2, main = title1, ylim = c(Yminima[1],1000))
lines(exp(exponentLVMH + rep(log(lvmhT0),length(exponentLVMH))), col = "yellow")
plot(exp(log((df_plain[[5]])[1:(indexes[2]-1)])), pch = 1, col = "red", type = 'l', xlab = x_label, ylab = y_label2, main = title2, ylim = c(Yminima[2],1000))
lines(exp(exponentTotal + rep(log(totalT0),length(exponentTotal))), col = "yellow")


#############
## PSI routines
#############

## The following are low level routines to calculate the phase from various PSI algorithms.

## least squares fit of phase shifted interferograms with optional weights.

lspsi <- function(images, phases, wt=rep(1, length(phases))) {
  img.mat <- matrix(images, ncol=dim(images)[3])
  lspsiC(img.mat, phases, wt)
}

## Vargas et al.'s (2011) Principal Components method

pcapsi <- function(im.mat, bgsub=TRUE, group_diag="v") {
    if (bgsub) im.mat <- im.mat-rowMeans(im.mat)

	# svd of the crossproduct is faster!

    svd.cp <- svd(crossprod(im.mat))
    if (tolower(group_diag) == "v") {
        ph <- atan2(svd.cp$v[,2]*sqrt(svd.cp$d[2]),svd.cp$v[,1]*sqrt(svd.cp$d[1]))
        u <- im.mat %*% (svd.cp$u[,1:2] %*% diag(1/sqrt(svd.cp$d[1:2])))
    } else {
        ph <- atan2(svd.cp$v[,2],svd.cp$v[,1])
        u <- im.mat %*% svd.cp$u[,1:2]
    }
    ph <- wrap(ph-ph[1])
    phi <- atan2(-u[,2],u[,1])
    mod <- sqrt(u[,1]^2+u[,2]^2)
    r2 <- (svd.cp$d[1]+svd.cp$d[2])/sum(svd.cp$d)
    list(phi=phi, mod=mod/max(mod), phases=ph, snr=sqrt(r2/(1-r2)), eigen=svd.cp$d)
}

## Moore-Penrose generalized inverse (needed for genpca below)

mpinv <- function(X) {
    S <- svd(X)
    eps <- .Machine$double.eps * max(dim(X)) * S$d[1]
    dinv <- numeric(length(S$d))
    dinv[S$d >= eps] <- 1/S$d[S$d >= eps]
    tcrossprod(S$v %*% diag(dinv), S$u)
}

## my variation on a PCA based algorithm

gpcapsi <- function(im.mat, ptol=0.001, maxiter=20, trace=1) {
  gpcapsiC(im.mat, ptol, maxiter, trace)
}

## The "advanced iterative algorithm" of Wang & Han (2004)

aiapsi <- function(im.mat, phases,
		   ptol=0.001, maxiter=20, trace=1) {
  aiapsiC(im.mat, phases, ptol, maxiter, trace)
}

## A variation of Han & Kim's (1994) iterative algorithm

hkpsi <- function(im.mat, phases,
		maxiter=20, ptol=0.001, trace=1, plotprogress=TRUE) {
	.meps <- sqrt(.Machine$double.eps)
	M <- nrow(im.mat)
	nf <- ncol(im.mat)
	phases <- wrap(phases-phases[1])
	S <- rbind(rep(1,nf), cos(phases), sin(phases))
	sse <- numeric(maxiter+1)
	for (i in 1:maxiter) {
		phases.last <- phases

		# get the phase estimate from phase shifts

		SD <- svd(S)
		dp <- SD$d
		dp[dp>.meps] <- 1/dp[dp>.meps]
		dp[dp <= .meps] <- 0
		Phi <- tcrossprod(im.mat %*% (SD$v %*% diag(dp)), SD$u)
		sse[i] <- crossprod(as.vector(im.mat)-as.vector(Phi %*% S))
		if (i == 1) sse.1 <- sse[i]

		# get phase shifts from the phase. Note use crossproduct for speed.
		# Here is only difference from AIA - use full least squares estimate
		# at this step.

		PD <- svd(crossprod(Phi))
		dp <- PD$d
		dp[dp>.meps] <- 1/dp[dp>.meps]
		dp[dp <= .meps] <- 0
		S <- (PD$u %*% diag(dp) %*% t(PD$v)) %*% crossprod(Phi, im.mat)
		phases <- atan2(S[3,], S[2,])
		dphases <- sd(wrap(phases-phases.last))
		if (plotprogress) {
			if (i ==1)
				plot(1:maxiter, 1:maxiter, ylim=c(ptol, 1), type="n",
				  xlab="Iteration", ylab="", log="y")
			points(i, sse[i]/sse.1, pch=1)
			points(i, dphases, pch=2, col="green")
		}
		if ((trace > 0) && ((i-1)%%trace == 0)) {
		  cat(paste(i, ":", format(sse[i], digits=2), ":"),
                      format(phases,digits=3), "\n")
		  flush.console()
		}
		if (dphases < ptol) break
		S <- rbind(rep(1,nf), cos(phases), sin(phases))
	}

	#final estimate of phase

	phases <- wrap(phases-phases[1])
	S <- rbind(rep(1,nf), cos(phases), sin(phases))
	SD <- svd(S)
	dp <- SD$d
	dp[dp>.meps] <- 1/dp[dp>.meps]
	dp[dp <= .meps] <- 0
	Phi <- tcrossprod(im.mat %*% (SD$v %*% diag(dp)), SD$u)
	sse[i+1] <- crossprod(as.vector(im.mat)-as.vector(Phi %*% S))
	phi <- atan2(-Phi[,3], Phi[,2])
	mod <- sqrt(Phi[,2]^2+Phi[,3]^2)
	list(phi=phi, mod=mod/max(mod), phases=phases, iter=i, sse=sse)
}

## tiltpsi (new version)

tiltpsi <- function(im.mat, phases, coords,
       		    ptol=0.01, maxiter=20, trace=1) {
  tiltpsiC(im.mat, phases, coords, ptol, maxiter, trace)
}


#' @title expected_k_pop
#' @description
#' Calculates the expected number of alleles at a locus in a population, evolving under
#' a Wright-Fisher infinite-alleles drift model.  Employs the approximation from
#' Ewens 1972, Equation 4, and performs a simple numerical integration.  The approximation
#' is good enough to match the value from Mathematica 9/10.
#'
#' @param n population size
#' @param theta scaled innovation rate
#' @return expected_k
#' @export

expected_k_pop <- function(n, theta) {

  expected_k_pop_integrand <- function(x) {(1/x) * ((1 - x)^(theta - 1))}

  tmp <- integrate(expected_k_pop_integrand, lower=1/n, upper=1)$value
  e_k <- tmp * theta
  e_k
}