# 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")


#Basic R script to find which zip codes in the United States are most similar to
# the one specified. Make sure to call the zip code when you call the function
# e.g. "Rscript similar_zip.r 94305" - it will print a list of the 15 most similar
# zips. Similarity is based on a slight variant of the chi-squared distance.
# Also edit the working directory.

zip_data = "zipcode_data.csv"
args<-commandArgs(TRUE)
library(haven)
setwd("Insert yours here")

zips_df <- read.csv(zip_data)

#read in zip; clean zips starting with 0
#not handling misspecified arguments for now
zip <- args[1]
while (identical(substr(zip, 0, 1), "0")) {
    zip <- substr(zip, 2, nchar(zip))
}

"Compute chi-square distance between each zip code and the specified one.

zip: single zip code data we want to compute distances from
df: full array of zip code data

Uses a chi-square-esque distance, where the distance for each demographic value is weighted
by the inverse of the population-wide percentage of that demographic. That is, for each
demographic j (e.g. Doctorate degree), zip codes x and y, and total population size N,
we compute Xj = (N / c_j) (x_j - y_j)^2, where c_j is the count of demographic j across
all zip codes. We return the square root of the sum of sum Xj for each demographic
category j."
get_nearest_zips <- function(zip, df, n) {
    #get data affiliated with this zip code
    zip_demogs <- df[match(zip, df$Zipcode), ]
    zip_demogs <- sapply(zip_demogs, as.numeric)

    #size of the entire population
    total_pop <- sum(df$Male + df$Female)
    #c is a row - country-wide percentage of each demographic
    c <- colSums(df[]) / total_pop
    #get the euclidean distance, segmented by demographic segment
    dists <- sweep(as.matrix(df), 2, zip_demogs, FUN='-') ^ 2
    #subset to remove zipcode, not relevant for distance computation
    dists <- subset(dists, select=-Zipcode)
    #for each demographic segment, weight it by the country-wide size of that demographic
    #remove zipcode from c as well
    dists <- sweep(dists, 2, c[2:length(c)], FUN='/')
    #then sum and square root across the demographic segments to get the final distance
    #only consider column 2 onwards since zip code number itself is irrelevant
    df$total_dists <- rowSums(dists) ^ 0.5

    #then, sort by the distance
    sorted <- df[order(df$total_dists), 'Zipcode']
    #exclude 1st because that will be the input zipcode with distance 0
    return(sorted[2:n+1])
}

nearest_zips <- get_nearest_zips(zip, zips_df, 15)
print("Nearest zips in ascending order. ")
print(nearest_zips)


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     17.10.2019
#modificado: 06.11.2019

setwd("2019/2019.08.13_formacao_RCD2019/bin/")
library("tidyverse")
library("modelr")

##1. Modelling example
library("hexbin")

#1.1.
diamonds2 <- diamonds %>%
  filter((x > 0) & (y > 0 & y < 20) & (z > 0 & z < 10)) %>%
  filter(carat <= 2.5) %>%
  select(carat,cut,color,clarity,price) %>%
  mutate(lprice = log(price), lcarat = log(carat))

diamonds_mod <- lm(lprice ~ lcarat,data=diamonds2)
diamonds2 <- diamonds2 %>%
  add_predictions(diamonds_mod,"lpred") %>%
  add_residuals(diamonds_mod,"lresid") %>%
  mutate(pred = exp(lpred))

diamonds_mod2 <- lm(lprice ~ lcarat + clarity + cut,data=diamonds2)
diamonds2 <- diamonds2 %>%
  add_predictions(diamonds_mod2,"lpred2") %>%
  add_residuals(diamonds_mod2,"lresid2") %>%
  mutate(pred2 = exp(lpred2))

diamonds_mod3 <- lm(lprice ~ lcarat + clarity + cut + color,data=diamonds2)
diamonds2 <- diamonds2 %>%
  add_predictions(diamonds_mod3,"lpred3") %>%
  add_residuals(diamonds_mod3,"lresid3") %>%
  mutate(pred3 = exp(lpred3))

#1.2.
summary(diamonds_mod)
summary(diamonds_mod2)
summary(diamonds_mod3)

#1.3.
diamonds2 %>%
  ggplot() +
    geom_point(aes(pred,price),size=2,color="grey30") +
    geom_abline(aes(intercept=0,slope=1),size=1,color="white")

diamonds2 %>%
  ggplot() +
    geom_point(aes(pred2,price),size=2,color="grey30") +
    geom_abline(aes(intercept=0,slope=1),size=1,color="white")

diamonds2 %>%
  ggplot() +
    geom_point(aes(pred3,price),size=2,color="grey30") +
    geom_abline(aes(intercept=0,slope=1),size=1,color="white")

#1.4.
diamonds2 %>%
  ggplot() +
    geom_hex(aes(lcarat,lresid),bins=50)

diamonds2 %>%
  ggplot() +
    geom_hex(aes(lcarat,lresid2),bins=50)

diamonds2 %>%
  ggplot() +
    geom_hex(aes(lcarat,lresid3),bins=50)

#observations with large residuals
diamonds2 %>%
  filter(abs(lresid3) > 1) %>%
  select(carat:price,pred3,lresid3)

#observations where observed < expected (i.e. under-priced)
diamonds2 %>%
  filter(lresid3 < 0) %>%
  select(carat:price,pred3,lresid3) %>%
  arrange(lresid3)

##2. Model Fitting

#2.1.
set.seed(12345)
real_a1 <- 4.22
real_a2 <- 2.05
x <- round(runif(n=30,min=0,max=10),digits=2)
y <- real_a1*x + real_a2 + rnorm(n=30,mean=0,sd=1)
sim1 <- tibble(x,y)

sim1_mod <- loess(y ~ x,data=sim1)

#2.2.
RMSD_loess <- sqrt(mean(sim1_mod$residuals^2))

#2.3.
sim1 <- sim1 %>%
  add_predictions(sim1_mod) %>%
  add_residuals(sim1_mod)

#2.4.
sim1 %>%
  ggplot() +
    geom_point(aes(x,y),size=2,color="grey30") +
    geom_line(aes(x,pred))

#2.5.
sim1 %>%
  ggplot() +
    geom_smooth(aes(x,y),method="loess",formula=y ~ x) +
    geom_line(aes(x,pred),color="red")

##3. Model Visualization

#3.1.
set.seed(12345)

real_a1 <- 4.22
real_a2 <- 2.05
x <- round(runif(n=30,min=0,max=10),digits=2)
y <- real_a1*x + real_a2 + rnorm(n=30,mean=0,sd=1)
sim1 <- tibble(x,y)

sim1_mod <- lm(y ~ x,data=sim1)

sim1 <- sim1 %>%
  add_predictions(sim1_mod) %>%
  add_residuals(sim1_mod)

sim1 %>%
  ggplot() +
    geom_freqpoly(aes(resid,..density..),binwidth=0.5) +
    stat_function(fun=dnorm,color="red",args=list(mean=0,sd=1))

dfnorm <- function(x,mean=0,sd=1,log=FALSE){
    dnorm(x=x,mean=mean,sd=sd,log=log) + dnorm(x=x,mean=-mean,sd=sd,log=log)
}

sim1 %>%
  ggplot() +
    geom_histogram(aes(abs(resid),..density..),boundary=0,binwidth=0.5) +
    stat_function(fun=dfnorm,color="red",args=list(mean=0,sd=1))


\name{dist_by_closeness}
\alias{dist_by_closeness}
\title{
Distance by Closeness
}
\description{
Distance by Closeness
}
\usage{
dist_by_closeness(mat)
}
\arguments{

  \item{mat}{A numeric matrix where the distance is calculated by rows.}

}
\details{
For two rows in the matrix, assume x_1, x_2, ..., x_n1 are the column index of none-zero values in row 1
and y_1, y_2, ... y_n2 are the column index for non-zero values in row 2,
the distance between the two rows based on the closeness is calculated as:

  \preformatted{
    d_closeness = sum_i sum_j(|x_i - y_j|) / (n_1*n_2)  }
}
\value{
A \code{\link[stats]{dist}} object.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
x1 = c(0, 0, 0, 0, 1, 1, 1, 0, 0, 0)
x2 = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0)
x3 = c(1, 0, 0, 0, 1, 1, 0, 0, 0, 0)
m = rbind(x1, x2, x3)
dist(m)
dist_by_closeness(m)
}


#############
## 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)
}


 ZHPEV Example Program Results

 Eigenvalues
    -4.2443 -0.6886  1.1412 13.7916

 Error estimate for the eigenvalues
        3.1E-15


#' @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
}


#' f_sigmatau
#'
#' Construct the $\Sigma_tau$ diagonal matrix
#' given the dimension $K$
#'
#' @param k dimension of the diagonal matrix
#'
#' @return $K\times K \Sigma_tau$ diagonal matix,
#'          with $\M \Sigma_\tau_{ij} = 1$ if $i\geq j$ and $0$ otherwise.
#'
f_sigmatau <- function(k) {
    sigmatau <- matrix(0L, k, k)
    sigmatau[lower.tri(sigmatau, diag = T)] <- 1
    return(sigmatau)
}

#' f_sigma
#'
#' Construct the $\Sigma$ matrix
#' given the dimension $k_\tau, K_1$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#'
#' @return $k_\tauK_1 \times k_\tauK_1 \Sigma$ diagonal block matix.
#'
f_sigma <- function(ktau, k1) {
    sigmatau <- f_sigmatau(ktau)
    return(kronecker(sigmatau, diag(k1)))
}

#' f_mate
#'
#' Construct the $E_{K_\tau}$ diagonal matrix
#' given the dimension $K_\tau$
#'
#' @param ktau dimension of the diagonal matrix
#'
#' @return $K_\tau \times K_\tau E_{K_\tau}$ diagonal matix,
#'          with $\M E_{11} = 1$ and $0$ anywhere else.
#'
f_mate <- function(ktau) {
    m_e <- matrix(0L, ktau, ktau)
    m_e[1, 1] <- 1
    return(m_e)
}

#' f_matf
#'
#' Construct the $(K_\tau-2) \times K_\tau$ $F_{K_\tau}$ matrix
#' given the dimension $K$
#'
#' @param ktau dimension of the diagonal matrix
#'
#' @return $(K_\tau-2)\times K_\tau F_{K_\tau}$,
#'          aka the first order differencing matrix,
#'          without the first row.
#'
f_matf <- function(ktau) {
    m_dif <- diff_matrix(ktau, 1)[-1, ]
    if (is.vector(m_dif)) {
        m_dif <- t(m_dif)
    }
    return(m_dif)
}

#' f_d11
#'
#' Construct the $K_{\tau}(K_1-2) \times K_{\tau}K_1$ $D_{11}$ matrix
#' given the dimension $K$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#'
#' @return $K_{\tau}(K_1-2) \times K_{\tau}K_1$ $D_{11}$ matrix
#'
f_d11 <- function(ktau, k1) {
    kronecker(f_mate(ktau), diff_matrix(k1, 2))
}

#' f_d12
#'
#' Construct the $K_{\tau}(K_1-1) \times K_{\tau}K_1$ $D_{12}$ matrix
#' given the dimension $K$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#'
#' @return $K_{\tau}(K_1-1) \times K_{\tau}K_1$ $D_{12}$ matrix
#'
f_d12 <- function(ktau, k1) {
    kronecker((diag(ktau) - f_mate(ktau)), diff_matrix(k1, 1))
}

#' f_dtau
#'
#' Construct the $K_{\tau - 2}K_1 \times K_{\tau}K_1$ $D_{\tau}$ matrix
#' given the dimension $K$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#'
#' @return $K_{\tau - 2}K_1 \times K_{\tau}K_1$ $D_{\tau}$ matrix
#'
f_dtau <- function(ktau, k1) {
    kronecker(f_matf(ktau), diag(k1))
}

#' f_mats
#'
#' Construct the $K_1K_2 \times K_1K_2$ $S$ matrix
#' given the dimension $K_1, K_2$
#'
#' @param ktau dimension of the taus
#' @param k1 dimension of the first covariate
#' @param lambdas vector of lambdas(penalty parameters)
#'
#' @return $K_{K_\tau}K_1 \timesK_{K_\tau}K_1$ $S$ matrix
#'
f_mats <- function(ktau, k1, lambdas) {
    s <- lambdas[1] * crossprod(f_dtau(ktau, k1))
    s <- s + lambdas[2] * crossprod(f_d11(ktau, k1))
    s <- s + lambdas[3] * crossprod(f_d12(ktau, k1))
    return(s)
}

#' f_matc
#'
#' Construct the $K_{K_\tau}K_1 \times $K_{K_\tau}K_1$ diagonla matrix $C$
#' given the dimension \code{v_dim}
#'
#' @param v_dim vector contain the dimension of covariates
#'             $(K_\tau, K_1, K_2, \cdots)$
#'
#' @param til_beta $K_\tauK_1\cdots$ vector of the coefficient $\tilde{\beta}$
#'
#' @return K_{K_\tau}K_1\cdots \times K_{K_\tau}K_1\cdots$ diagonal matrix $C$,
#'         with diagonal equals derivative of $\tilde{\beta}$.
#'          $\M C_{jj} = \begin{cases}
#'                      1, &\text{if } \tilde{\beta}_j=\beta_j\\
#'                       \exp(\beta_j), &\text{otherwise}.
#'                      \end{cases}$
#'
f_matc <- function(v_dim, til_beta) {
    if (prod(v_dim) != length(til_beta)) {
        print("v_dim:"); print(v_dim); print("til_beta:"); print(til_beta)
        stop("f_matc: input dimension invalid \n")
    }
    v_idx <- seq_len(v_dim[2])
    til_beta[v_idx] <- 1L
    m_c <- diag(til_beta)
    return(m_c)
}

#' f_g1
#'
#' Construct the $(K_0+m) \times (K_0+m)$ or $K \times K$ $G_1$ diagonal matrix
#' given the dimension $K = K_0 + m$
#'
#' @param k0 number of internal knots
#' @param m order of the basis splines
#'
#' @return $K\times K G_1$ diagonal matix,
#'          with $G_1_{ii} = (t_{i+m} - t_i)/m$.
#'
f_g1 <- function(k0, m) {
    h <- 1 / (1 + k0)
    v_knots <- seq_len(k0) * h
    v_knots <- c(rep(0, m), v_knots, rep(1, m))
    out <- diag(diff(x = v_knots, lag = m) / m)
    return(out)
}

#' f_g2
#'
#' Construct the $(K_0+m) \times (K_0+m)$ or $K \times K$ $G_2$ diagonal matrix
#' given the dimension $K = K_0 + m$
#'
#' @param k0 number of internal knots
#' @param m order of the basis splines
#'
#' @return $K\times K G_2$ diagonal matix,
#'          with $G_2_{ii} = (t_{i+m+1} - t_i)/m$.
#'
f_g2 <- function(k0, m) {
    out <- f_g1(k0, m + 1)
    out <- out[-1, -1]
    return(out)
}

#' f_n1
#'
#' Construct the $n \times (K_1)$ spline matrix for the first covariate
#' given the dimension $K_1 = k1 + m1$
#'
#' @param x observations for the first covariate
#' @param k1 number of internal knots
#' @param m1 order of the basis splines
#'
#'
#' @return $n \times K_1$ spline matrix for the first covariate,
#'
f_n1 <- function(x, k1, m1) {
    out <- spline_basis(x, k1, m1)
    return(out)
}

#' f_ntau
#'
#' Construct the $n \times (K_1)$ spline designfor the taus
#' given the dimension $K_\tau = k\tau + m\tau$
#'
#' @param v_tau observations for the tau
#' @param ktau number of internal knots
#' @param mtau order of the basis splines
#'
#'
#' @return $n \times K_\tau$ spline design for the taus,
#'
f_ntau <- function(v_tau, ktau, mtau) {
    spline_basis(v_tau, ktau, mtau, x_range = c(1, 0))
}

#' f_ntau
#'
#' Construct the $n \times (K_\tau)$ spline matrix $N_{\tau^*}$
#' given the dimension $K_\tau = k\tau + m\tau$
#'
#' @param taustar estimated tau for each observations
#' @param k\tau number of internal knots
#' @param m\tau order of the basis splines
#'
#' @import splines
#'
#' @return $n \times K_\tau$ intergrated spline matrix $N_{\tau^*}$
#'
f_ntaustar <- function(taustar, ktau, mtau) {
    out <- spline_basis(taustar, ktau, mtau + 1, x_range = c(1, 0))
    out <- out[, -1]
    return(out)
}


if (isVernalizable==1 and vernaprog < 1):
    tt = deltaTT
    if (tt >= minTvern and tt <= intTvern):
        vernaprog = vernaprog + vAI * tt + vBEE
    if (tt > intTvern):
        maxVernaProg = vAI * intTvern + vBEE
        dLverna = max(minDL, min(maxDL, dayLength))
        vernaprog += max(0, maxVernaProg * (1 + ((intTvern - tt) / (maxTvern - intTvern)) * ((dLverna - minDL) / (maxDL - minDL))))
    primordno = 2.0 * leafNumber + pNini
    minLeafNumber = minFinalNumber
    if (vernaprog >= 1.0 or primordno >= aMXLFNO):
        minFinalNumber = max(primordno, minFinalNumber)
        calendarMoments.append("EndVernalisation")
        calendarCumuls.append(cumulTT)
        calendarDates.append(currentdate)
        vernaprog = max(1, vernaprog)
    else:
        potlfno = aMXLFNO - (aMXLFNO - minLeafNumber) * vernaprog
        if (primordno >= potlfno):
            minFinalNumber = max((potlfno + primordno) / 2.0, minFinalNumber)
            vernaprog = max(1, vernaprog)
            calendarMoments.append("EndVernalisation")
            calendarCumuls.append(cumulTT)
            calendarDates.append(currentdate)


<<<<<<< HEAD
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health using the Gini coefficient
## Florida Charts Census Tract Mortality Data:  R Project for Statistical Computing Code Script by DrewC!

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Standard Libraries
library(tidyverse)

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis
library(pROC) # ROC tests with AUC output
library(ineq) # Gini coefficient and Lorenz curve

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_cedric = read.csv("_data/cedric_can_gini.csv") # Import dataset from _data folder
df_mungos = read.csv("_data/mungos_np_value.csv") # Import dataset from _data folder

## Join
df_bella = inner_join(df_cedric, df_mungos, by = "County")

## Verify
glimpse(df_bella)
glimpse(df_mungos)
glimpse(df_cedric)

## Export
write.csv(df_bella, "_data/bella_can_gini_np_value.csv") #clean in excel and select variable

### Step 2: Statistical Test

## Spearman's Rank for ERR
corr_err = cor.test(x = df_bella$Gini, y = df_bella$ERR, method = "spearman") # Pearson's Rank for Q->Q
print(corr_err)

## Spearman's Rank for MSPB
corr_mspb = cor.test(x = df_bella$Gini, y = df_bella$MSPB, method = "spearman") # Pearson's Rank for Q->Q
=======
#### Healthy Neighborhoods Project: Using Ecological Data to Improve Community Health
### Cedric subproject: Developing better ways to measure equity in health using the Gini coefficient
## Florida Charts Census Tract Mortality Data:  R Project for Statistical Computing Code Script by DrewC!

### Step 1: Import Libraries and Import Dataset

## Open R Terminal
R # open R in VS Code (any terminal)

## Import Standard Libraries
library(tidyverse)

## Import Machine Learning Libraries
library(randomForest) # Popular random forest package for R

## Import Statistics Libraries
library(MASS) # Stepwise inclusion model with linear and logistic options
library(psych) # Survey analysis library with factor analysis
library(GPArotation) # Rotation options for factor analysis
library(pROC) # ROC tests with AUC output
library(ineq) # Gini coefficient and Lorenz curve

## Import Data
setwd("C:/Users/drewc/GitHub/Healthy_Neighborhoods") # Set wd to project repository
df_cedric = read.csv("_data/cedric_can_gini.csv") # Import dataset from _data folder
df_mungos = read.csv("_data/mungos_np_value.csv") # Import dataset from _data folder

## Join
df_bella = inner_join(df_cedric, df_mungos, by = "County")

## Verify
glimpse(df_bella)
glimpse(df_mungos)
glimpse(df_cedric)

## Export
write.csv(df_bella, "_data/bella_can_gini_np_value.csv") #clean in excel and select variable

### Step 2: Statistical Test

## Spearman's Rank for ERR
corr_err = cor.test(x = df_bella$Gini, y = df_bella$ERR, method = "spearman") # Pearson's Rank for Q->Q
print(corr_err)

## Spearman's Rank for MSPB
corr_mspb = cor.test(x = df_bella$Gini, y = df_bella$MSPB, method = "spearman") # Pearson's Rank for Q->Q
>>>>>>> 321eaea894d29a3f212ee3e111b86695f46cf6db
print(corr_mspb)


multiplication_table <- function(n=12)
{
   one_to_n <- 1:n
   x <- matrix(one_to_n) %*% t(one_to_n)
   x[lower.tri(x)] <- 0
   rownames(x) <- colnames(x) <- one_to_n
   print(as.table(x), zero.print="")
   invisible(x)
}
multiplication_table()


# 4. faza: Analiza podatkov

podatki <- gradbeni.stroski %>% filter(TipStroska=="StroskiMateriala", Leto >= 2016) %>%
  select(-"TipStroska")

prileganje <- glm(data = podatki, Indeks ~ I(Leto) + I(Leto^2))
leta <- data.frame(Leto = 2020)
napoved <- leta %>% mutate(Indeks=predict(prileganje,.))
podatki <- podatki %>% rbind(napoved) #na stare podatke dodamo leto 2020 iz napovedi

graf_regresija <- podatki %>% ggplot(aes(x=Leto, y=Indeks)) +
  geom_point(size=3) +
  geom_smooth(method='glm', formula=y ~ poly(x,2), color='darkblue') +
  geom_point(data = napoved, aes(x = Leto, y = Indeks), color = "red", size = 3)+
  scale_x_continuous('Leto', breaks = seq(2016, 2020, 1), limits = c(2016,2020)) +
  ylab("Indeks stroškov materiala") +
  labs(title = "Napoved indeksa stroškov materiala za leto 2020") +
  theme(axis.line = element_line(colour = "black",
                                 size = 1, linetype = "solid"),
        axis.ticks = element_line(color = "red"),
        axis.ticks.length = unit(2, "mm")) +
  guides(color=FALSE) #dam stran legendo

graf_regresija

#METODA VODITELJEV

#pripravim posamezne tabele povprecji po regijah
povprecna.dokoncana <- dokoncana.stanovanja.st.in.povrsina %>%
  group_by(StatisticnaRegija) %>%
  summarise(PovprecnoSteviloZgrajenih = mean(StDokoncanihStanovanjNa1000Prebivalcev),
            PovrpecnaVelikostZgrajena_m2=mean(PovprecnaPovrsina_m2))

povprecna.gradbena.dovoljenja <- gradbena.dovoljenja.letno %>%
  group_by(StatisticnaRegija) %>%
  summarise(PovprecnoSteviloGradbenih = mean(SteviloStavb),
            PovprecnaPovrsinaGradbena_m2 = mean(Povrsina_1000m2))

povprecen.indeks.plac <- indeks.neto.plac %>%
  group_by(StatisticnaRegija) %>%
  summarise(PovprecenIndeksPlac = mean(Indeks))

povprecen.os.infra <- stanovanja.brez.os.infra %>%
  group_by(StatisticnaRegija) %>%
  summarise(PovprecenDelezInfra = mean(DelezVOdstotkih))

#skupna tabela povprecji po regijah
povprecna.regije <- povprecna.dokoncana %>%
  left_join(povprecna.gradbena.dovoljenja, by="StatisticnaRegija") %>%
  left_join(povprecen.indeks.plac, by ="StatisticnaRegija") %>%
  left_join(povprecen.os.infra, by = "StatisticnaRegija")

#tema za zemljevid
theme_map <-theme_minimal() +
    theme(
      plot.background = element_rect(fill = "#f5f5f2", color = NA),
      panel.background = element_rect(fill = "#f5f5f2", color = NA),
      axis.title=element_blank(),
      axis.text=element_blank(),
      axis.ticks=element_blank(),
      panel.grid.major = element_line(color = "#ebebe5", size = 0.2)
    )

#modelacija podatkov
data.norm <- povprecna.regije %>% .[c(2,3,4,5,6,7)] %>% scale() #normalizirani podatki
rownames(data.norm) <- povprecna.regije$StatisticnaRegija

k <- kmeans(data.norm, 5, nstart=1000) #v koliko skupin jih damo

skupine <- data.frame(StatisticnaRegija=povprecna.regije$StatisticnaRegija,
                      skupina=factor(k$cluster))

#narisemo zemljevid
map.data <- right_join(skupine, Slovenija, by = "StatisticnaRegija")
zemljevid.napredna.analiza <- ggplot(map.data) +
  geom_polygon(aes(x = long, y = lat, group = group, fill = skupina)) +
  geom_path(aes(x = long, y = lat, group = group),
            color = "white", size = 0.1) +
  labs(fill="Skupine regij", title="Gručenje regij s podobnimi lastnostmi") +
  scale_fill_brewer(palette="Paired") +
  theme_map


#To find Row and coloumn Index of maximum and minimum value in a given matrix
vector = c(20:28)
final = matrix(vector,nrow = 3,ncol =3, byrow = T)
print(final)
min_index_value = which(final == min(final))
max_index_value = which(final == max(final))
cat("minimum value index",min_index_value,"\n")
cat("maximum value index",max_index_value)


# MIT License
# Copyright (c) 2020 Abhinav Prakash, Vijay Panchang, Yu Ding, and Lewis Ntaimo

# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

source("function.r")
input_file = "assunpink.csv"
output_file = "assunpink"
data_col = 3
year_col = 1
col_names = T
CSVFile = read.csv(file = input_file, header = col_names)
Data = CSVFile[,data_col]
Year = CSVFile[,year_col]
referenceyear = 2018
time_index = time.index(Year,referenceyear)
lmfit = lm(Data~time_index)
mu0.int = lmfit$coefficients[1]
mu1.int = abs(lmfit$coefficients[2])
scale.int = sd(Data)
set.seed(2)
shape.int = runif(1,-1,1)
k = 0
llf = function(x) {
    k =(1 + (x[4]*(Data-(x[1]+(x[2]*time_index)))/x[3]))^(-1/x[4])
    pdf = (1/x[3])*((k)^(x[4]+1))*exp(-k)
    -sum(log(pdf))
}
result = try(
    expr =  optim(par = c(mu0.int,mu1.int,scale.int,shape.int), method = "L-BFGS-B", fn = llf, lower = c(0,0,0,-Inf)), silent = TRUE
)
while (class(result) == "try-error"){
    k = k+1
    shape.int = runif(1,-1,1)
    result = try(
      expr =  optim(par = c(mu0.int,mu1.int,scale.int,shape.int), method = "L-BFGS-B", fn = llf, lower = c(0,0,0,-Inf)), silent = TRUE
    )
  }
  mu0 = result$par[1]
  mu1 = result$par[2]
  scale = result$par[3]
  shape = result$par[4]
  NLLH = result$value

  retevent = calc.nstat.ret.event(mu0,mu1,scale,shape,100,baseyear = referenceyear,analysisyear = referenceyear,1)

cat('Maximum Likelihood Estimation (Constrained)','\n')
cat('mu0 = ',mu0,'mu1 = ',mu1,'scale = ',scale,'shape = ',shape,'100yr return event = ',retevent,"NLLH =",NLLH,'\n')


graphics.off() # This closes all of R's graphics windows.
rm(list=ls())  # Careful! This clears all of R's memory!
library(ggplot2)
library(ggpubr)
library(ks)
library(rjags)
library(runjags)
setwd("~/Documents/MATH2269_Bayesian/2020/presentations/Module 6/Application2")
source("DBDA2E-utilities.R")

#===============PRELIMINARY FUNCTIONS FOR POSTERIOR INFERENCES====================

smryMCMC_HD = function(  codaSamples , compVal = NULL,  saveName=NULL) {
  summaryInfo = NULL
  mcmcMat = as.matrix(codaSamples,chains=TRUE)
  paramName = colnames(mcmcMat)
  for ( pName in paramName ) {
    if (pName %in% colnames(compVal)){
      if (!is.na(compVal[pName])) {
        summaryInfo = rbind( summaryInfo , summarizePost( paramSampleVec = mcmcMat[,pName] ,
                                                          compVal = as.numeric(compVal[pName]) ))
      }
      else {
        summaryInfo = rbind( summaryInfo , summarizePost( paramSampleVec = mcmcMat[,pName] ) )
      }
    } else {
      summaryInfo = rbind( summaryInfo , summarizePost( paramSampleVec = mcmcMat[,pName] ) )
    }
  }
  rownames(summaryInfo) = paramName

  # summaryInfo = rbind( summaryInfo ,
  #                      "tau" = summarizePost( mcmcMat[,"tau"] ) )
  if ( !is.null(saveName) ) {
    write.csv( summaryInfo , file=paste(saveName,"SummaryInfo.csv",sep="") )
  }
  return( summaryInfo )
}

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

plotMCMC_HD = function( codaSamples , data , xName="x" , yName="y" ,
                        showCurve=FALSE ,  pairsPlot=FALSE , compVal = NULL,
                        saveName=NULL , saveType="jpg" ) {
  # showCurve is TRUE or FALSE and indicates whether the posterior should
  #   be displayed as a histogram (by default) or by an approximate curve.
  # pairsPlot is TRUE or FALSE and indicates whether scatterplots of pairs
  #   of parameters should be displayed.
  #-----------------------------------------------------------------------------
  y = data[,yName]
  x = as.matrix(data[,xName])
  mcmcMat = as.matrix(codaSamples,chains=TRUE)
  chainLength = NROW( mcmcMat )
  zbeta0 = mcmcMat[,"zbeta0"]
  zbeta  = mcmcMat[,grep("^zbeta$|^zbeta\\[",colnames(mcmcMat))]
  if ( ncol(x)==1 ) { zbeta = matrix( zbeta , ncol=1 ) }
  zVar = mcmcMat[,"zVar"]
  beta0 = mcmcMat[,"beta0"]
  beta  = mcmcMat[,grep("^beta$|^beta\\[",colnames(mcmcMat))]
  if ( ncol(x)==1 ) { beta = matrix( beta , ncol=1 ) }
  tau = mcmcMat[,"tau"]
  pred1 = mcmcMat[,"pred[1]"] # Added by Demirhan
  pred2 = mcmcMat[,"pred[2]"] # Added by Demirhan
  pred3 = mcmcMat[,"pred[3]"] # Added by Demirhan
  pred4 = mcmcMat[,"pred[4]"] # Added by Demirhan
  pred5 = mcmcMat[,"pred[5]"] # Added by Demirhan

  #-----------------------------------------------------------------------------
  # Compute R^2 for credible parameters:
  YcorX = cor( y , x ) # correlation of y with each x predictor
  Rsq = zbeta %*% matrix( YcorX , ncol=1 )
  #-----------------------------------------------------------------------------
  if ( pairsPlot ) {
    # Plot the parameters pairwise, to see correlations:
    openGraph()
    nPtToPlot = 1000
    plotIdx = floor(seq(1,chainLength,by=chainLength/nPtToPlot))
    panel.cor = function(x, y, digits=2, prefix="", cex.cor, ...) {
      usr = par("usr"); on.exit(par(usr))
      par(usr = c(0, 1, 0, 1))
      r = (cor(x, y))
      txt = format(c(r, 0.123456789), digits=digits)[1]
      txt = paste(prefix, txt, sep="")
      if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt)
      text(0.5, 0.5, txt, cex=1.25 ) # was cex=cex.cor*r
    }
    pairs( cbind( beta0 , beta , tau )[plotIdx,] ,
           labels=c( "beta[0]" ,
                     paste0("beta[",1:ncol(beta),"]\n",xName) ,
                     expression(tau) ) ,
           lower.panel=panel.cor , col="skyblue" )
    if ( !is.null(saveName) ) {
      saveGraph( file=paste(saveName,"PostPairs",sep=""), type=saveType)
    }
  }
  #-----------------------------------------------------------------------------
  # Marginal histograms:

  decideOpenGraph = function( panelCount , saveName , finished=FALSE ,
                              nRow=2 , nCol=3 ) {
    # If finishing a set:
    if ( finished==TRUE ) {
      if ( !is.null(saveName) ) {
        saveGraph( file=paste0(saveName,ceiling((panelCount-1)/(nRow*nCol))),
                   type=saveType)
      }
      panelCount = 1 # re-set panelCount
      return(panelCount)
    } else {
      # If this is first panel of a graph:
      if ( ( panelCount %% (nRow*nCol) ) == 1 ) {
        # If previous graph was open, save previous one:
        if ( panelCount>1 & !is.null(saveName) ) {
          saveGraph( file=paste0(saveName,(panelCount%/%(nRow*nCol))),
                     type=saveType)
        }
        # Open new graph
        openGraph(width=nCol*7.0/3,height=nRow*2.0)
        layout( matrix( 1:(nRow*nCol) , nrow=nRow, byrow=TRUE ) )
        par( mar=c(4,4,2.5,0.5) , mgp=c(2.5,0.7,0) )
      }
      # Increment and return panel count:
      panelCount = panelCount+1
      return(panelCount)
    }
  }

  # Original scale:
  panelCount = 1
  if (!is.na(compVal["beta0"])){
    panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMarg") )
    histInfo = plotPost( beta0 , cex.lab = 1.75 , showCurve=showCurve ,
                         xlab=bquote(beta[0]) , main="Intercept", compVal = as.numeric(compVal["beta0"] ))
  } else {
    histInfo = plotPost( beta0 , cex.lab = 1.75 , showCurve=showCurve ,
                         xlab=bquote(beta[0]) , main="Intercept")
  }
  for ( bIdx in 1:ncol(beta) ) {
    panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMarg") )
    if (!is.na(compVal[paste0("beta[",bIdx,"]")])) {
      histInfo = plotPost( beta[,bIdx] , cex.lab = 1.75 , showCurve=showCurve ,
                           xlab=bquote(beta[.(bIdx)]) , main=xName[bIdx],
                           compVal = as.numeric(compVal[paste0("beta[",bIdx,"]")]))
    } else{
      histInfo = plotPost( beta[,bIdx] , cex.lab = 1.75 , showCurve=showCurve ,
                           xlab=bquote(beta[.(bIdx)]) , main=xName[bIdx])
    }
  }
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( tau , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(tau) , main=paste("Scale") )
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( Rsq , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(R^2) , main=paste("Prop Var Accntd") )
  panelCount = decideOpenGraph( panelCount ,  saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred1 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred1" , main="Prediction 1" ) # Added by Demirhan
  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred2 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred2" , main="Prediction 2" ) # Added by Demirhan

  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred3 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred2" , main="Prediction 2" ) # Added by Demirhan

  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred4 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred2" , main="Prediction 2" ) # Added by Demirhan

  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMarg") )
  histInfo = plotPost( pred5 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab="pred2" , main="Prediction 2" ) # Added by Demirhan

  # Standardized scale:
  panelCount = 1
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMargZ") )
  histInfo = plotPost( zbeta0 , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(z*beta[0]) , main="Intercept" )
  for ( bIdx in 1:ncol(beta) ) {
    panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMargZ") )
    histInfo = plotPost( zbeta[,bIdx] , cex.lab = 1.75 , showCurve=showCurve ,
                         xlab=bquote(z*beta[.(bIdx)]) , main=xName[bIdx] )
  }
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMargZ") )
  histInfo = plotPost( zVar , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(z*tau) , main=paste("Scale") )
  panelCount = decideOpenGraph( panelCount , saveName=paste0(saveName,"PostMargZ") )
  histInfo = plotPost( Rsq , cex.lab = 1.75 , showCurve=showCurve ,
                       xlab=bquote(R^2) , main=paste("Prop Var Accntd") )
  panelCount = decideOpenGraph( panelCount , finished=TRUE , saveName=paste0(saveName,"PostMargZ") )

  #-----------------------------------------------------------------------------
}

#===============PRELIMINARY FUNCTIONS FOR POSTERIOR INFERENCES====================

myData <- read.csv("Assignment2PropertyPrices.csv")
head(myData)

# Scatter plots
p1 <- ggplot(myData, aes(x=Area, y=SalePrice.100K.)) +
  geom_point() +
  xlab("Area") +
  ylab("SalePrice.100K.")

p2 <- ggplot(myData, aes(x=Bedrooms, y=SalePrice.100K.)) +
  geom_point() +
  xlab("Bedrooms") +
  ylab("SalePrice.100K.")

p3 <- ggplot(myData, aes(x=Bathrooms, y=SalePrice.100K.)) +
  geom_point() +
  xlab("Bathrooms") +
  ylab("SalePrice.100K.")

p4 <- ggplot(myData, aes(x=CarParks, y=SalePrice.100K.)) +
  geom_point() +
  xlab("CarParks") +
  ylab("SalePrice.100K.")

p5 <- ggplot(myData, aes(x=PropertyType, y=SalePrice.100K.)) +
  geom_point() +
  xlab("PropertyType") +
  ylab("SalePrice.100K.")

figure <- ggarrange(p1, p2, p3, p4, p5, nrow = 2, ncol = 3)
figure

# Histogram
hist(myData$SalePrice.100K., main= " Histogram of the dependent variable", xlab = "Cost")
# Kernel density estimation
plot(kde(myData$SalePrice.100K.), xlab = "Cost") # with default settings

# THE DATA.
y = myData[,"Y"]
x = as.matrix(myData[,c("X1","X2","X3","X4","X5")])

# Some more descriptives
cat("\nCORRELATION MATRIX OF PREDICTORS:\n ")
show( round(cor(x),3) )
cat("\n")

xPred = array(NA, dim = c(5,5))
xPred[1,] = c(600, 2, 2, 1, 1)
xPred[2,] = c(800, 3, 1, 2, 0)
xPred[3,] = c(1500, 2, 1, 1, 0)
xPred[4,] = c(2500, 5, 4, 4, 0)
xPred[5,] = c(250, 3, 2, 1, 1)

# Specify the data in a list, for later shipment to JAGS:
dataList <- list(
  x = x ,
  y = y ,
  xPred = xPred ,
  Nx = dim(x)[2] ,
  Ntotal = dim(x)[1]
)

# First run without initials!
initsList <- list(
  zbeta0 = 2000,
  zbeta = c(0.009, 1, 1, 1.2, -1.5),
  Var = 12000000
)

# WE WILL RUN THE MODEL WITH SCALING!

# THE MODEL.
modelString = "
# Standardize the data:
data {
  ysd <- sd(y)
  for ( i in 1:Ntotal ) {
    zy[i] <- y[i] / ysd
  }
  for ( j in 1:Nx ) {
    xsd[j] <-   sd(x[,j])
    for ( i in 1:Ntotal ) {
      zx[i,j] <- x[i,j] / xsd[j]
    }
  }
}
# Specify the model for scaled data:
model {
  for ( i in 1:Ntotal ) {
    zy[i] ~ dgamma( (mu[i]^2)/zVar , mu[i]/zVar )
    mu[i] <- zbeta0 + sum( zbeta[1:Nx] * zx[i,1:Nx] )
  }
  # Priors on standardized scale:
  zbeta0 ~ dnorm( 0 , 1/2^2 )  # 1/ variance for normal distribution
  zbeta[1] ~ dnorm( 0.0009/xsd[1] , 1/(0.01/xsd[1]^2) ) # 1/ variance for normal distribution
  zbeta[2] ~ dnorm( 1 , 1/(2/xsd[2]^2) ) ) # 1/ variance for normal distribution
  zbeta[3] ~ dnorm( 0 , 1/4 ) # 1/ variance for normal distribution
  zbeta[4] ~ dnorm( (1.2)/xsd[4] , 1/(0.1/xsd[4]^2) ) # 1/ variance for normal distribution
  zbeta[5] ~ dnorm( (-1.5)/xsd[5] , 1/(0.01/xsd[5]^2) ) # 1/ variance for normal distribution
  zVar ~ dgamma( 0.01 , 0.01 )
  # Transform to original scale:
  beta[1:Nx] <- ( zbeta[1:Nx] / xsd[1:Nx] ) * ysd
  beta0 <- zbeta0*ysd
  tau <- zVar * (ysd)^2

  # Compute predictions at every step of the MCMC
  for ( i in 1:5){
    pred[i] <- beta0 + beta[1] * xPred[i,1] + beta[2] * xPred[i,2] + beta[3] * xPred[i,3] + beta[4] * xPred[i,4] + beta[5] * xPred[i,5]
  }
  # pred[1] <- beta0 + beta[1] * xPred[1,1] + beta[2] * xPred[1,2] + beta[3] * xPred[1,3] + beta[4] * xPred[1,4]
  # pred[2] <- beta0 + beta[1] * xPred[2,1] + beta[2] * xPred[2,2] + beta[3] * xPred[2,3] + beta[4] * xPred[2,4]

}
" # close quote for modelString
# Write out modelString to a text file
writeLines( modelString , con="TEMPmodel_Assignment2.txt" )

parameters = c( "zbeta0" ,  "zbeta" , "beta0" ,  "beta" ,  "tau", "zVar") # Here beta is a vector!

adaptSteps = 1500  # Number of steps to "tune" the samplers
burnInSteps = 5000
nChains = 3
thinSteps = 40 # First run for 3
numSavedSteps = 10000
nIter = ceiling( ( numSavedSteps * thinSteps ) / nChains )

# Parallel run
runJagsOut <- run.jags( method="parallel" ,
                        model="TEMPmodel_Assignment2.txt" ,
                        monitor=c( "zbeta0" ,  "zbeta" , "beta0" ,  "beta" ,  "tau", "zVar", "pred")  ,
                        data=dataList ,
                        inits=initsList ,
                        n.chains=nChains ,
                        adapt=adaptSteps ,
                        burnin=burnInSteps ,
                        sample=numSavedSteps ,
                        thin=thinSteps , summarise=FALSE , plots=FALSE )
codaSamples = as.mcmc.list( runJagsOut )

# save.image(file="rEnvironment.RData")
#load(file="rEnvironment.RData") # Load the results with 124,000 iterations

diagMCMC( codaSamples , parName="beta0" )
diagMCMC( codaSamples , parName="beta[1]" )
diagMCMC( codaSamples , parName="beta[2]" )
diagMCMC( codaSamples , parName="beta[3]" )
diagMCMC( codaSamples , parName="beta[4]" )
diagMCMC( codaSamples , parName="beta[5]" )
diagMCMC( codaSamples , parName="tau" )
diagMCMC( codaSamples , parName="pred[1]" )
diagMCMC( codaSamples , parName="pred[2]" )
diagMCMC( codaSamples , parName="pred[3]" )
diagMCMC( codaSamples , parName="pred[4]" )
diagMCMC( codaSamples , parName="pred[5]" )
diagMCMC( codaSamples , parName="zbeta0" )
diagMCMC( codaSamples , parName="zbeta[1]" )

compVal <- data.frame("beta0" = NA, "beta[1]" = NA, "beta[2]" = NA, "beta[3]" = NA, "beta[4]" =  NA, "tau" = NA , check.names=FALSE)

summaryInfo <- smryMCMC_HD( codaSamples = codaSamples , compVal = compVal )
print(summaryInfo)

plotMCMC_HD( codaSamples = codaSamples , data = myData, xName=c("X1","X2","X3","X4") ,
             yName="Y", compVal = compVal)

# ============ Predictive check ============
coefficients <- summaryInfo[7:11,3] # Get the model coefficients out
Variance <- summaryInfo[12,3] # Get the variance out
# Since we imposed the regression model on the mean of the gamma likelihood,
# we use the model (X*beta) to generate the mean of gamma population for each
# observed x vector.
meanGamma <- as.matrix(cbind(rep(1,nrow(x)),  x)) %*% as.vector(coefficients)
# Generate random data from the posterior distribution. Here I take the
# reparameterisation back to alpha and beta.
randomData <- rgamma(n= 10000,shape=meanGamma^2/Variance, rate = meanGamma/Variance)

# Display the density plot of observed data and posterior distribution:
predicted <- data.frame(elapsed = randomData)
observed <- data.frame(elapsed = y)
predicted$type <- "Predicted"
observed$type <- "Observed"
dataPred <- rbind(predicted, observed)

ggplot(dataPred, aes(elapsed, fill = type)) + geom_density(alpha = 0.2)


#EC581 Assignment #1
#Mustafa Kutay Yabas
library(zoo)
library(Quandl)
library(quantmod)

#get data from Quandl in zoo format
data_xu100 = Quandl("GOOG/INDEXIST_XU100", api_key="XXX", start_date="2003-07-01", type="zoo")

head(data_xu100)
tail(data_xu100)

Price<-data_xu100$Close
plot(Price)

#log returns
Return<-vector(length=length(Price)-1)
for (i in 2:length(Price)) {
  Return[i-1] <- (log( Price[[i]]/Price[[i-1]] ))
}

#log returns alternative method
#Return<-diff(log(Price), lag=1)

summary(Price)

#histogram of log returns
histogram = hist(Return)

#daily average return
daily_average_return = mean(Return) # %0.06

#average annualized return
annualized_return = ( ((daily_average_return+1)^220) - 1  ) * 100 # %14.44

# t-test function
ttest<-function(x1,x2) {
  s1<-var(x1)
  s2<-var(x2)
  n1<-length(x1)
  n2<-length(x2)
  mu1<-mean(x1)
  mu2<-mean(x2)

  st <- ( (n1-1)*s1 + (n2-1)*s2 ) / ( (n1-1) + (n2-1) )
  t <- (mu1 - mu2) / ( sqrt(st) * sqrt( 1/n1 + 1/n2 ) )
  return(t)

}

#Simulate random asset price to compare with Price
Test<-vector(length = length(Price))
Test[1]<-rnorm(1)/100
for (i in 2:length(Test)) {
  Test[i]<-0.9*Test[i-1]+rnorm(1)/100
}
Test<-exp(cumsum(Test))

#Now make the t-test
result_ttest = ttest(Price,Test)


test.ll <- function()
{
    checkEqualsNumeric(ll(1,1), 0)
    checkEqualsNumeric(ll(1,0), Inf)
    checkEqualsNumeric(ll(0,1), Inf)
    checkEqualsNumeric(ll(1,0.5), -log(0.5))
}

test.logLoss <- function()
{
    checkEqualsNumeric(logLoss(c(1,1,0,0),c(1,1,0,0)), 0)
    checkEqualsNumeric(logLoss(c(1,1,0,0),c(1,1,1,0)), Inf)
    checkEqualsNumeric(logLoss(c(1,1,1,0,0,0),c(.5,.1,.01,.9,.75,.001)), 1.881797068998267)
}


 ## prediction equation is
 #y=25.0+1.5*x1+0.8*x2
Y <- matrix(c(25,19,33,23),4,1)
X <- matrix(c(1,1,1,1,-2,-2,2,2,5,-5,5,-5),4,3)
transpose_X=t(X)
transpose_X_X=transpose_X%*%X
inverse_transpose_X_X=solve(transpose_X_X)
inverse_transpose_X_X
# for  estimated standard error use inverse_trasnpose_X_X matrix
s_beta0=2*sqrt(0.25)
s_beta0
s_beta1=2*sqrt(0.0625)
s_beta2=2*sqrt(0.01)
s_beta1
s_beta2


setwd('C:\\temp\\CryptoHistory\\Analytics')

library(quantmod);
library(forecast)
library(tseries)

setSymbolLookup(
  KrakenBtcUsd  = list(src="csv"),
  KrakenEthUsd  = list(src="csv"),
  KrakenEosEth  = list(src="csv"),
  KrakenBchUsd  = list(src="csv"),
    format="yyyy-MM-ddTHH:mm:ss.fffZ");

KrakenBtcUsd <-  getSymbols("KrakenBtcUsd", auto.assign=FALSE);
KrakenEthUsd <-  getSymbols("KrakenEthUsd", auto.assign=FALSE);
KrakenEosEth <-  getSymbols("KrakenEosEth", auto.assign=FALSE);

KrakenBchUsd <-  getSymbols("KrakenBchUsd", auto.assign=FALSE);

chartSeriesTA <- function(symb){
  chartSeries(symb, subset='last 30 days',
              TA=c(
                addVo(),
                addSMA(),
                addEMA(),
                addMACD(),
                addRSI(),
                addSMI(),
                addBBands())
  );
  addTA(ZigZag(symb[,2:3],5),on=1);
}

chartSeriesTA(KrakenBtcUsd)
chartSeriesTA(KrakenEthUsd)
chartSeriesTA(KrakenEosEth)

tsLimit <- 620;

KrakenBtcUsdOpenPrices <- tail(
    coredata(
        Op(KrakenBtcUsd)
      ),tsLimit
    );

KrakenEthUsdOpenPrices <- tail(
  coredata(
    Op(KrakenEthUsd)
  ),tsLimit
);

KrakenEosEthOpenPrices <- tail(
  coredata(
    Op(KrakenEosEth)
  ),tsLimit
);

KrakenBchUsdOpenPrices <- tail(
  coredata(
    Op(KrakenBchUsd)
  ),tsLimit
);

cor(KrakenBtcUsdOpenPrices, KrakenEthUsdOpenPrices, method = c("pearson", "kendall", "spearman"))
cor.test(KrakenBtcUsdOpenPrices, KrakenEthUsdOpenPrices, method=c("pearson", "kendall", "spearman"))

cor(KrakenEthUsdOpenPrices, KrakenEosEthOpenPrices,  method = c("pearson", "kendall", "spearman"))
cor.test(KrakenEthUsdOpenPrices, KrakenEosEthOpenPrices, method=c("pearson", "kendall", "spearman"))

#cor(KrakenBtcUsdOpenPrices, KrakenEosEthOpenPrices,  method = c("pearson", "kendall", "spearman"))
#cor.test(KrakenBtcUsdOpenPrices, KrakenEosEthOpenPrices, method=c("pearson", "kendall", "spearman"))

cor(KrakenBtcUsdOpenPrices, KrakenBchUsdOpenPrices, method = c("pearson", "kendall", "spearman"))
cor.test(KrakenBtcUsdOpenPrices, KrakenBchUsdOpenPrices, method=c("pearson", "kendall", "spearman"))


subroutine circen(i,j,k,x0,y0,x,y,ntot,eps,collin,nerror)
# Find the circumcentre (x0,y0) of the triangle with
# vertices (x(i),y(i)), (x(j),y(j)), (x(k),y(k)).
# Called by qtest1, dirseg, dirout.

implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3)
logical collin

nerror = -1

# Get the coordinates.
xt(1) = x(i)
yt(1) = y(i)
xt(2) = x(j)
yt(2) = y(j)
xt(3) = x(k)
yt(3) = y(k)

# Check for collinearity
ijk = 0
call cross(xt,yt,ijk,cprd)
if(abs(cprd) < eps) collin = .true.
else collin = .false.

# Form the vector u from i to j, and the vector v from i to k,
# and normalize them.
a  = x(j) - x(i)
b  = y(j) - y(i)
c  = x(k) - x(i)
d  = y(k) - y(i)
c1 = sqrt(a*a+b*b)
c2 = sqrt(c*c+d*d)
a  = a/c1
b  = b/c1
c  = c/c2
d  = d/c2

# If the points are collinear, make sure that they're in the right
# order --- i between j and k.
if(collin) {
        alpha = a*c+b*d
        # If they're not in the right order, bring things to
        # a shuddering halt.
        if(alpha>0) {
		nerror = 3
		return
        }
        # Collinear, but in the right order; think of this as meaning
        # that the circumcircle in question has infinite radius.
        return
}

# Not collinear; go ahead, make my circumcentre.  (First, form
# the cross product of the ***unit*** vectors, instead of the
# ``normalized'' cross product produced by ``cross''.)
crss = a*d - b*c
x0 = x(i) + 0.5*(c1*d - c2*b)/crss
y0 = y(i) + 0.5*(c2*a - c1*c)/crss

return
end


BHData <- read.table(url("https://archive.ics.uci.edu/ml/machine-learning-databases/housing/housing.data"), sep = "")
names(BHData)<- c("crim","zn","indus","chas","nox","rm","age","dis",
                  "rad","tax","ptratio","black","lstat","medv")

str(BHData)
summary(BHData)

max_data <- apply(BHData, 2, max)
min_data <- apply(BHData, 2, min)

BHDataScaled <- as.data.frame(scale(BHData,center = min_data, scale = max_data - min_data))
summary(BHDataScaled)

boxplot(BHDataScaled)

CorBHData<-cor(BHDataScaled)

library(corrplot)

corrplot(CorBHData, method = "pie",tl.cex=0.4,cl.cex=0.4,type="lower")

LModel1<-lm(medv~.,data=BHDataScaled)
LModel1

summary(LModel1)

Pred1 <- predict(LModel1)
mse1 <- mean((BHDataScaled$medv - Pred1)^2)
mse1

plot(BHDataScaled[,14],Pred1,
     xlab="Actual",ylab="Predicted")
abline(a=0,b=1)

par(mfrow=c(2,2))
plot(LModel1)

library(randomForest)
RFModel=randomForest(medv ~ . , data = BHDataScaled)
RFModel
summary(RFModel)

par(mfrow=c(1,1))
plot(RFModel)

VarImp<-importance(RFModel)
VarImp<-as.matrix(VarImp[order(VarImp[,1], decreasing = TRUE),])
VarImp

varImpPlot(RFModel)

Pred2<-predict(RFModel)

plot(BHDataScaled[,14],Pred2,
     xlab="Actual",ylab="Predicted")
abline(a=0,b=1)


Airquality<-as.data.frame(airquality)
summary(Airquality)

Airquality<-na.omit(Airquality)

max_data <- apply(Airquality, 2, max)
min_data <- apply(Airquality, 2, min)
data_scaled1 <- scale(Airquality,center = min_data, scale = max_data - min_data)
summary(data_scaled1)

mean_data <- apply(Airquality, 2, mean)
sd_data <- apply(Airquality, 2, sd)
data_scaled2 <- scale(Airquality,center = mean_data, scale = sd_data)
summary(data_scaled2)

SDdata_scaled2<-apply(data_scaled2,2,sd)
SDdata_scaled2


library(deSolve)
library(tidyr)
library(reshape)
library(magrittr)
library(plyr)
library(dplyr)
library(ggplot2)

m <- 4  #number of age classes
mu <- c(0,0,0,1/(55*365)) #death rate in each age group; it is assumed that only adults die
nu <- c(1/(55*365),0,0,0) #is the birth rate into the childhood class; it is assumed only adults give birth.
n <- c(6,4,10,55)/75 # fraction in each age class (assumption that life expectancy is 75 years)
S0 <- c(0.05,0.01,0.01,0.008) # inital value for number of susceptible
E0 <- c(0.0001,0.0001,0.0001,0.0001) # inital value for number of exposed
I0 <- c(0.0001,0.0001,0.0001,0.0001) # inital value for number of infectious
R0 <- c(0.0298, 0.04313333, 0.12313333, 0.72513333) # inital value for number of recovered
ND <- 365 # time to simulate
beta <- matrix(c(2.089, 2.089, 2.086, 2.037, 2.089, 9.336, 2.086, 2.037, 2.086, 2.086,
                 2.086, 2.037, 2.037, 2.037, 2.037, 2.037), nrow=4, ncol=4) # matrix of transmission rates
gamma <- 1/5 # recovery rate
sigma <- 1/8 # rate at which individuals move from the exposed to the infectious classes
TS <- 1 # time step to simualte is days

# combining parameter and initial values
parms <- list(nu=nu, beta=beta, mu=mu, sigma=sigma, gamma=gamma)
INPUT <- c(S0, E0, I0, R0)

# constructing time vector
t_start <- 0 # starting time
t_end <- ND - 1 # ending time
t_inc <- TS #time increment
t_range <- seq(from= t_start, to=t_end+t_inc, by=t_inc) # vector with time steps

# differential equations
diff_eqs <- function(times, Y, parms){
  dY <- numeric(length(Y))
  with(parms,{
    # creates an empty matrix
    for(i in 1:m){
      dY[i] <- nu[i]*n[4] -  beta[,i]%*%Y[2*m + seq(1:m)] * Y[i] - mu[i] * Y[i] # S_i
      dY[m+i] <-  beta[,i] %*% Y[2*m + seq(1:m)] *Y[i] - mu[i] * Y[m+i] - sigma * Y[m+i] #E_i
      dY[2*m+i] <- sigma * Y[m+i] - gamma * Y[2*m + i] - mu[i] * Y[2*m+i] #I_i
      dY[3*m+i] <- gamma * Y[2*m+i] - mu[i] * Y[3*m + i] #R_i
    }
    list(dY)
  })
}

RES2=rep(0,17) #initalizing the result vector
number_years <- 100 #set the number of years to simulate

# initialize the loop
k=1
# yearly ageing
for(k in 1:number_years) {
  RES = lsoda(INPUT, t_range, diff_eqs, parms)
  #taking the last entry as the the new input that then is propagated accoring to the aging
  INPUT=RES[366,-1]
  INPUT[16]=INPUT[16]+INPUT[15]/10
  INPUT[15]=INPUT[15]+INPUT[14]/4-INPUT[15]/10
  INPUT[14]=INPUT[14]+INPUT[13]/6-INPUT[14]/4
  INPUT[13]=INPUT[13]-INPUT[13]/6

  INPUT[12]=INPUT[12]+INPUT[11]/10
  INPUT[11]=INPUT[11]+INPUT[10]/4-INPUT[11]/10
  INPUT[10]=INPUT[10]+INPUT[9]/6-INPUT[10]/4
  INPUT[9]=INPUT[9]-INPUT[9]/6

  INPUT[8]=INPUT[8]+INPUT[7]/10
  INPUT[7]=INPUT[7]+INPUT[6]/4-INPUT[7]/10
  INPUT[6]=INPUT[6]+INPUT[5]/6-INPUT[6]/4
  INPUT[5]=INPUT[5]-INPUT[5]/6

  INPUT[4]=INPUT[4]+INPUT[3]/10
  INPUT[3]=INPUT[3]+INPUT[2]/4-INPUT[3]/10
  INPUT[2]=INPUT[2]+INPUT[1]/6-INPUT[2]/4
  INPUT[1]=INPUT[1]-INPUT[1]/6
  RES2 <- rbind(RES2,RES)
  k=k+1
}

#rescaling time to years
time <- seq(from=0, to=100*(ND+1))/(ND+1)
#changing time to the rescaled time
RES2[ ,"time"] <- time

#labeling of the output from ODE solver
label <- c("S1", "S2", "S3", "S4","E1", "E2", "E3", "E4", "I1", "I2", "I3", "I4", "R1", "R2", "R3", "R4")
label1 <- substr(label, 1, 1)
Age <- substr(label, 2, 2)

df <- data.frame(time = RES2[, 1],
                 label1 = rep(label1, each =  nrow(RES2)),
                 Age = rep(Age, each =  nrow(RES2)),
                 value = c(RES2[, -1]))

# Plot
df$label1 <- factor(df$label1, levels = c("S","E","I","R"))
df$Age <- factor(df$Age)
df %>% mutate(label1 = recode(label1, S = "Susceptible")) %>%
       mutate(label1 = recode(label1, E = "Exposed")) %>%
       mutate(label1 = recode(label1, I = "Infectious")) %>%
       mutate(label1 = recode(label1, R = "Recovered"))  %>%
       mutate(Age = recode(Age, "1" = "0-6 years ")) %>%
       mutate(Age = recode(Age, "2" = "6-10 years ")) %>%
       mutate(Age = recode(Age, "3" = "10-20 years ")) %>%
       mutate(Age = recode(Age, "4" = "20+ years ")) %>%
ggplot() +
   geom_line(aes(x = time, y = value, color = Age)) +
   facet_wrap( ~label1, ncol=1, scales =  "free_y")+
   xlab("Time (years)") + ylab(" Individuals")


#loading libraries
library (ISLR )
library(caret)
library(dplyr)
library(glmnet)
library(elasticnet)
library(DAAG)

#reading the input file
df1 <- read.csv("/Users/rajivranjan/Desktop/slump.csv", header=TRUE)
df1<-select(df1, Cement,Slag,Fly.ash,Water,SP,Coarse.Aggr.,Fine.Aggr.,FLOW.cm.)

#randomly selecting 85 Samples
smp_size1 <- floor(0.83 * nrow(df1))
set.seed(123)
train_ind1 <- sample(seq_len(nrow(df1)), size = smp_size1)

#divinding train and test data
train1 <- df1[train_ind1, ]
test1 <- df1[-train_ind1, ]

#changing the data set into matrix bcz ridgefit takes only matrix
#selecting all the values except FLOW.cm in x
x1<-model.matrix(FLOW.cm.~.,train1)
y1<-as.matrix(train1$FLOW.cm.)

xtest1<-model.matrix(FLOW.cm.~.,test1)
ytest1<-as.matrix(test1$FLOW.cm.)

#generating the model
RidgeMod <- cv.glmnet(x1, y1, alpha=0, nlambda=100,lambda.min.ratio=0.0001,nfolds=5)
LassoMod <- cv.glmnet(x1, y1, alpha=1, nlambda=100,lambda.min.ratio=0.0001,nfolds=5)
Control1<-trainControl(method = "repeatedcv",number = 5,repeats=5)
LmFit2<-train(FLOW.cm. ~ ., data = train1, method = "glm",trControl = Control1, metric="Rsquared")

#using the model to predict the values
y_predicted1 <- predict(RidgeMod, newdata=test1,newx=xtest1,s="lambda.min")
y_predicted4 <- predict(LassoMod, newdata=test1,newx=xtest1,s="lambda.min")
PredictedTest2<-predict(LmFit2,test1)

#plotting the actual vs predicted chart
plot(test1$FLOW.cm.,y_predicted1,xlab="actual",ylab="predicted",col = "red")
legend("topleft", legend=c("Ridge L2", "Lasso L1", "MLE"), col=c("red", "blue","green"),pch=c(1,1,1),cex=0.8,title="Regularizations", text.font=4, bg='azure')
par(new=TRUE)
plot(test1$FLOW.cm.,y_predicted4,xlab="",ylab="",col = "blue",axes=FALSE)
par(new=TRUE)
plot(test1$FLOW.cm.,PredictedTest2,xlab="",ylab="",col = "green",axes=FALSE)


setwd('~/Code/SMAI/BayesianNets')

dense_to_sparse <- function(data,nfeatures) {
  A = matrix(0,nrow(data),nfeatures)
  for (k in 1:dim(data)[1]) {
    for (i in 1:(dim(data)[2])) {
      if(!is.na(data[k,i]) && data[k,i]<= nfeatures) {
        A[k,data[k,i]] <- 1
      }
    }
  }
  return(A)
}

fast_dense_to_sparse <- function(data,nfeatures) {
  A = matrix(0,nrow(data),nfeatures)
  for (k in 1:dim(data)[1]) {
    # for (i in 1:(dim(data)[2])) {
    #   if(!is.na(data[k,i]) && data[k,i]<= nfeatures) {
    #     A[k,data[k,i]] <- 1
    #   }
    # }
    A[k,data[k,] <= nfeatures] <- 1
  }
  return(A)
}
principle_components <- function(data) {
  # A <- dense_to_sparse(data,2000)
  A <- data
  X <- as.matrix(apply(A, 2, function(y) y - mean(y)))
  Y <- cov(X)
  eig <- eigen(Y)
  vectors <- as.matrix(eig$vectors[,1:20])
  # final_data <- t(t(vectors) %*% t(X))
  # return(final_data)
  return(vectors)
}

fisher_components <- function(data, labels) {
  # A <- dense_to_sparse(data,200)
  A <- data
  A <- cbind(A, labels)
  X <- A[A$V1 == 1,]
  Y <- A[A$V1 == -1,]
  X[,201] <- NULL
  Y[,201] <- NULL

  Mu1 <- as.matrix(apply(X, 2, function(y) mean(y)))
  Mu2 <- as.matrix(apply(Y, 2, function(y) mean(y)))

  U <- X - Mu1
  V <- Y - Mu2

  S1 <- cov(U)
  S2 <- cov(V)
  SW <- S1 + S2
  SB <- (Mu1 - Mu2) %*% t(Mu1-Mu2)
  invSw <- solve(SW) %*% SB
  eig <- eigen(invSw)
  vectors <- as.matrix(eig$vectors[,1:1])
  A[,ncol(A)] <- NULL
  # final_data <- t(t(vectors) %*% t(A))
  # return(final_data)
  return(Re(vectors))
}

gaussian_naive_bayes <- function(data, test,test_labels) {
  mask <- data[,ncol(data)] == -1
  negative <- data[mask,]
  positive <- data[!mask,]
  positive[,ncol(positive)] <- NULL
  negative[,ncol(negative)] <- NULL

  Mu1 <- apply(positive, 2, function(y) mean(y))
  Mu2 <- apply(negative, 2, function(y) mean(y))

  Var1 <- apply(positive, 2, function(y) var(y))
  Var2 <- apply(negative, 2, function(y) var(y))

  A <- t(as.matrix(apply(test, 1, function(y) y - Mu1)))
  B <- t(as.matrix(apply(test, 1, function(y) y - Mu2)))

  A <- A^2
  B <- B^2

  Var1 <- 2*Var1^2
  Var2 <- 2*Var2^2

  C <- exp(t(as.matrix(apply(A, 1, function(y) -1*y/Var1))))
  D <- exp(t(as.matrix(apply(B, 1, function(y) -1*y/Var2))))

  # U <- t(as.matrix(apply(C,1, function(y) (1/sqrt(pi*Var1))*y)))
  # V <- t(as.matrix(apply(D,1, function(y) (1/sqrt(pi*Var1))*y)))

  mistake = 0
  total = 0
  for(i in 1:nrow(test)) {
    predict <- test_labels[i,]
    vec <- C[i,]
    vec2 <- D[i,]
    pos_score <- sum(sapply(vec,function(x) log(x+1)))
    neg_score <- sum(sapply(vec2,function(x) log(x+1)))
    #predict <- test[i,length(vec)]
    pos_score = log(nrow(positive)/nrow(data)) + pos_score
    neg_score = log(nrow(negative)/nrow(data)) + neg_score
    if((neg_score - pos_score)  >= 0.01) {
        naive_predict = -1
    } else {
        naive_predict = 1
    }

    if(naive_predict != predict) {
      mistake = mistake + 1
    }
    total = total +1
  }
  print(mistake/total)
}

data <- read.table("Datasets/dorothea_train.data", header = FALSE, sep = " ", col.names = paste0("V",seq_len(6100)), fill = TRUE)
labels <- read.table("Datasets/dorothea_train.labels", header = FALSE, sep = " ")
#principle_components(data)
# vectors <- fisher_components(data,labels)
# vectors <- principle_components(data)
test <- read.table("Datasets/dorothea_valid.data", header = FALSE, sep = " ", col.names = paste0("V",seq_len(6100)), fill = TRUE)
test_labels <- read.table("Datasets/dorothea_valid.labels", header = FALSE, sep = " ")

ddata <- dense_to_sparse(data,200)
dtest <- dense_to_sparse(test,200)
fdata <- t(t(vectors) %*% t(ddata))
fdata <- cbind(fdata, labels)
ftest <- t(t(vectors) %*% t(dtest))
# ftest <- cbind(test, test_labels)


> sprintf("%f", pi)
[1] "3.141593"
> sprintf("%.3f", pi)
[1] "3.142"
> sprintf("%1.0f", pi)
[1] "3"
> sprintf("%5.1f", pi)
[1] "  3.1"
> sprintf("%05.1f", pi)
[1] "003.1"
> sprintf("%+f", pi)
[1] "+3.141593"
> sprintf("% f", pi)
[1] " 3.141593"
> sprintf("%-10f", pi)# left justified
[1] "3.141593  "
> sprintf("%e", pi)
[1] "3.141593e+00"
> sprintf("%E", pi)
[1] "3.141593E+00"
> sprintf("%g", pi)
[1] "3.14159"
> sprintf("%g",   1e6 * pi) # -> exponential
[1] "3.14159e+06"
> sprintf("%.9g", 1e6 * pi) # -> "fixed"
[1] "3141592.65"
> sprintf("%G", 1e-6 * pi)
[1] "3.14159E-06"


## Load required packages
require(plotly) # For interactive 3D graphics
require(numDeriv) # For Jacobian matrix of partial derivatives

library(ggplot2)
library(data.table)

## Writes a function to get coordinates for a 3D wireframe graphic
## x = Minimum and Maximum x-values
## y = Minimum and Maximum y-values
## func = Function to plot
## pixels = Graph resolution
getSurface = function(x = c(-1,1),
                      y = c(-1,1),
                      func = function(x) x[1]^2 + x[2]^2,
                      pixels = 20) {
  ## Create grid of x and y values
  grid.x <- x[1] + (0:pixels)*(x[2]-x[1])/pixels
  grid.y <- y[1] + (0:pixels)*(y[2]-y[1])/pixels
  grid <- expand.grid(grid.x,grid.y)
  names(grid) <- c("x","y")
  ## Apply the function to each value of x and y (x[1] and x[2])
  grid$z = apply(grid,1,func)
  grid
}

data <- getSurface(x = c(0,100),
                   y = c(0,100),
                   func = function(x) (x[1]^.1)*(x[2]^.1),
                   pixels = 60)

p <- plot_ly(showscale = FALSE, width = 600, height = 600) %>%
  add_mesh(x = data.pos$x, y = data.pos$y, z = data.pos$z, type = 'mesh3d') %>%
  add_mesh(x = data.neg$x, y = data.neg$y, z = data.neg$z, type = 'mesh3d')
p

L1 = function(L2, L=200, rho=1, theta2=.3){
  theta1 = 1-theta2
  L1 = (-(theta2*(L2^rho) - (L^rho))/theta1)^(1/rho)
  return(L1)
}

L1(234)

curve(L1, from=0, to=200)

### migration flows gender
setwd("~/Dropbox/upf_economics_migration/2017/analysis/gender")

d = fread('wb_bmf.csv')

os = d[, list(y1960 = sum(n1960, na.rm=TRUE), y1970 = sum(n1970, na.rm=TRUE), y1980 = sum(n1980, na.rm=TRUE), y1990 = sum(n1990, na.rm=TRUE), y2000 = sum(n2000, na.rm=TRUE)), by=list(o, oc, g, gc)]

osl = melt(os, id.vars=c('o', 'oc', 'g', 'gc'))

names(osl)[5] = 'year'
names(osl)[3] = 'gender'

osl$year = as.integer(substr(osl$year, 2, 5))

unique(paste(osl$oc,osl$o))

D = osl[oc %in% c("ESP", "MEX", "MAR", "POL", "PHL", "ROM")]

p<-ggplot(data=D, aes(x=year, y=value, group=gender)) +
  geom_line(aes(color=gender)) + facet_wrap(~o, ncol=2)

p

ds = d[, list(y1960 = sum(n1960, na.rm=TRUE), y1970 = sum(n1970, na.rm=TRUE), y1980 = sum(n1980, na.rm=TRUE), y1990 = sum(n1990, na.rm=TRUE), y2000 = sum(n2000, na.rm=TRUE)), by=list(d, dc, g, gc)]

dsl = melt(ds, id.vars=c('d', 'dc', 'g', 'gc'))

names(dsl)[5] = 'year'
names(dsl)[3] = 'gender'

dsl$year = as.integer(substr(dsl$year, 2, 5))

unique(paste(dsl$dc,dsl$d))

D = dsl[dc %in% c("ESP", "DEU", "USA", "FRA")]

p<-ggplot(data=D, aes(x=year, y=value, group=gender)) +
  geom_line(aes(color=gender)) + facet_wrap(~d, ncol=2)

p

unique(paste(dsl$dc,dsl$d))

odsl = melt(d, id.vars=c('o', 'oc', 'd', 'dc', 'g', 'gc'))

names(odsl)[7] = 'year'
names(odsl)[5] = 'gender'

odsl$year = as.integer(substr(odsl$year, 2, 5))

D = odsl[dc %in% c("USA") & oc %in% c("MEX", "PHL")]

p<-ggplot(data=D, aes(x=year, y=value, group=gender)) +
  geom_line(aes(color=gender)) + facet_wrap(~o, ncol=2)

p

D = odsl[dc %in% c("DEU") & oc %in% c("TUR", "ESP")]

p<-ggplot(data=D, aes(x=year, y=value, group=gender)) +
  geom_line(aes(color=gender)) + facet_wrap(~o, ncol=2)

p


library(pomp)
library(reshape2)
library(ggplot2)

sir.step <- "
double lambd = bet * (I+iota) / N;
double ifrac = 1.0 - exp(-lambd *dt);
double rfrac = 1.0 - exp(-gamm*dt);
double infection = rbinom(S, ifrac);
double recovery = rbinom(I, rfrac);
S += -infection;
I += infection - recovery;
R += recovery;
Y += infection;
"

rmeas <- "
Z = Y;
"

pomp(
  data=data.frame(time=seq(0,200,by=0.1),Z=rep(0,2001)),
  times="time",
  t0=0,
  rmeasure=Csnippet(rmeas),
  rprocess=euler.sim(
    step.fun=Csnippet(sir.step),
    delta.t=0.1
  ),
  statenames=c("S","I","R","Y"),
  paramnames=c(
    "bet","gamm","iota", "N"
  ),
  initializer=function(params, t0, ...) {
    x0 <- c(S=999,I=1,R=0,Y=0)
    x0
  },
  params=c(bet=0.1, gamm=0.05, iota=0.01, N=1000.0)
) -> sir

set.seed(42)

sir_sim <- simulate(sir)

sir_sim

sir_out <- data.frame(Time=sir_sim@times,Cases=as.integer(sir_sim@data))

sir_out_long <- melt(as.data.frame(sir_out),"Time")

# Plot
ggplot(sir_out_long,aes(x=Time,y=value,colour=variable,group=variable)) +
  geom_step(lwd=2) + xlab("Time") + ylab("Cases") + theme(legend.position="none")


set.seed(0)

dot <- function(x){
  return(sum(x * x))
}

### DATA
# Public data
K = 3
M = 10000

# Alice's private data
N1 = 1000
y1 = rnorm(N1)
X1 = matrix(rnorm(N1 * M), N1, M)
C1 = matrix(rnorm(N1 * K), N1, K)

# Bob's private data
N2 = 2000
y2 = rnorm(N2)
X2 = matrix(rnorm(N2 * M), N2, M)
C2 = matrix(rnorm(N2 * K), N2, K)

# Carla's private data
N3 = 1500
y3 = rnorm(N3)
X3 = matrix(rnorm(N3 * M), N3, M)
C3 = matrix(rnorm(N3 * K), N3, K)

### PRIVATE COMPUTE compresses the data.
# Alice computes and secret shares...
yy1 = dot(y1)
Xy1 = t(X1) %*% y1
XX1 = apply(X1,2,dot)

Cty1 = t(C1) %*% y1
CtX1 = t(C1) %*% X1

R1 = qr.R(qr(C1))

# Bob computes and secret shares...
yy2 = dot(y2)
Xy2 = t(X2) %*% y2
XX2 = apply(X2, 2, dot)

Cty2 = t(C2) %*% y2
CtX2 = t(C2) %*% X2

R2 = qr.R(qr(C2))

# Carla computes and secret shares...
yy3 = dot(y3)
Xy3 = t(X3) %*% y3
XX3 = apply(X3, 2, dot)

Cty3 = t(C3) %*% y3
CtX3 = t(C3) %*% X3

R3 = qr.R(qr(C3))

### SECURE MULTI-PARTY COMPUTE is now independent of the sample sizes.
D = N1 + N2 + N3 - K - 1

yy = yy1 + yy2 + yy3
Xy = Xy1 + Xy2 + Xy3
XX = XX1 + XX2 + XX3

Cty = Cty1 + Cty2 + Cty3
CtX = CtX1 + CtX2 + CtX3

invR = solve(qr.R(qr(rbind(R1, R2, R3))))

Qty = t(invR) %*% Cty
QtX = t(invR) %*% CtX

QtyQty = dot(Qty)
QtXQty = t(QtX) %*% Qty
QtXQtX = apply(QtX, 2, dot)

yyq = yy - QtyQty
Xyq = Xy - QtXQty
XXq = XX - QtXQtX

# The endpoints of secure computation are effect size and squared standard error.
beta = Xyq / XXq
sigma_sq = (yyq / XXq - beta^2) / D

# These determine the t statistic and p-value.
sigma = sqrt(sigma_sq)
tstat = beta / sigma
pval = 2 * pt(-abs(tstat), D)

df = data.frame(beta=beta, sigma=sigma, tstat=tstat, pval=pval)

# VERIFY correctness for the first M0 columns of X:
M0 = 5

y = c(y1 ,y2, y3)
X = rbind(X1, X2, X3)
C = rbind(C1, C2, C3)

res = matrix(nrow=0,ncol=4)
for (m in 1:M0) {
  fit = lm(y ~ X[,m] + C - 1)
  res = rbind(res,as.vector(summary(fit)$coefficients[1,]))
}

df2 = data.frame(beta=res[,1], sigma=res[,2], tstat=res[,3], pval=res[,4])

all.equal(df[1:M0,],df2) # Returns TRUE


#### estimating the algorithms for doorspread and wing spread for filling in gaps in the datras flexfile.

library(icesDatras)
library(mgcv)

hh<-getDATRAS("HH","NS-IBTS",c(2003:2020),c(1)) ## HH data downloaded from the ICES data
hh<-hh[hh$HaulVal=="V",]

hh.NL<-hh[hh$Country=="NED",]
hh.NL<-hh.NL[hh.NL$DoorSpread>0,]

# correcting errors not yet changed in Datras
hh.NL[hh.NL$DoorSpread==48,]$DoorSpread<-74
hh.NL[hh.NL$Year==2005 & hh.NL$HaulNo==20,]$DoorSpread<-91
hh.NL[hh.NL$Year==2010 & hh.NL$DoorSpread>98,]$DoorSpread<--9
hh.NL<-hh.NL[hh.NL$DoorSpread>50,]
hh.NL<-hh.NL[hh.NL$Warplngt>0,]
hh.NL<-hh.NL[hh.NL$Depth>1,]

hh.NL$Doorcal.Den<-79.254-(34.368*exp(-0.029*hh.NL$Depth)) ## Danish algorithm for doorspread
hh.NL$Doorcal.MAF<-(33.251*log10(hh.NL$Depth))+ 15.744 ## Algorithm proposed by the EU project MAFCONS

plot(hh.NL$DoorSpread~hh.NL$Depth, ylim=c(30,140))
lines(hh.NL$Doorcal.Den~hh.NL$Depth, col="blue")
lines(hh.NL$Doorcal.MAF~hh.NL$Depth, col="red")
# clear underestimation of the Dutch values

mm<-lm(hh.NL$Warplngt~hh.NL$Depth)

hh.NL<-hh.NL[is.na(hh.NL$Depth)==F,]
hh.NL<-hh.NL[is.na(hh.NL$Warplngt)==F,]

DoorSpread<- hh.NL$DoorSpread
Depth<- hh.NL$Depth
Warplngt<- hh.NL$Warplngt

t1<-nls(hh.NL$DoorSpread~a*log10(hh.NL$Depth)+d*log10(hh.NL$Warplngt)+ b, start = list(a = 16, b = -30, d = -15))

test1<-data.frame(Depth=seq(0,200,by=1))
test1$Warplngt<-mm$coefficients[1]+test1$Depth*mm$coefficients[2]

test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]
lines(test1$nls.fun~test1$Depth, col="gold")
## better fit
summary(t1)$parameters

###forcing to a doorspread of zero
zero<-hh.NL[1,]
zero$DoorSpread<-45
zero$Depth<-10
zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

max<-hh.NL[1,]
max$DoorSpread<-100
max$Depth<-180
max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

hh.NL1<-rbind(zero,hh.NL,max)
we = rep(1, dim(hh.NL1)[1])
we[1]<-1000
we[length(we)]<-1000

d1<-hh.NL1$DoorSpread
d2<-hh.NL1$Depth
d3<-hh.NL1$Warplngt

t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -30, d = -15))
test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]
lines(test1$nls.fun~test1$Depth, col="green")

##### year effect

plot(hh.NL$DoorSpread~hh.NL$Depth, ylim=c(30,140))

for(i in unique(hh.NL$Year)){
d1<-hh.NL[hh.NL$Year==i,]$DoorSpread
d2<-hh.NL[hh.NL$Year==i,]$Depth
d3<-hh.NL[hh.NL$Year==i,]$Warplngt

t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b, start = list(a = 16, b = -30, d = -15))
test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

lines(test1$nls.fun~test1$Depth, col=i)
Sys.sleep(3)
}

#### groups 2003+2004, 2005-2014, 2015+2016, 2017-2020
plot(hh.NL$DoorSpread~hh.NL$Depth, ylim=c(30,120), xlab="Depth (m)",ylab="Doorspread (m)")

zero<-hh.NL[1,]
zero$DoorSpread<-55
zero$Depth<-10
zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

max<-hh.NL[1,]
max$DoorSpread<-110
max$Depth<-180
max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

hh.NL1<-rbind(zero,hh.NL[hh.NL$Year %in% c(2003,2004),],max)
we = rep(1, dim(hh.NL1)[1])
we[1]<-5
we[length(we)]<-50

  d1<-hh.NL1$DoorSpread
  d2<-hh.NL1$Depth
  d3<-hh.NL1$Warplngt

  t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -20, d = 35))
  test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

 # plot(hh.NL1$DoorSpread~hh.NL1$Depth, ylim=c(30,140))
    lines(test1$nls.fun~test1$Depth, col="red")
  summary(t1)$parameters

#####2005-2014

  zero<-hh.NL[1,]
  zero$DoorSpread<-55
  zero$Depth<-10
  zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

  max<-hh.NL[1,]
  max$DoorSpread<-100
  max$Depth<-180
  max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

  hh.NL1<-rbind(zero,hh.NL[hh.NL$Year %in% c(2005:2014),],max)
  we = rep(1, dim(hh.NL1)[1])
  we[1]<-50
  we[length(we)]<-50

  d1<-hh.NL1$DoorSpread
  d2<-hh.NL1$Depth
  d3<-hh.NL1$Warplngt

  t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -20, d = 35))
  test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

 # plot(hh.NL1$DoorSpread~hh.NL1$Depth, ylim=c(30,140))
  lines(test1$nls.fun~test1$Depth, col="blue")
  summary(t1)$parameters

  #####2015-2016

  zero<-hh.NL[1,]
  zero$DoorSpread<-45
  zero$Depth<-10
  zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

  max<-hh.NL[1,]
  max$DoorSpread<-100
  max$Depth<-180
  max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

  hh.NL1<-rbind(zero,hh.NL[hh.NL$Year %in% c(2015:2016),],max)
  we = rep(1, dim(hh.NL1)[1])
  we[1]<-50
  we[length(we)]<-50

  d1<-hh.NL1$DoorSpread
  d2<-hh.NL1$Depth
  d3<-hh.NL1$Warplngt

  t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -20, d = 35))
  test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

 #plot(hh.NL1$DoorSpread~hh.NL1$Depth, ylim=c(30,140))
  lines(test1$nls.fun~test1$Depth, col="green")
  summary(t1)$parameters

  ### 2017-2020
  zero<-hh.NL[1,]
  zero$DoorSpread<-55
  zero$Depth<-10
  zero$Warplngt<-mm$coefficients[1]+zero$Depth*mm$coefficients[2]

  max<-hh.NL[1,]
  max$DoorSpread<-100
  max$Depth<-180
  max$Warplngt<-mm$coefficients[1]+max$Depth*mm$coefficients[2]

  hh.NL1<-rbind(zero,hh.NL[hh.NL$Year %in% c(2017:2020),],max)
  we = rep(1, dim(hh.NL1)[1])
  we[1]<-50
  we[length(we)]<-50

  d1<-hh.NL1$DoorSpread
  d2<-hh.NL1$Depth
  d3<-hh.NL1$Warplngt

  t1<-nls(d1~a*log10(d2)+d*log10(d3)+ b,weights=we, start = list(a = 16, b = -20, d = 35))
  test1$nls.fun<-summary(t1)$parameters[1]*log10(test1$Depth)+summary(t1)$parameters[3]*log10(test1$Warplngt)+ summary(t1)$parameters[2]

 #plot(hh.NL1$DoorSpread~hh.NL1$Depth, ylim=c(30,140))
  lines(test1$nls.fun~test1$Depth, col="gold")
  summary(t1)$parameters


 Inf                    #positive infinity
 -Inf                   #negative infinity
 .Machine$double.xmax   # largest finite floating-point number
 is.finite              # function to test to see if a number is finite

# function that returns the input if it is finite, otherwise returns (plus or minus) the largest finite floating-point number
 forcefinite <- function(x) ifelse(is.finite(x), x, sign(x)*.Machine$double.xmax)

 forcefinite(c(1, -1, 0, .Machine$double.xmax, -.Machine$double.xmax, Inf, -Inf))
# [1]   1.000000e+00  -1.000000e+00   0.000000e+00  1.797693e+308
# [5] -1.797693e+308  1.797693e+308 -1.797693e+308


#'@title calcHMThrustFactor
#'
#'@description Calculate thrust deduction factor (\code{thrustFactor})
#'(dimensionless) from the Holtrop & Mennen method.
#'
#'@param lwl Waterline length (vector of numericals, m) (see \code{\link{calclwl}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'@param maxDisplacement Maximum ship displacement (vector of numericals, m^3)
#'@param nProp Number of propellers (vector of numericals, see
#' \code{\link{calcPropNum}})
#'@param Cp Prismatic coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCp}})
#'@param propDiam Propeller diameter (vector of numericals, m) (see
#' \code{\link{calcPropDia}})
#'@param Cbw Waterline block coefficient (vector of numericals, dimensionless) (see
#' \code{\link{calcCbw}})
#'@param Cstern Afterbody form coefficient: \itemize{\item V-shaped Hull = -10
#'         \item U-Shaped Hull =  10
#'         \item Normal Hull = 0 (default)}
#' Can supply either a vector of numericals, a single number, or rely on the default
#'@param lcb Longitudinal position of center of buoyancy (vector of numericals, see
#' \code{\link{calclcb}})
#'@param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can supply
#' either a vector of numericals, a single number, or rely on the default
#'
#'@details
#'Thrust deduction factor is a component of hull efficiency as well as a
#'component of propeller efficiency. It describes the increase in resistance on
#'the hull from water getting sucked back towards the propeller.
#'
#'Note: In "A Statistical Re-Analysis of Resistance and Propulsion Data", the
#'authors re-analyze with the inclusion of Series 64 hull forms for a total of
#'334 models included in the analysis. They suggest an update of the single
#'screw thrust equation but that the original equations should be used
#'for twin screw ships.
#'
#'Additionally, we are assuming conventional stern for all single screw ships.
#'Holtrop & Mennen also include an estimation for thrust factor for single screw
#'ships with open stern for fast sailing ships, but that is not included here.
#'
#'@return \code{thrustFactor} (vector of numericals, dimensionless)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'Holtrop, J. and Mennen, G. G. J. 1984. "A Statistical Re-Analysis of Resistance
#'and Propulsion Data'.
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcPropNum}}
#'\item \code{\link{calcCp}}
#'\item \code{\link{calcPropDia}}
#'\item \code{\link{calcCbw}}
#'\item \code{\link{calclcb}}}
#'
#'@family Holtrop-Mennen Calculations
#'
#'@examples
#' calcHMThrustFactor(c(32.25,32.20),c(218.75,209.25),c(13.57,11.49),c(80097,52382.04),
#'                    c(1,1),c(0.81,0.67),c(6.7,7),c(0.81,0.65))
#' calcHMThrustFactor(32.25,218.75,13.57,80097,
#'                    1,0.81,6.7,0.81)
#'
#'@export

calcHMThrustFactor<- function(breadth,lwl,maxDraft,maxDisplacement,nProp,Cp,
                         propDiam,Cbw,Cstern=0,lcb=0,seawaterDensity=1.025){

  #================
  c10<- ifelse(lwl/breadth<5.2,#case 1
               0.25-(0.003328402/((breadth/lwl)-0.134615385))
  ,#case 2
    breadth/lwl
  )
  #================

  thrustFactor<- ifelse(nProp==1,#begin single screw estimation ([2] method)
    0.25014*((breadth/lwl)^0.28956)*
      ((sqrt(breadth*maxDraft)/maxDisplacement)^0.2624)/
    ((1-Cp+0.0225*lcb)^0.01762)+0.0015*Cstern

    #end single screw estimation
  ,#begin twin screw estimation ([1] method)
    0.325*Cbw-0.1885*propDiam/sqrt(breadth*maxDraft)

  )#end twin screw estimation

  return(thrustFactor)
}


#edf plot
#  use beta distribution as an example
par(mfrow=c(2,2))
a <- 3
b <- 1.5
n <- 30
x <- seq(0, 1, length=100)
f <- dbeta(x, a, b)
plot(x, f, type="l", main="pdf")
F <- pbeta(x, a, b)
plot(x, F, type="l", main="CDF")
X <- rbeta(n,a,b)
hist(X, main=paste(n,"samples"), xlim=c(0,1))
rug(X)
eF <- ecdf(X)
plot(eF, main="EDF", verticals=TRUE, xlim=c(0,1))
par(mfrow=c(1,1))

#bootstrap resample of martin
martin <- c(0.13,-0.01,-0.01,0.42,-0.02,0.01,0.09,0.03,0.04,0.06,0.12,0.03)
nreps <- 1000
how.often <- matrix(NA, nrow=nreps, ncol=length(martin))
for(i in 1:nreps) how.often[i,] <- sample(martin,length(martin),replace=TRUE)
table(how.often)

boot.martin <- function(data, b, alpha, type="nonp") {
#  Purpose:  compute 95% CI endpoints for dataset
#  Input: dataset, number of replicates, type in ("nonp", "par-norm", "par-t")
#  output: histogram with CI endpoints
  boot <- matrix(NA, nrow=b+1, ncol=length(data))
  m <- mean(martin)
  sd <- sd(martin)
  title <- paste(b, type, "bootstraps", sep=' ')
  if (type == "nonp") {
    for(i in 1:b) {boot[i,] <- sample(data,length(data),replace=TRUE) }
  } else {
    if (type=="par-norm") {
    for(i in 1:b) {boot[i,] <- rnorm(length(data),m,sd) }
    } else {
      if (type=="par-t") {
      for(i in 1:b) {boot[i,] <- (rt(length(martin),length(martin)-1)*sd)+m }
      } else {
        stop("Bootstrap type !in 'nonp', 'par-norm', 'par-t")
      }}}

  n.elements <- b+1
  boot[n.elements, ] <- data
  mean.boot <- apply(boot,1,mean)  # rowMeans would work equally well
  hist(mean.boot, main=title, freq=FALSE)
  m <- mean.boot[1:b]
  x <- order(m)
  lower.quantile <- floor(alpha/2 * n.elements)
  upper.quantile <- ceiling((1-alpha/2) * n.elements)
  endpoints <- c(m[x[lower.quantile]], m[x[upper.quantile]])
  abline(v=endpoints[1], lty=2)
  abline(v=endpoints[2], lty=2)
  return(endpoints)
}

boot.martin(martin, b=99, alpha=0.05)
boot.martin(martin, b=999, alpha=0.05, 'par-norm')
boot.martin(martin, b=999, alpha=0.05, 'par-t')
boot.martin(martin, b=999, alpha=0.05, 'para-norm')


#get wd
getwd()

#This will be a different path if in the lab or at home
dird="C:\\Users\\prith\\OneDrive\\Documents\\MATH4753_FA18\\DATAxls\\"

#my function to read data
myread=function(csv){
  fl=paste(dird,csv,sep="")
  read.table(fl,header=TRUE,sep=",")
}
#EASY WAY TO READ IN FILES

spruce.df=myread("SPRUCE.csv")#MS pg478
with(spruce.df, dput(list(D=BHDiameter,H=Height),
                     file="spruce.dat"))
# Or use
# spruce.df=read.table(file.choose(),header=TRUE,sep=",")

#Last six lines
tail(spruce.df)

#Plot the points
windows()

plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

#load s20x library and make lowess smoother
library(s20x)

trendscatter(Height~BHDiameter,f=0.5,data=spruce.df)
# Now make the linear model
spruce.lm=lm(Height~BHDiameter,data=spruce.df)
summary(spruce.lm)
#residuals  created from the linear model object
height.res=residuals(spruce.lm)

#fitted values made from the linear model object
height.fit=fitted(spruce.lm)

#Make the plot using the plot function
plot(height.fit,height.res)

# Put a lowess smoother through res vs fitted
trendscatter( height.fit,height.res)

# Quick way to make a residual plot
plot(spruce.lm, which =1)

# Two plots testing normality
windows()
normcheck(spruce.lm,shapiro.wilk = TRUE)

## Quadratic object using the linear model
quad.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)
summary(quad.lm)

ciReg(quad.lm)

add1(spruce.lm,.~.+I(BHDiameter^2))
anova(spruce.lm)
anova(quad.lm)
anova(spruce.lm,quad.lm)
cubic.lm=lm(Height~BHDiameter + I(BHDiameter^2)+I(BHDiameter^3),data=spruce.df)
summary(cubic.lm)
anova(cubic.lm)
add1(quad.lm,.~.+I(BHDiameter^3))
#add to the scatter plot
windows()
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

coef(quad.lm)
names(quad.lm)
quad.lm$coef[2]

myplot=function(x){
 0.86089580 +1.46959217*x  -0.02745726*x^2
 }

 #Or more general method
myplot=function(x){
 quad.lm$coef[1] +quad.lm$coef[2]*x  + quad.lm$coef[3]*x^2
 }

curve(myplot, lwd=2, col="steelblue",add=TRUE)

plot(quad.lm, which=1)

normcheck(quad.lm,shapiro.wilk = TRUE)

summary(quad.lm)

ciReg(quad.lm)

predict(quad.lm, data.frame(BHDiameter=c(15,18,20)))

anova(spruce.lm,quad.lm)

anova(quad.lm)
anova(spruce.lm)

height.qfit=fitted(quad.lm)

RSS=with(spruce.df, sum((Height-height.qfit)^2))
RSS
MSS = with(spruce.df, sum((height.qfit-mean(Height))^2))
MSS

TSS = with(spruce.df, sum((Height-mean(Height))^2))
TSS

MSS/TSS

cooks20x(quad.lm)

#Now remove the 24th datum and reanalyze data

quad2.lm=lm(Height~BHDiameter + I(BHDiameter^2) , data=spruce.df[-24,])
summary(quad2.lm)
summary(quad.lm)

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

#some other code you might need
#The following code plots residuals
windows()
#Plot the data
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

#Make a quadratic model
quad.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)

# Find the coefficients
coef(quad.lm)

#Make a function that produces heights for inputs "x"
myplot=function(x){
 0.86089580 +1.46959217*x  -0.02745726*x^2
 }

# add the quadratic to the points
curve(myplot, lwd=2, col="steelblue",add=TRUE)

#Place segments (residuals) on the plot (except for the 3 largest cooks distances. 18, 21, 24)
with(spruce.df[-c(18,21,24),],segments(BHDiameter, Height, BHDiameter, height.qfit[-c(18,21,24)]) )
with(spruce.df[c(18,21,24),],segments(BHDiameter, Height, BHDiameter, height.qfit[c(18,21,24)], col="Red", lwd=3) )
with( spruce.df, arrows(5,Height[24], BHDiameter[24], Height[24],lwd=2,col="Blue"))
with(spruce.df,text(2,Height[24], paste("Highest Cook's","\n", "distance",sep=" ")))
with(spruce.df, text(BHDiameter,Height, 1:36,cex=0.5,pos=4))
 #########################################################################

layout(matrix(1:4,nr=2,nc=2,byrow=TRUE))

#Lets look at where the plots will go
layout.show(4)

#Plot the data
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)
# add the line
abline(spruce.lm)

#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

abline(spruce.lm)

#make yhat the estimates of E[Height | BHDiameter]
yhat=with(spruce.df,predict(spruce.lm,data.frame(BHDiameter)))
yhat=fitted(spruce.lm)
# Draw in segments making the residuals (regression errors)
with(spruce.df,{
segments(BHDiameter,Height,BHDiameter,yhat)
})

RSS=with(spruce.df,sum((Height-yhat)^2))

RSS

#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

#make nieve model
with(spruce.df, abline(h=mean(Height)))
abline(spruce.lm)

#make the explained errors (explained by the model)
with(spruce.df, segments(BHDiameter,mean(Height),BHDiameter,yhat,col="Red"))
MSS=with(spruce.df,sum((yhat-mean(Height))^2))
MSS

# Total  error
#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

with(spruce.df,abline(h=mean(Height)))
with(spruce.df, segments(BHDiameter,Height,BHDiameter,mean(Height),col="Green"))
TSS=with(spruce.df,sum((Height-mean(Height))^2))
TSS
RSS + MSS
MSS/TSS

summary(spruce.lm)

#obtain coefft values
coef(spruce.lm)

#Calculate new y values given x
predict(spruce.lm, data.frame(BHDiameter=c(15,18,20)))

anova(spruce.lm)

spruce2.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)
summary(spruce2.lm)

### More on the problem
windows()
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
     ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
     main="Spruce height prediction",data=spruce.df)

yhatt=with(spruce.df,fitted(spruce2.lm))
with(spruce.df,plot(BHDiameter,yhatt,col="Red")
)

sum(residuals(spruce2.lm)^2)
plot(yhatt~BHDiameter,data=spruce.df,type="p")
summary(spruce2.lm)
anova(spruce2.lm)
anova(spruce.lm,spruce2.lm)
MSS
RSS

mat <- matrix(ncol=2, nrow=n)

for (i in 1:n) {
  var1 <- function_one(i,par1)
  var2 <- function_two(i,par2)
  mat[i,] <- c(var1,var2)
}

yhat=with(spruce.df,predict(spruce.lm,data.frame(BHDiameter)))
yhat

summary(quad.lm)
myplot2=function(){
  n = 36
  mat <- matrix(ncol=1, nrow=n)
  for (x in 1:n){
    mat[x,] = quad.lm$coef[1] +quad.lm$coef[2]*x  + quad.lm$coef[3]*x^2
  }
  return(mat)
}
curveplot = myplot2()
curveplot
curve(myplot, lwd=2, col="green3",add=TRUE)
with(spruce.df,{
segments(BHDiameter,Height,BHDiameter,curveplot)
})
spruce.df$Height
spruce.df$BHDiameter
segment(BHDiameter,19.2,BHDiameter,20.23)

#add to the scatter plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
     ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
     main="Spruce height prediction",data=spruce.df)

myplot=function(x){
  result = 0.86089580 +1.46959217*x  -0.02745726*x^2
  result
  return (result)
}

#Or more general method
myplot2=function(){
  n = 36
  mat <- matrix(ncol=1, nrow=n)
  for (x in 1:n){
    mat[x] = quad.lm$coef[1] +quad.lm$coef[2]*x  + quad.lm$coef[3]*x^2
  }
  return(mat)
}
curveplot = myplot2()
curveplot
curve(myplot, lwd=2, col="green3",add=TRUE)
with(spruce.df,{segments(BHDiameter,19.2,BHDiameter,20.23)})