library(gamlss)
library(gtools)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("GSE65682_series_all_mortality.Rdat")

################################################################################
# Gamlss estimation of gene noise for each gene for CAP

# f - factor:
# ctl - control;
# cap:0 - CAP survived; cap:1 - CAP decieased;
# other:0 - Sepsis survived; other:1 - Sepsis decieased;
f <- gsub(":NA", "", paste(pheno$d, pheno$mort, sep=":"))
f <- relevel(factor(f), ref="ctl")

gene_noise_CAP <- mclapply(seq(nrow(affyData_out)), function(i) {
  cat(i, "\n")

  # df - data.frame
  # y - log2 hybridizations
  # x - factor (ctl - control; cap:0 - CAP survived; cap:1 - CAP decieased)
  # x2 - factor (ctl - control; cap - CAP)
  df <- data.frame(y = as.numeric(affyData_out[i,]), x = f, age = pheno$age)
  df <- subset(df, x != "other:0" & x != "other:1")
  df$x <- droplevels(df$x)
  df$x2 <- factor(substring(as.character(df$x), 1,3), levels=c("ctl", "cap"))
  df$age <- quantcut(df$age, q=10)

  sink("/dev/null")
   # df$yr <- resid(gamlss(y ~ age, sigma.fo = ~ age, data = df, n.cyc=1000))
   # df$yr <- df$y

   # gamlss models
   # m0 - model for mu and sigma with x factor effects: ctl - control; cap:0 - CAP survived; cap:1 - CAP decieased
   # m1 - model for mu with x factor effects: ctl - control; cap:0 - CAP survived; cap:1 - CAP decieased
   # m2 - model for sigma with x factor effects: ctl - control; cap:0 - CAP survived; cap:1 - CAP decieased

   m0 <- tryCatch( gamlss(y ~ 0 + x , sigma.fo = ~ 0 + x , data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m1 <- tryCatch( gamlss(y ~ 0 + x , sigma.fo = ~ 1, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m2 <- tryCatch( gamlss(y ~ 1, sigma.fo = ~ 0 + x , data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)

   # m0a - model for mu and sigma with x2 factor effects: ctl - control; cap - CAP
   # m1a - model for mu with x2 factor effects: ctl - control; cap - CAP
   # m2a - model for sigma with x2 factor effects: ctl - control; cap - CAP

   m0a <- tryCatch( gamlss(y ~ 0 + x2 , sigma.fo = ~ 0 + x2 , data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m1a <- tryCatch( gamlss(y ~ 0 + x2 , sigma.fo = ~ 1, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m2a <- tryCatch( gamlss(y ~ 1, sigma.fo = ~ 0 + x2 , data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
  sink()

  if(any(sapply(list(m0,m1,m2), is.null))) {
    res1 <- data.frame(mu_ctl = NA, mu_cap0 = NA, mu_cap1 = NA, v_ctl = NA, v_cap0 = NA, v_cap1 = NA, V_ave = NA, p_mu = NA, p_sigma=NA)
  } else {
      # LR test for the significance of CAP effect (ctl, cap:0, cap:1) on mean gene expression
      p_mu <- pchisq(2*as.numeric(logLik(m0)-logLik(m2)), 2, lower.tail=F)
      # LR test for the significance of CAP effect on gene expression noise (sigma - standard deviation)
      p_sigma <- pchisq(2*as.numeric(logLik(m0)-logLik(m1)), 2, lower.tail=F)
      # Estimation of mean gene expression
      mu <- mean(df$y) + m0$mu.coefficients[1:3]
      # Estimation of gene expression noise (sigma^2 - variance)
      sigma <- exp(m0$sigma.coefficients[1:3])^2
      # results:
      # mu_ctl - mean gene expression for control
      # mu_cap0 - mean gene expression for cap0 (CAP survived)
      # mu_cap1 - mean gene expression for cap1 (CAP decieased)
      # v_ctl - gene expression variance for control
      # v_cap0 - gene expression variance for cap0 (CAP survived)
      # v_cap1 - gene expression variance for cap1 (CAP decieased)
      # V_ave - pooled gene expression variance
      # p_mu - significance of CAP effect on mean gene expression
      # p_sigma - significance of CAP effect on gene expression noise (sigma - standard deviation)
      res1 <- data.frame(mu_ctl = mu[[1]], mu_cap0 = mu[[2]], mu_cap1 = mu[[3]],
        v_ctl = sigma[[1]], v_cap0 = sigma[[2]], v_cap1 = sigma[[3]], V_ave = exp(m1$sigma.coefficients[[1]])^2,
        p_mu = p_mu, p_sigma=p_sigma)
  }

  if(any(sapply(list(m0a,m1a,m2a), is.null))) {
    res2 <- data.frame(mu2_ctl = NA, mu2_cap = NA, v2_ctl = NA, v2_cap = NA, p2_mu = NA, p2_sigma=NA)
  } else {
      # LR test for the significance of CAP effect (ctl, cap) on mean gene expression and sigma
      p2_mu  <- pchisq(2*as.numeric(logLik(m0a)-logLik(m2a)), 1, lower.tail=F)
      p2_sigma <- pchisq(2*as.numeric(logLik(m0a)-logLik(m1a)), 1, lower.tail=F)
      mu2 <- mean(df$y) + m0a$mu.coefficients[1:3]
      sigma2 <- exp(m0a$sigma.coefficients[1:3])^2
      # results:
      # mu2_ctl - mean gene expression for control
      # mu2_cap - mean gene expression for CAP (survived/decieased)
      # v2_ctl - gene expression variance for control
      # v2_cap - gene expression variance for CAP (survived/decieased)
      # p2_mu - significance of ctl vs CAP effect on mean gene expression
      # p2_sigma - significance of ctl vs CAP effect on gene expression noise (sigma - standard deviation)
      res2 <- data.frame(mu2_ctl = mu2[[1]], mu2_cap = mu2[[2]],
        v2_ctl = sigma2[[1]], v2_cap = sigma2[[2]],
        p2_mu = p2_mu, p2_sigma=p2_sigma)
  }

  res <- cbind(res1, res2)
}, mc.cores=6)
gene_noise_CAP <- do.call(rbind, gene_noise_CAP)
gene_noise_CAP$padj_sigma <- p.adjust(gene_noise_CAP$p_sigma, "bonferroni")
gene_noise_CAP$padj_mu <- p.adjust(gene_noise_CAP$p_mu, "bonferroni")
rownames(gene_noise_CAP) <- rownames(affyData_out)

################################################################################
# Gamlss estimation of gene noise for each gene for Sepsis (SPS) (same as above)

gene_noise_SPS <- mclapply(seq(nrow(affyData_out)), function(i) {
  cat(i, "\n")
  df <- data.frame(y = as.numeric(affyData_out[i,]), x = f, age = pheno$age)
  df <- subset(df, x != "cap:0" & x != "cap:1")
  df$x <- droplevels(df$x)
  df$x2 <- factor(substring(as.character(df$x), 1,3), levels=c("ctl", "oth"))
  df$age <- quantcut(df$age, q=10)

  sink("/dev/null")
   # df$yr <- resid(gamlss(y ~ age, sigma.fo = ~ age, data = df, n.cyc=1000))
   # df$yr <- df$y

   m0 <- tryCatch( gamlss(y ~ 0 + x , sigma.fo = ~ 0 + x , data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m1 <- tryCatch( gamlss(y ~ 0 + x , sigma.fo = ~ 1, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m2 <- tryCatch( gamlss(y ~ 1, sigma.fo = ~ 0 + x , data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)

   m0a <- tryCatch( gamlss(y ~ 0 + x2 , sigma.fo = ~ 0 + x2 , data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m1a <- tryCatch( gamlss(y ~ 0 + x2 , sigma.fo = ~ 1, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m2a <- tryCatch( gamlss(y ~ 1, sigma.fo = ~ 0 + x2 , data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
  sink()

  if(any(sapply(list(m0,m1,m2), is.null))) {
    res1 <- data.frame(mu_ctl = NA, mu_sps0 = NA, mu_sps1 = NA, v_ctl = NA, v_sps0 = NA, v_sps1 = NA, V_ave = NA, p_mu = NA, p_sigma=NA)
  } else {
      p_mu <- pchisq(2*as.numeric(logLik(m0)-logLik(m2)), 2, lower.tail=F)
      p_sigma <- pchisq(2*as.numeric(logLik(m0)-logLik(m1)), 2, lower.tail=F)
      mu <- mean(df$y) + m0$mu.coefficients[1:3]
      sigma <- exp(m0$sigma.coefficients[1:3])^2
      res1 <- data.frame(mu_ctl = mu[[1]], mu_sps0 = mu[[2]], mu_sps1 = mu[[3]],
        v_ctl = sigma[[1]], v_sps0 = sigma[[2]], v_sps1 = sigma[[3]], V_ave = exp(m1$sigma.coefficients[[1]])^2,
        p_mu = p_mu, p_sigma=p_sigma)
  }

  if(any(sapply(list(m0a,m1a,m2a), is.null))) {
    res2 <- data.frame(mu2_ctl = NA, mu2_sps = NA, v2_ctl = NA, v2_sps = NA, p2_mu = NA, p2_sigma=NA)
  } else {
      p2_mu  <- pchisq(2*as.numeric(logLik(m0a)-logLik(m2a)), 1, lower.tail=F)
      p2_sigma <- pchisq(2*as.numeric(logLik(m0a)-logLik(m1a)), 1, lower.tail=F)
      mu2 <- mean(df$y) + m0a$mu.coefficients[1:3]
      sigma2 <- exp(m0a$sigma.coefficients[1:3])^2
      res2 <- data.frame(mu2_ctl = mu2[[1]], mu2_sps = mu2[[2]],
        v2_ctl = sigma2[[1]], v2_sps = sigma2[[2]],
        p2_mu = p2_mu, p2_sigma=p2_sigma)
  }

  res <- cbind(res1, res2)
}, mc.cores=6)
gene_noise_SPS <- do.call(rbind, gene_noise_SPS)
gene_noise_SPS$padj_sigma <- p.adjust(gene_noise_SPS$p_sigma, "bonferroni")
gene_noise_SPS$padj_mu <- p.adjust(gene_noise_SPS$p_mu, "bonferroni")
rownames(gene_noise_SPS) <- rownames(affyData_out)

################################################################################
# Gamlss estimation of gene noise for each gene for H1N1 (same as above)

load("eset_H1N1.Rdat")
H1N1_stage <- samples_H1N1$'disease phase:ch1'

gene_noise_H1N <- mclapply(seq(nrow(eset_H1N1)), function(i) {
  cat(i, "\n")
  df <- data.frame(y = as.numeric(eset_H1N1[i,]), x = factor(H1N1_stage))
  df$x2 <- factor(gsub("late ", "", gsub("early ", "", as.character(df$x))), levels=c("control", "period"))

  sink("/dev/null")

   m0 <- tryCatch( gamlss(y ~ 0 + x, sigma.fo = ~ 0 + x, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m1 <- tryCatch( gamlss(y ~ 0 + x, sigma.fo = ~ 1, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m2 <- tryCatch( gamlss(y ~ 1, sigma.fo = ~ 0 + x, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)

   m0a <- tryCatch( gamlss(y ~ 0 + x2, sigma.fo = ~ 0 + x2, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m1a <- tryCatch( gamlss(y ~ 0 + x2, sigma.fo = ~ 1, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
   m2a <- tryCatch( gamlss(y ~ 1, sigma.fo = ~ 0 + x2, data = df, n.cyc=1000), warning = function(w) NULL, error = function(e) NULL)
  sink()

  if(any(sapply(list(m0,m1,m2), is.null))) {
    res1 <- data.frame(mu_ctl = NA, mu_h1n0 = NA, mu_h1n1 = NA, v_ctl = NA, v_h1n0 = NA, v_h1n1 = NA, V_ave = NA, p_mu = NA, p_sigma=NA)
  } else {
      p_mu <- pchisq(2*as.numeric(logLik(m0)-logLik(m2)), m0$df.fit-m2$df.fit, lower.tail=F)
      p_sigma <- pchisq(2*as.numeric(logLik(m0)-logLik(m1)), m0$df.fit-m1$df.fit, lower.tail=F)
      mu <- mean(df$y) + m0$mu.coefficients
      sigma <- exp(m0$sigma.coefficients)^2
      # results:
      # mu_ctl - mean gene expression for control
      # mu_h1n0 - mean gene expression for H1N1 early
      # mu_h1n1 - mean gene expression for H1N1 late
      # v_ctl - gene expression variance for control
      # v_h1n0 - gene expression variance for H1N1 early
      # v_h1n1 - gene expression variance for H1N1 late
      # V_ave - pooled gene expression variance
      # p_mu - significance of H1N1 effect on mean gene expression
      # p_sigma - significance of H1N1 effect on gene expression noise (sigma - standard deviation)
      res1 <- data.frame(mu_ctl = mu[[1]], mu_h1n0 = mu[[2]], mu_h1n1 = mu[[3]],
        v_ctl = sigma[[1]], v_h1n0 = sigma[[2]], v_h1n1 = sigma[[3]], V_ave = exp(m1$sigma.coefficients)^2,
        p_mu = p_mu, p_sigma=p_sigma)
  }

  if(any(sapply(list(m0a,m1a,m2a), is.null))) {
    res2 <- data.frame(mu2_ctl = NA, mu2_h1n = NA, v2_ctl = NA, v2_h1n = NA, p2_mu = NA, p2_sigma=NA)
  } else {
      p2_mu  <- pchisq(2*as.numeric(logLik(m0a)-logLik(m2a)), m0a$df.fit-m2a$df.fit, lower.tail=F)
      p2_sigma <- pchisq(2*as.numeric(logLik(m0a)-logLik(m1a)), m0a$df.fit-m1a$df.fit, lower.tail=F)
      mu2 <- mean(df$y) + m0a$mu.coefficients
      sigma2 <- exp(m0a$sigma.coefficients)^2
      # results:
      # mu2_ctl - mean gene expression for control
      # mu2_h1n - mean gene expression for H1N1 (early/late)
      # v2_ctl - gene expression variance for control
      # v2_h1n - gene expression variance for H1N1 (early/late)
      # p2_mu - significance of ctl vs H1N1 effect on mean gene expression
      # p2_sigma - significance of ctl vs H1N1 effect on gene expression noise (sigma - standard deviation)
      res2 <- data.frame(mu2_ctl = mu2[[1]], mu2_h1n = mu2[[2]],
        v2_ctl = sigma2[[1]], v2_h1n = sigma2[[2]],
        p2_mu = p2_mu, p2_sigma=p2_sigma)
  }

  res <- cbind(res1, res2)
}, mc.cores=6)
gene_noise_H1N <- do.call(rbind, gene_noise_H1N)
gene_noise_H1N$padj_sigma <- p.adjust(gene_noise_H1N$p_sigma, "BH")
gene_noise_H1N$padj_mu <- p.adjust(gene_noise_H1N$p_mu, "BH")
rownames(gene_noise_H1N) <- rownames(eset_H1N1)

rm(f, affyData, affyData_out,eset_H1N1)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
save.image("CAP_Sepsis_H1N1_gene_noise_Figure1.Rdat")


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 16, 2016

number_vals<-100
x<-rnorm(number_vals)
y<-rnorm(number_vals)
plot(1, 1,
     xlim= c(min(x), max(x)),
     ylim= c(min(y), max(y)), col=0)
points(x, y)
the_expression<-paste("Plotting y vs. x",
                      "\n sigma x = ", format(sd(x), digits=4, scientific=F),
                      "\n sigma y = ", format(sd(y), digits=4, scientific=F),  sep="")
title(the_expression)
grid()


# Day 6: Lanternfish

get_day6_input_path <- function() {
    paste(getwd(), "/2021/Day 6/Day6_input.txt", sep = "")
}

part1 <- function(num_days = 80) {
    readings <- readLines(get_day6_input_path())

    days <- num_days
    fishies <- strtoi(unlist(strsplit(readings[1], ",")))

    lanternfish <- optimize_fishies(fishies, c(1:5))

    for (i in 1:days) {
        lanternfish[, 1] <- lanternfish[, 1] - 1

        sum_new_fishies <- sum(lanternfish[which(lanternfish[, 1] == -1), 2])

        lanternfish[, 1][lanternfish[, 1] == -1] <- 6
        if (sum_new_fishies > 0) {
            lanternfish <- rbind(lanternfish, c(8, sum_new_fishies))
        }
    }
    print(sum(lanternfish[, 2]))
    print(paste(sum(lanternfish[, 2])))
}

part2 <- function() {
    part1(256)
}

optimize_fishies <- function(fishies, starting_vals) {
    lanternfish <- matrix(ncol = 2)[-1, ]

    for (i in seq_len(length(starting_vals))) {
        sum_of_i <- sum(fishies == i)
        if (sum_of_i > 0) {
            lanternfish <- rbind(lanternfish, c(i, sum_of_i))
        }
    }

    lanternfish
}

part1()
part2()


#' Function to allocate the rate distribution between 2 variables to rate quadrants
#'
#' This function allocates the rate distribution between 2 variables to rate quadrants
#' @param ieObject object comprising the output of an ie analysis
#' @return list of ratedistribution elements and branches for each quadrant
#' @export

ieRateDistr<-function(Y,X,neutral){
            #relative rate
                    YvX<-Y[1:3]
                    D<-Y$rate-X$rate
                    YvX<-cbind(YvX,Y$rate)
                    YvX<-cbind(YvX,X$rate)
                    YvX<-cbind(YvX,D)
                    MA<-sqrt((D^2)-((sqrt(2*(D^2))/2)^2))
                    MAresidual<-MA
                    YvX<-cbind(YvX,MAresidual)
                          negatives<-which(YvX$D<0)
                          for(i in negatives){
                          YvX$MAresidual[i]<-YvX$MAresidual[i]*(-1)}
                    colnames(YvX)<-c("node_anc","node_desc","BL","Y_rate","X_rate","D","MAresidual")

            #neutral
                  neutral_max<-neutral
                  neutral_min<-(-neutral)
            #accellerated increase
                  AI<-which(YvX$MAresidual>neutral_max & Y$rate>0 & X$rate>0 & Y$rate>neutral)
            #decellerated increase
                  DI<-which(YvX$MAresidual<neutral_min & Y$rate>0 & X$rate>0 & X$rate>neutral)
            #decellerated decrease
                  DD<-which(YvX$MAresidual>neutral_max & Y$rate<0 & X$rate<0 & X$rate<(-neutral))
            #accellerated decrease
                  AD<-which(YvX$MAresidual<neutral_min & Y$rate<0 & X$rate<0 & Y$rate<(-neutral))
            #separation
                  S1<-c(which(YvX$MAresidual>neutral_max & Y$rate>0 & X$rate<0 & Y$rate>neutral),
                        which(YvX$MAresidual>neutral_max & Y$rate>0 & X$rate<0 & Y$rate<=neutral & X$rate< (-(neutral))))
                  S2<-c(which(YvX$MAresidual<neutral_min & Y$rate<0 & X$rate>0 & Y$rate<(-neutral)),
                        which(YvX$MAresidual<neutral_min & Y$rate<0 & X$rate>0 & Y$rate>=(-neutral) & X$rate> neutral))
            #all
                  all<-c(S1,AI,DI,S2,AD,DD)

      #Return
            results<-list(YvX,S1,AI,DI,S2,AD,DD,all)
            names(results)<-c("YvX","S1","AI","DI","S2","AD","DD","All")
            return(results)

}


library(qcc)

death=c(2,1,2,4,2,5,3,3,5,6,3,8,3,3,6,3,6,5,3,5,2,6,2,3,4,3,2,9,2,2,3,2,10,7,9,6,2,1,2,4,2,5,3,3,5,6,3,8,3,3,6,3,6,5,3,5,2,6,2,3,4,3,2,9,2,2,3,2,10,7,9,6,2,1,2,4,2,5,3,3,5,6,3,8,3,3,6,3,6,5,3,5,2,6,2,3,4,3,2,9,2,2,3,2,10,7,9,6)
freq.table=table(death)
print(freq.table)

pareto.result <-pareto.chart(freq.table, main="사망원인", xlab="질병종류", ylab="Frequency", ylab2="Cumulative Percentage")

legend(x="right", legend=c("빈도수","누적상대도수"),lty=c(0,1),pch=c(-1,20), fill=c("orange",0), title="범례", border=c("black","white"))


library(tidyverse)
library(cmdstanr)
library(posterior)
library(bayesplot)
library(ggfan)

#generate some data
n = 2^5 #bigger n will take longer; 2^7 takes about 90s on a reasonably modern cpu
#x can be anything (doesn't have to be on a grid)
x = 1:n
# x = sort(runif(n,0,1))
generate_mod = cmdstan_model('stan/pvgp_generate.stan',force_recompile = T)
generated = generate_mod$generate_quantities(
	data = lst(
		n = n
		, x = x
		, pvn_ = .2
		, lengthscale_ = .1*diff(range(x))
		, sample_pvn = F
		, sample_lengthscale = F
	)
	, fitted_params = as_draws_array(tibble(dummy=0))
)

#extract quantities
(
	generated$draws(c('f','y'),format ="draws_list" )
	%>% as_draws_df()
	%>% as_tibble()
	%>% select(-.chain,-.iteration,-.draw)
	%>% pivot_longer(everything())

	%>% separate(
		name
		, into = c('name','index')
		, convert = TRUE
	)
	# %>% View())
	%>% pivot_wider()
	%>% mutate(
		x = x[index]
	)
) -> dat

#quick viz:
(
	dat
	%>% ggplot(aes(x=x))
	+ geom_point(aes(y=y),alpha=.5)
	+ geom_line(aes(y=f),alpha=.5)
)

dx = matrix(NA,n,n)
for(i in 1:n){
	for(j in 1:n){
		dx[i,j] = -((x[i]-x[j])^2)/2
	}
}

dx_ut_flat = as.numeric(dx[upper.tri(dx)])
udx = unique(dx_ut_flat)
dx_lt_flat = as.numeric(dx[lower.tri(dx)])

i_uk_k_ut = match(dx_ut_flat,udx)
i_uk_k_lt = match(dx_lt_flat,udx)
i_k_diag = which(as.numeric(diag(1,n,n))==1)
i_k_ut = which(as.numeric(upper.tri(matrix(NA,n,n)))==1)
i_k_lt = which(as.numeric(lower.tri(matrix(NA,n,n)))==1)

data_for_stan = lst(
	n_xy = nrow(dat)
	, x = dat$x
	, y = dat$y
	, udx = udx
	, i_uk_k_ut = i_uk_k_ut
	, i_uk_k_lt = i_uk_k_lt
	, i_k_diag = i_k_diag
	, i_k_ut = i_k_ut
	, i_k_lt = i_k_lt
	, n_udx = length(udx)
	, n_ut = length(i_k_ut)
)
glimpse(data_for_stan)

#sample
sample_mod = cmdstan_model('stan/pvgp_sample.stan',force_recompile=T)
sampled = sample_mod$sample(
	data = data_for_stan
	, chains = parallel::detectCores()/2
	, parallel_chains = parallel::detectCores()/2
	, refresh = 20
)

#check timing
p = sampled$profiles()
(
	p
	%>% bind_rows()
	%>% select(name,total_time)
	%>% group_by(name)
	%>% summarise(
		min = min(total_time)
		, max = max(total_time)
	)
)

#check diagnostics
sampled$cmdstan_diagnose()

#check that delta is small
sampled$draws('delta',format='rvars')

#check summary of hyperparameters
sampled$summary(variables=c('pvn','lengthscale'))

#check pairs plot
(
	c('pvn','lengthscale')
	%>% sampled$draws()
	%>% mcmc_pairs(
		np = nuts_params(sampled)
		, off_diag_fun = 'hex'
	)
)

#extract the samples for f
(
	sampled$draws('f',format='draws_df')
	# %>% as_draws_df()
	%>% as_tibble()
	%>% pivot_longer(starts_with('f'))
	%>% separate(
		name
		, into = c('name','index')
		, convert = TRUE
	)
) -> f_samples

#join with the data and plot
(
	f_samples
	%>% left_join(dat)
	%>% ggplot(aes(x=x))
	+ geom_fan(aes(y=value),intervals=seq(.01,.99,.01))
	+ scale_fill_viridis_c(direction=-1,guide='none')
	+ geom_interval(aes(y=value),intervals=.5,linetype=3,colour='black')
	+ geom_line(data=dat,aes(y=f),colour='white',size=1)#,alpha = .8)
	+ geom_point(data=dat,aes(y=y),alpha=.5,size=2,colour='black')
	+ geom_point(data=dat,aes(y=y),alpha=.5,size=2,colour='white',shape=1)
	+ theme(
		panel.grid = element_blank()
		, panel.background = element_rect(fill='black')
	)
)


rm(list=ls())

library('radolc')

#--- testing ADOLC's hessian vector product
fr <- function(x) {   ## Rosenbrock Banana function
  x1 <- x[1]
  x2 <- x[2]
  y <- 100 * (x2 - x1 * x1)* (x2 - x1 * x1) + (1 - x1)*(1 - x1)
  y }

trace_on(1)
x <- adolc_createList(2,2.0)
badouble_declareIndependent(x)
y <- fr(x)
badouble_declareDependent(y)
trace_off()

xx <- c(1.0,2.0)
vv <- c(3.0,5.5)
yy <- c(0.0,0.0)
hess_vec(1,2,xx,vv,yy) # result z = \nambla^2F(x)v
#hess_vec(tag,n,x,v,z)
# tag: integer, tape identification
# n  : integer, number of independents n and m = 1
# x[n]: independent vector x
# v[n]: vector
# z[n]: resulting Hessian vector product

print(yy)

#Always detach the package
detach(package:radolc, unload=TRUE)


#Naive bayes
library(caTools)
library(rpart)
library(rpart.plot)
library(caret)
library(e1071)
set.seed(125)
myd=read.csv('diabetes.csv')

myd$Outcome=factor(myd$Outcome,
                   c(0,1))

split=sample.split(myd,SplitRatio = 0.75)
train_data=subset(myd,split==TRUE)
test_data=subset(myd,split==FALSE)
classifier=naiveBayes(x=train_data,
                      y=train_data$Outcome)

pred=predict(classifier,newdata = test_data)
cm=table(test_data$Outcome,pred)
cm
result=confusionMatrix(pred,test_data$Outcome)
result

#Decision Tree

fit=rpart(train_data$Outcome~.,
          data=train_data,
          method="class")

#rpart.plot(fit)
pred1=predict(fit,newdata = test_data,type = "class")
cm1=table(test_data$Outcome,pred1)
result1=confusionMatrix(pred1,test_data$Outcome)
result1

Decision Tree Vs Naive Bayes/Classifier.r


# H0: BGP == Triple
# Compare means with one-way ANOVA

## Bloom
data <- read.csv('../../results/filter_types/plot_all.csv', sep = ';')
t.test(data$combination_2, data$combination_4,paired=TRUE)
# p: 0.5161
# => Accept H0, equal means
mean(data$combination_2) # 12284.03
mean(data$combination_4) # 16917.35
# BGP == Triple !

## GCS
data <- read.csv('../../results/filter_types/plot_all.csv', sep = ';')
t.test(data$combination_3, data$combination_5,paired=TRUE)
# p: 0.6197
# => Accept H0, equal means
mean(data$combination_3) # 12582.91
mean(data$combination_5) # 16145.51
# BGP == Triple !


# computation times ttest
asr_total <- read.table(file = "data/asr_total.csv",header = FALSE, dec = ".", col.names = "s", sep=",")
asr_total$method    <- c(rep("asr_total", 158)) # blocks: ca 6 per subject: 27*6

asr_minimal <- read.table(file = "data/asr_min.csv",header = FALSE, dec = ".", col.names = "s", sep=",")
asr_minimal$method    <- c(rep("asr_min", 158))

rasr_total <- read.table(file = "data/rasr_total.csv",header = FALSE, dec = ".", col.names = "s", sep=",")
rasr_total$method    <- c(rep("rasr_total", 158))

rasr_minimal <- read.table(file = "data/rasr_min.csv",header = FALSE, dec = ".", col.names = "s", sep=",")
rasr_minimal$method    <- c(rep("rasr_min", 158))

library(ez)
library(effsize)
source("pairwise.t.test.with.t.and.df.R")
# minimal times
all <- rbind(asr_minimal, rasr_minimal)
result <- pairwise.t.test.with.t.and.df(all$s, all$method, adjust.method="bonf", paired=TRUE)
# p-value
print(result)
# Print t-values
print(c("t-value: ", result[[5]]))
# Print dfs
print(c("Df: ", result[[6]]))
# Cohen's D for t-test
cohen.d(all$s, as.factor(all$method), paired = TRUE)

# total times
all <- rbind(asr_total, rasr_total)
result <- pairwise.t.test.with.t.and.df(all$s, all$method, adjust.method="bonf", paired=TRUE)
# p-value
print(result)
# Print t-values
print(c("t-value: ", result[[5]]))
# Print dfs
print(c("Df: ", result[[6]]))
# Cohen's D for t-test
cohen.d(all$s, as.factor(all$method), paired = TRUE)

wilcox.test(rasr_minimal$s, asr_minimal$s, paired=TRUE)


library(data.table)
library(stringr)

SAMPLERDIRS <- c("mala", "smmala_reverse", "amsmmala", "alsmmala")

DATADIR <- "../../data"
OUTDIR <- "../output"

nsamplerdirs <- length(SAMPLERDIRS)

nchains <- 10
nmcmc <- 110000
nburnin <- 10000
npostburnin <- nmcmc-nburnin

maxlag <- 50
ci <- 3
pi <- 7

cors <- matrix(data=NA, nrow=maxlag+1, ncol=nsamplerdirs)

for (j in 1:nsamplerdirs) {
  chains <- t(fread(
    file.path(DATADIR, SAMPLERDIRS[j], paste("chain", str_pad(ci, 2, pad="0"), ".csv", sep="")), sep=",", header=FALSE
  ))

  cors[, j] <- acf(chains[, pi], lag.max=maxlag, demean=TRUE, plot=FALSE)$acf
}

sqrtnpostburnin <- sqrt(npostburnin)

cols <- c("green", "blue", "red", "orange")

pdf(file=file.path(OUTDIR, "tdist_acfplot.pdf"), width=10, height=6)

plot(
  0:maxlag,
  cors[, 1],
  type="o",
  ylim=c(-0.2, 1.),
  col=cols[1],
  lwd=2,
  pch=20,
  xlab="",
  ylab="",
  cex.axis=1.8,
  cex.lab=1.7,
  yaxt="n"
)

axis(
  2,
  at=seq(-0.2, 1, by=0.2),
  labels=seq(-0.2, 1, by=0.2),
  cex.axis=1.8,
  las=1
)

lines(
  0:maxlag,
  cors[, 2],
  type="o",
  col=cols[2],
  lwd=2,
  pch=20
)

lines(
  0:maxlag,
  cors[, 3],
  type="o",
  col=cols[3],
  lwd=2,
  pch=20
)

lines(
  0:maxlag,
  cors[, 4],
  type="o",
  col=cols[4],
  lwd=2,
  pch=20
)

legend(
  36, 0.6,
  c("MALA", "SMMALA", "AMSMMALA", "ALSMMALA"),
  lty=c(1, 1, 1),
  lwd=c(5, 5, 5),
  col=cols,
  cex=1.5,
  bty="n"
)

sqrt(npostburnin)

abline(h=1.96/sqrtnpostburnin, lty=2)
abline(h=-1.96/sqrtnpostburnin, lty=2)

dev.off()


source("split_samples_utils.r")

library(Seurat)
library(ggplot2)

#devtools::install_github("shengqh/cutoff")
#install.packages("bbmle")
library(zoo)
library(reshape2)
library(gridExtra)
library(ggExtra)

library(bbmle)
library(choisycutoff)

#still keep it here in case we need it later.
my_startval <- function(values,D1="normal",D2="normal",cutoff_point=0) {
  if(cutoff_point >0){
    thresh = cutoff_point
  }else{
    den <- tryCatch(
      expr = {
        density(values, bw="SJ")
      },
      error = function(e){
        density(values)
      }
    )
    w=1
    x=den$x
    y=den$y
    y.smooth=den$y
    n <- length(y.smooth)
    y.max <- rollapply(zoo(y.smooth), 2*w+1, max, align="center")
    delta <- y.max - y.smooth[-c(1:w, n+1-1:w)]
    i.max <- which(delta <= 0) + w
    res=data.frame(x=x[i.max], i=i.max, y=y[i.max])
    res=res[res$x>0,]
    res=res[order(res$y, decreasing = T),]

    if(nrow(res)>2){
      res=res[1:2,]
    }

    xx=x[x>min(res$x) & x<max(res$x)]
    yy=y[x>min(res$x) & x<max(res$x)]
    yy.min=min(yy)
    ii.min=which(yy==yy.min)
    thresh=xx[ii.min]
  }

  sel <- values<thresh
  data1 <- values[sel]
  data2 <- values[!sel]
  lambda <- length(data1)/length(values)
  param1 <- MASS::fitdistr(data1,D1)$est
  param2 <- MASS::fitdistr(data2,D2)$est
  out <- c(param1,param2,lambda)
  names(out) <- c("mu1","sigma1","mu2","sigma2","lambda")
  return(out)
}

get_cutoff<-function(values, prefix, cutoff_startval=NA){
  my_out <- em(values,"normal","normal", cutoff_startval=cutoff_startval)
  cut_off <- cutoff(my_out)
  png(paste0(prefix, ".cutoff.png"), width=2000, height=1600, res=300)
  hist(values,200,F,xlab="concentration",ylab="density", main=NULL,col="grey")
  lines(density(values),lwd=1.5,col="blue")
  lines(my_out,lwd=1.5,col="red")
  abline(v=cut_off[1],lwd=1.5,col="brown")
  abline(v=my_out$start.val,lwd=1.5,col="green")
  dev.off()
  return(list(em_out=my_out, cut_off=cut_off))
}

files_lines=read.table(parSampleFile1, sep="\t")
files=split(files_lines$V1, files_lines$V2)

if(parSampleFile2 != ''){
  cutoffs_lines=read.table(parSampleFile2, sep="\t")
  cutoffs=split(cutoffs_lines$V1, cutoffs_lines$V2)
}else{
  cutoffs=list()
}

params_lines=read.table(parSampleFile3, sep="\t")
params=split(params_lines$V1, params_lines$V2)
params$hto_ignore_exists=ifelse(params$hto_ignore_exists=="0", FALSE, TRUE)

idx=14
for(idx in c(1:length(files))){
  fname=names(files)[idx]
  output_prefix = paste0(fname, ".HTO")
  output_file=paste0(output_prefix, ".csv")

  #if(file.exists(output_file) & params$hto_ignore_exists){
  #  next
  #}

  rdsfile=files[[idx]]
  cat(fname, ":", rdsfile, " ...\n")

  obj=read_hto(rdsfile, output_prefix)

  cutoff_point=ifelse(fname %in% names(cutoffs), as.numeric(cutoffs[[fname]]), NA)

  tagnames=rownames(obj[["HTO"]])
  data <- FetchData(object=obj, vars=tagnames)
  write.csv(data, file=paste0(output_prefix, ".data.csv"))

  res=NULL
  tagname=tagnames[1]
  for (tagname in tagnames) {
    values=data[,tagname]
    values=values[values>0]
    cat(paste0("get cutoff of ", tagname, " ...\n"))
    my_cutoff=get_cutoff(values, paste0(output_prefix, "_", tagname), cutoff_point)
    data[,paste0(tagname,"_pos")] = ifelse(data[,tagname]>my_cutoff$cut_off[1], tagname, "Negative")
    res<-rbind(res, data.frame(
      start.val=my_cutoff$em_out$start.val,
      mu1=my_cutoff$em_out$param["mu1"],
      sigma1=my_cutoff$em_out$param["sigma1"],
      mu2=my_cutoff$em_out$param["mu2"],
      sigma2=my_cutoff$em_out$param["sigma2"],
      cutoff=my_cutoff$cut_off[1]))
  }
  rownames(res)=tagnames
  write.csv(res, paste0(output_prefix, ".estimated.csv"))

  cat(paste0("get classification ...\n"))
  class_names=paste0(tagnames, "_pos")
  data$HTO_classification=unlist(apply(data, 1, function(x){
    xx=unique(x[class_names])
    if (length(xx) > 1){
      xx = xx[xx != "Negative"]
      if (length(xx) > 1) {
        return("Doublet")
      }
    }
    return(xx)
  }))

  data$HTO_classification.global=unlist(apply(data, 1, function(x){
    xx=unique(x[class_names])
    if (length(xx) > 1){
      xx = xx[xx != "Negative"]
      if (length(xx) > 1) {
        return("Doublet")
      }else{
        return("Singlet")
      }
    }
    return("Negative")
  }))

  obj[["HTO_classification"]] = data$HTO_classification
  obj[["HTO_classification.global"]] = data$HTO_classification.global

  output_post_classification(obj, output_prefix)
}


sierpinski.triangle = function(n) {
	len <- 2^(n+1)
	b <- c(rep(FALSE,len/2),TRUE,rep(FALSE,len/2))
	for (i in 1:(len/2))
	{
		cat(paste(ifelse(b,"*"," "),collapse=""),"\n")
		n <- rep(FALSE,len+1)
		n[which(b)-1]<-TRUE
		n[which(b)+1]<-xor(n[which(b)+1],TRUE)
		b <- n
	}
}
sierpinski.triangle(5)


library(tree)
data(iris)

# Dataset
sample <- iris[sample(nrow(iris)), ]
train <- sample[1:105, ]
test <- sample[106:150, ]

# Training
model <- tree(Species~., train)
summary(model)

plot(model)
text(model)

# Testing
pred <- predict(model, test[, -5], type = "class")
table(pred, test$Species)


#' @title
#' Generate initial estimators
#'
#' @description
#' This function provides the initial estimators of U and V to initialize the
#' blockwise coordinate descent algorithm.
#'
#' @usage
#' NRRR.ini(Y, X, r, rx, ry, jx, jy, p, d, n)
#'
#'
#' @param Y response matrix of dimension n-by-jy*d.
#' @param X design matrix of dimension n-by-jx*p.
#' @param r rank of the local reduced-rank structure.
#' @param rx number of latent predictors.
#' @param ry number of latent responses.
#' @param jx number of basis functions to expand the functional predictor.
#' @param jy number of basis functions to expand the functional response.
#' @param p number of predictors.
#' @param d number of responses.
#' @param n sample size.
#'
#'
#' @return The function returns a list:
#'   \item{Ag}{the estimated U.}
#'   \item{Bg}{the estimated V.}
#'
#' @references Liu, X., Ma, S., & Chen, K. (2020).
#' Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
#'
#' @examples
#' library(NRRR)
#' simDat <- NRRR.sim(n = 100, ns = 200, nt = 200, r = 5, rx = 3, ry = 3,
#'                    jx = 15, jy = 15, p = 10, d = 6, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' fit_init <- with(simDat, NRRR.ini(Y = Yest, X = Xest, r = 5,
#'                  rx = 3, ry = 3, jx = 15, jy = 15,
#'                  p = 10, d = 6, n = 100))
#' fit_init$Ag
#' @export
NRRR.ini <- function(Y,X,r,rx,ry,jx,jy,p,d,n){
  #require(rrpack)
  if (r == 0) stop("r cannot be 0")
  if (r > min(dim(Y)[2])) stop("r cannot be greater than jy*d")
  if(p < rx) stop("rx cannot be greater than p")
  if(d < ry) stop("ry cannot be greater than d")

  # ignore the global structure to estimate C from RRR
  fit_RRR <- RRR(Y,X,nrank=r)
  Crr <- fit_RRR$C
  # Compute Bghat, i.e, V
  if(p==rx){
    Bghat <- diag(nrow=rx,ncol=rx)
  }else{
    Cbg <- matrix(nrow=p,ncol=d*jy*jx,NA)
    for(j in 1:jx){
      a1 <- d*jy*(j-1) + 1
      b1 <- d*jy*j

      a2 <- p*(j-1) + 1
      b2 <- p*j
      Cbg[,a1:b1] <- Crr[a2:b2,]
    }
    Bghat <- as.matrix(svd(Cbg, nu=rx,nv=rx)$u)
  }

  #Compute Aghat, i.e., U
  if(d==ry){
    Aghat <- diag(nrow=ry,ncol=ry)
  }else{
    Cag <- matrix(nrow=d,ncol=p*jy*jx,NA)
    for(j in 1:jy){
      a1 <- p*jx*(j-1) + 1
      b1 <- p*jx*j

      a2 <- d*(j-1) + 1
      b2 <- d*j

      Cag[,a1:b1] <- t(Crr[,a2:b2])
    }
    Aghat <- as.matrix(svd(Cag, nu=ry,nv=ry)$u)
  }

  return(list(Ag=Aghat,Bg=Bghat,C=Crr))
}


plot(c(), c(), ylim=c(0,40), xlim=c(0,1), yaxt='n')
axis(side=2, at=(0:4)*10, labels=(0:4)*50)
r = matrix(0, nrow = 40, ncol=11)
for (y in 2:40) {
    n = 5*y
    m = 50 * (10000/n)
    sum = rep(0, len=11)
    for (i in 1:m) {
        sum = sum + quantile(runif(n=y), seq(0,1,0.1))
    }
    r[y,] = sum/m
    print(y)
}
for (x in 1:11) {
    lines(r[2:40,x], 2:40, type='b')
}

plot(c(), c(), ylim=c(0,40), xlim=c(1e-6,0.03), yaxt='n', log='x')
axis(side=2, at=(0:4)*10, labels=(0:4)*1000)
for (i in 1:40) {
    n = i * 1000
    m = 1e6/n
    r = rep(0,4)
    for (j in 1:m) {
        r = r + quantile(runif(n), c(0, 0.001, 0.01, 0.02))
    }
    r = r/m
    points(r, rep(i, 4))
}


#' F2C
#'
#' Convert temperature from Fahrenheit degree to  Celsius degree.
#'
#' @param numeric F Temperature in Fahrenheit degrees
#' @return umeric  Temperature in Celsius degrees.
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  F2C
#'
#' @export
#'
#'
#'
#'

F2C<-function(tF)
{
  return (tF * 0.555556- 17.7778);
}


#'@title calcHMTotalRes
#'
#' @description Calculate total ship resistance (\code{Rtot}) (kN) using the
#' Holtrop & Mennen method.
#'
#' @param Rapp Appendage resistance (vector of numericals, kN) (see
#' \code{\link{calcHMAppendageRes}})
#' @param Rw Wave waking (similar to residual) resistance (vector of numericals, kN)
#' (see \code{\link{calcHMWaveMakingRes}})
#' @param Rb Bulbous bow resistance (vector of numericals, kN) (see
#' \code{\link{calcHMBulbousBowRes}})
#' @param Rtr Immersed transom resistance (vector of numericals, kN) (see
#' \code{\link{calcHMImmersedTransomRes}})
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^2). Can
#' supply either a vector of numericals, a single number, or rely on the default
#' @param wettedSA Wetted hull surface area (vector of numericals, m^2) (see
#' \code{\link{calcHMWettedSA}})
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param Cf Frictional resistance coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCf}})
#' @param formFactor Form factor (1+k) (vector of numericals, dimensionless)
#' (see \code{\link{calcHMFormFactor}})
#' @param Ca Incremental hull (roughness) resistance coefficient (vector of
#' numericals, dimensionless) (see \code{\link{calcHMCa}})
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item Coastal operations = 10 \item At-sea operations = 15 (default)}.
#' Can supply either a vector of numericals, a single number, or rely on the default
#'
#' @details
#' Note that service margin is included here as a resistance term.
#'
#' @return \code{Rtot} (vector of numericals, kN)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#' @seealso \code{\link{calcSpeedUnitConversion}}
#'
#' @family Holtrop-Mennen Calculations
#' @family Resistance Calculations
#'
#' @examples
#' calcHMTotalRes(Rapp=0.24,
#'                Rw=2.6,
#'                Rb=c(4.538188e-07,3.579217e-06,1.180116e-05,2.709520e-05,5.085940e-05),
#'                Rtr=c(0.58,2.2,4.8,8.1,12.1),
#'                seawaterDensity=1.025,
#'                wettedSA=10746.282,
#'                shipSpeed=seq(1,5,1),
#'                Cf=c(0.0019,0.0017,0.0016,0.0016,0.0015),
#'                formFactor=1.275601,
#'                Ca=0.0003356088,
#'                serviceMargin=15)
#'
#' @export

calcHMTotalRes<- function(Rapp,Rw,Rb,Rtr,seawaterDensity,wettedSA,shipSpeed,
                          Cf,formFactor,Ca,serviceMargin){
  Rtot<-
(    Rapp+Rw+Rb+Rtr+
    (.5*seawaterDensity*wettedSA*((shipSpeed)^2)*Cf)*(formFactor)+
    (.5*seawaterDensity*wettedSA*((shipSpeed)^2)*Ca))*(1+serviceMargin/100)
  return(Rtot)
}


# Load tag intent data and calculate inter-rater agreement

json.tagOverlap1 <- read.csv(file="json_overlap_1.csv", header = TRUE)
django.tagOverlap1 <- read.csv(file="django_overlap_1.csv", header = TRUE)
regex.tagOverlap1 <- read.csv(file="regex_overlap_1.csv", header = TRUE)
head(json.tagOverlap1)

# load the library
library(irr)

kappam.fleiss(json.tagOverlap1[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(django.tagOverlap1[c("Rater1", "Rater2", "Rater3")])

kappam.fleiss(regex.tagOverlap1[c("Rater1", "Rater2", "Rater3")])

tagOverlap1 <- rbind(json.tagOverlap1, django.tagOverlap1, regex.tagOverlap1)
kappam.fleiss(tagOverlap1[c("Rater1", "Rater2", "Rater3")])

# only for sanity check
kappam.fleiss(json.tagOverlap1[c("ResRater1", "ResRater2", "ResRater3")])

kappam.fleiss(django.tagOverlap1[c("ResRater1", "ResRater2", "ResRater3")])

kappam.fleiss(regex.tagOverlap1[c("ResRater1", "ResRater2", "ResRater3")])


#' Z-polytope sampler for linear inverse problems
#'
#' For the linear inverse problem y=Ax where y and x are counts, the y-fibre (solution set) is a Z-polytope (i.e. the points on the integer lattice within a convex polytope). This function implements samplers for the Z-polytope, with using a dynamic lattice basis or a full Markov basis. The underyling model for x can be Poisson, uniform or negative binomial.
#' @param y Vector of observed count data.
#' @param A Model configuration matrix, assumed to be binary.
#' @param lambda Mean vector for x.
#' @param U Optional matrix the columns of which should be a Markov (sub)-basis.
#' @param Method "MH" for Metropolis-Hastings sampler, "Gibbs" for Gibbs sampler.
#' @param Reorder Should the columns of A be reordered? Defaults to TRUE.
#' @param tune.par Tuning parameter (alpha) controlling variation in fitness values for lattice bases. Defaults to 0.5.
#' @param combine Should extra moves be included combining lattice basis vectors? Defaults to FALSE, but should usually be set to TRUE if A is not unimodular.
#' @param x.order If Reorder=FALSE, x.order can be used to reorder columns of A to match ordering of entries of x. Defaults to NULL when no such reordering is performed.
#' @param x.ini Vector of initial values for x. Default is NULL, when initial values derived through integer programming.
#' @param Model "Poisson", "Uniform", "NegBin" or "Normal" (the last being a discrete approximation).
#' @param Proposal "NonUnif" or "Unif" (default).
#' @param NB.alpha Dispersion parameter for negaqtive-binomial distribution. Defaults to 1.
#' @param ndraws Number of iterations to run sampler after burn-in. One iteration comprises cycling through the full basis (possibly augmented by a combined move). Defaults to 10^4.
#' @param burnin Number of iteractions for burn in period. Defaults to 2000, which is usually more than adequate.
#' @param verbose Controls level of detail in recording lattice bases used.
#' @param THIN Thinning parameter for output. Defaults to 1 (no thinning).
#' @return A list with components X (a matrix, each row corresponding to samplers for an entry of x) and x.order (a vector describing dynamic selection of lattice bases, if verbose=1).
#' @export
#' @examples
#' data(LondonRoad)
#' Xsampler(A=LondonRoad$A,y=LondonRoad$y,lambda=LondonRoad$lambda,Model="Poisson",Method="Gibbs",tune.par=0.5,combine=FALSE)

Xsampler <- function (y, A, lambda, U=NULL, Method="MH", Reorder=TRUE, tune.par=0.5, combine=FALSE, x.order=NULL, x.ini=NULL, Model="Poisson", Proposal="Unif", NB.alpha=1, ndraws = 10000, burnin = 2000, verbose = 0, THIN = 1) {
	require(lpSolve)
	require(numbers)
	require(extraDistr)
  	if(Model=="NegBin" & NB.alpha<=0) NB.alpha=1
	if(Model=="Uniform") Method <- "Gibbs"
	y <- as.numeric(y)
	r <- ncol(A)
	n <- nrow(A)
	tol <- 10^{-10}

	if (is.matrix(U)) Reorder=FALSE

	if (Reorder){
		lambda.star <- lambda
		lam.order <- order(lambda.star,decreasing=TRUE)
		A <- A[,lam.order]
		x.order <- lam.order
		for (i in 3:n){
			while (qr(A[,1:i])$rank < i){
				A <- A[,c(1:(i-1),(i+1):r,i)]
				x.order <- x.order[c(1:(i-1),(i+1):r,i)]
			}
		}
	}

	if (!Reorder) {
		if(is.null(x.order)) x.order <- 1:r
		A <- A[,x.order]
	}

	lambda <- lambda[x.order]

	if (is.matrix(U)){
	 	dA1 <- 1
		tune.par <- -1
	}
	if (!is.matrix(U)){
		A1 <- A[,1:n]
		dA1 <- det(A1)
		A2 <- as.matrix(A[,-c(1:n)])
		A1.inv <- solve(A1)
		C <- A1.inv%*%A2
		U <- rbind(-C,diag(r-n))
	}

	m <- ncol(U) + 1*combine

	X <- matrix(0, r, m*(ndraws + burnin)+1)
	if (verbose==1) X.ORDER <- matrix(0, r, m*(ndraws + burnin)+1)

	if (!is.null(x.ini)) x.ini <- x.ini[x.order]
	if (is.null(x.ini)){
		x.ini <- lp("max",objective.in=rep(1,r),const.mat=A,const.dir=rep("=",nrow(A)),const.rhs=y,all.int=T)$solution
	}
	x <- x.ini
      X[x.order,1] <- x
	if (verbose==1) X.ORDER[,1] <- x.order

	for (iter in seq(1, ndraws + burnin)) {
		for (j in 1:m){
			if (j <= ncol(U)) z <- U[,j]
			if (j > ncol(U)){
				delta <- 0
				while(sum(delta)==0) delta <- rpois(ncol(U),lambda=0.5)
				delta <- delta*sample(c(-1,1),size=ncol(U),replace=T)
				z <- U%*%delta
			}
			if (abs(dA1)!=1) { if(is_wholenumber(z)==F) z <- round(z*abs(dA1))/mGCD(round(abs(z*dA1))) }
			max.move <- floor(min((x/abs(z))[which(z<0)]))
			min.move <- -floor(min((x/abs(z))[which(z>0)]))
			x.min <- x+min.move*z
			x.max <- x+max.move*z
			indx <- 1:(max.move-min.move+1)
			update.indx <- which(z!=0)
			if (max(indx>1)){
				if (Method=="Gibbs"){
					if (Model!="Uniform") x.matrix <- round(t(mapply(seq,from=x.min[update.indx],by=z[update.indx],length.out=max.move-min.move+1)))
					if (Model=="Poisson") {
						log.probs <- colSums(dpois(x.matrix,lambda[update.indx],log=T))
						probs <- exp(log.probs-max(log.probs))
						x <- x.min + sample(indx-1,size=1,prob=probs)*z
					}
					if (Model=="NegBin"){
						log.probs <- colSums(dnbinom(x.matrix,mu=lambda[update.indx],size=lambda[update.indx]/NB.alpha,log=T))
						probs <- exp(log.probs-max(log.probs))
						x <- x.min + sample(indx-1,size=1,prob=probs)*z
					}
					if (Model=="Uniform") x <- x.min+sample(indx-1,size=1)*z
				}
				if (Method=="MH"){
					if (Proposal=="Unif") move.length <- sample(min.move:max.move,1)
					if (Proposal=="NonUnif"){
	            			if (Model=="Poisson") {
							aa <- x[n+j]+z[n+j]*min.move
							bb <- x[n+j]+z[n+j]*max.move
							move.length <- (rtpois(1,lambda=lambda[n+j],a=aa-0.5,b=bb)-x[n+j])/z[n+j]
							}
	            			if (Model=="NegBin") move.length <- sample(min.move:max.move,1,prob=dnbinom((x[n+j]+z[n+j]*min.move):(x[n+j]+z[n+j]*max.move),mu=lambda[n+j],size=lambda[n+j]/NB.alpha))
						if (Model=="Normal") move.length <- rtnorm(1,lambda[n+j],sd=sqrt((1+NB.alpha)*lambda[n+j]),lower=x[n+j]+z[n+j]*min.move,upper=x[n+j]+z[n+j]*max.move)
					}
					x.cand <- x + z*move.length
					if (Model=="Poisson"){
						L <- sum(dpois(x[update.indx],lambda[update.indx],log=T))
						L.cand <- sum(dpois(x.cand[update.indx],lambda[update.indx],log=T))
					}
					if (Model=="NegBin"){
						L <- sum(dnbinom(x[update.indx],mu=lambda[update.indx],size=lambda[update.indx]/NB.alpha,log=T))
						L.cand <- sum(dnbinom(x.cand[update.indx],mu=lambda[update.indx],size=lambda[update.indx]/NB.alpha,log=T))
					}
					if (Model=="Normal"){
						L <- sum(dnorm(x[update.indx],mean=lambda[update.indx],sd=sqrt((1+NB.alpha)*lambda[update.indx]),log=T))
						L.cand <- sum(dnorm(x.cand[update.indx],mean=lambda[update.indx],sd=sqrt((1+NB.alpha)*lambda[update.indx]),log=T))
					}
					if (Proposal=="Unif") acc.prob <- exp(L.cand - L)
					if (Proposal=="NonUnif"){
	            				if (Model=="Poisson"){
							q.can <- dpois(x.cand[n+j],lambda[n+j],log=T)
							q.cur <- dpois(x[n+j],lambda[n+j],log=T)
						}
	            				if (Model=="NegBin"){
							q.can <- dnbinom(x.cand[n+j],mu=lambda[n+j],size=lambda[n+j]/NB.alpha,log=T)
							q.cur <- dnbinom(x[n+j],mu=lambda[n+j],size=lambda[n+j]/NB.alpha,log=T)
						}
 						if (Model=="Normal") {
							q.can <- dnorm(x.cand[n+j],lambda[n+j],sqrt((1+NB.alpha)*lambda[n+j]),log=T)
							q.cur <- dnorm(x[n+j],lambda[n+j],sqrt((1+NB.alpha)*lambda[n+j]),log=T)
						}
			  			acc.prob <- exp(L.cand - L + q.cur - q.can)
					}
					if (is.na(acc.prob)) acc.prob <- 0
					if (runif(1) < acc.prob) x <- x.cand
				}
			}
			if (tune.par > 0){
                  	lambda.star <- rnorm(r,mean=lambda,sd=tune.par*lambda)
				ii <- sample(1:n,1)
				swap.indx <- abs(C[ii,])>tol
				if (any(swap.indx)){
					jj <- sample((1:(r-n))[swap.indx],1)
					if (lambda.star[ii] <= lambda.star[jj+n]/abs(C[ii,jj])){
					ei <- rep(0,n)
 					ej <- rep(0,r-n)
					ei[ii] <- 1
					ej[jj] <- 1
					dA1 <- round(C[ii,jj]*dA1)
					C <- C - outer(C[,jj]-ei,C[ii,]+ej)/C[ii,jj]
					U <- rbind(-C,diag(r-n))
					x.order[c(ii,jj+n)] <- x.order[c(jj+n,ii)]
					x[c(ii,jj+n)] <- x[c(jj+n,ii)]
 					lambda[c(ii,jj+n)] <- lambda[c(jj+n,ii)]
 					}
				}
			}
			X[x.order,1+(iter-1)*m+j] <- x
			if (verbose==1) X.ORDER[,1+(iter-1)*m+j] <- x.order
		}
	}
	if (verbose==1) x.order <- X.ORDER
	list(X=X[,seq(1,ncol(X),by=THIN)],x.order=x.order)
}


#ex from pg 29
size <- 1000
n <- 1
theta <- 0.485
phi <- (1-theta)/theta
y <- rbinom(n, size = size, prob = theta)
y2 <- rbinom(n, size = size, prob = phi)


# Computes the Kullback-Leibler divergence based on kernel density
# estimates with Gaussian kernel

kld_d = function(x,y,...){

  integrand = function(x,y,t){
    denx = density(x, na.rm = T)
    deny = density(y, na.rm = T)
    f.x =  approx(denx$x,denx$y,t)$y
    f.y =  approx(deny$x,deny$y,t)$y
    tmpRatio = f.x *(log2(f.x) - log2(f.y))
    tmpRatio = ifelse(is.infinite(tmpRatio),0,ifelse(is.na(tmpRatio),0,tmpRatio))
    tmpRatio
  }
  integrate(integrand,-Inf,Inf,x = x,y = y,stop.on.error=FALSE)$value

}


# Goals: To write functions
#        To write functions that send back multiple objects.

# FIRST LEARN ABOUT LISTS --
X = list(height=5.4, weight=54)
print("Use default printing --")
print(X)
print("Accessing individual elements --")
cat("Your height is ", X$height, " and your weight is ", X$weight, "\n")

# FUNCTIONS --
square <- function(x) {
  return(x*x)
}
cat("The square of 3 is ", square(3), "\n")

                 # default value of the arg is set to 5.
cube <- function(x=5) {
  return(x*x*x);
}
cat("Calling cube with 2 : ", cube(2), "\n")    # will give 2^3
cat("Calling cube        : ", cube(), "\n")     # will default to 5^3.

# LEARN ABOUT FUNCTIONS THAT RETURN MULTIPLE OBJECTS --
powers <- function(x) {
  parcel = list(x2=x*x, x3=x*x*x, x4=x*x*x*x);
  return(parcel);
}

X = powers(3);
print("Showing powers of 3 --"); print(X);

# WRITING THIS COMPACTLY (4 lines instead of 7)

powerful <- function(x) {
  return(list(x2=x*x, x3=x*x*x, x4=x*x*x*x));
}
print("Showing powers of 3 --"); print(powerful(3));

# In R, the last expression in a function is, by default, what is
# returned. So you could equally just say:
powerful <- function(x) {list(x2=x*x, x3=x*x*x, x4=x*x*x*x)}

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/b4.r


#' Remove redundancy frrom linear system
#'
#' Removes redundant rows of configuration matric and corresponding entries in observed data
#' @param A Configuration matrix
#' @param y Vector of observed data. Should be of length nrow(A)
#' @return A list with components A and y, respectively the configuration matrix and data vector with redundant rows removed.
#' @export

remove_redundancy <- function(A,y){
	if (length(y)!=nrow(A)) stop("A and y incompatible")
	tmp <- qr(t(A))
	n <-tmp$rank
	indx <- tmp$pivot[1:n]
	A <- A[indx,]
	y <- y[indx]
	list(A=A,y=y)
}


#clear environment
rm(list = ls())

# set working directory
wd <- 'C:/Users/gbal/Desktop/r.training/2.data'
setwd(wd)

# load and clan data ==========================================================

# load salmon .data
salmon <- read.table('salmon.data.raw.txt', sep = ',', dec = '.', h = TRUE)

# correct weight length data for converson issues
salmon$weight[!is.na(salmon$weight) & salmon$weight > 50] <- salmon$weight[!is.na(salmon$weight) & salmon$weight > 50] / 1000
salmon$length[!is.na(salmon$length) & salmon$length < 44] <- salmon$length[!is.na(salmon$length) & salmon$length < 44] * 2.54

# fit length weight relationship ==================================================

#install.packages(optimx)

require(optimx)

# define model to fit, need to create function
length.weight <- function(param, length, weight){
  a <- exp(param[1])
  b <- exp(param[2])
  sd.l <- exp(param[3])
  weight.pred <- a * length ^ b
  nll <- dlnorm(weight, meanlog = log(weight.pred) - (sd.l ^ 2) / 2, sdlog = sd.l, log = TRUE)
  return(- sum(nll))
}

# fit method selection if wished
optimx.methods.selected <- c('Nelder-Mead',
                             #'BFGS',
                             #'CG',
                             #'L-BFGS-B',
                             #'nlm',
                             'nlminb'#,
                             #'spg',
                             #'ucminf',
                             #'newuoa',
                             #'bobyqa',
                             #'nmkb'#,
                             #'hjkb',
                             #'Rcgmin',
                             #'Rvmmin'
)

# run fit with optimix function
optimx.fit <- optimx(par = c(1, 1, 1),
                     fn = length.weight,
                     length = salmon$length,
                     weight = salmon$weight * 1000,
                     method = optimx.methods.selected,
                     control = list(save.failures = TRUE)
                     #control = list(all.methods = TRUE, save.failures = TRUE)
)

# check fit ====================================================================

plot(salmon$length, salmon$weight * 1000)
# add fitted curve
curve(exp(optimx.fit$p1[1]) * (x ^ exp(optimx.fit$p2[1])),
      col = 'red',
      lwd = 3,
      add = TRUE)

# lm fit fit based on log tranformation
lm(log(salmon$weight * 1000) ~ log(salmon$length))


# 4. faza: Analiza podatkov

theme_set(theme_bw())

#napoved Turcija

podatki <- uvoz_1 %>%
  filter(Drzava == "Turkey", Spol == "Males",
         Izobrazba == "Upper secondary and post-secondary non-tertiary education (levels 3 and 4)")

graf1 <- ggplot(podatki, aes(x=Leto, y= Vrednost)) + geom_point(color="black")
model <- lm(data = podatki, Vrednost ~ Leto)
graf2 = graf1 + geom_smooth(method = "lm", fullrange=TRUE, formula = y~x)
nova <- data.frame(Leto = 2008:2030)
napoved <- mutate(nova, Vrednost=predict(model, nova))

graf_napoved <- graf2 +  geom_point(data=napoved,aes(x=Leto,y= Vrednost), size = 1, color = "blue") +
  scale_x_continuous('Leto', breaks = seq(2008, 2030, 3)) +
  ylab("Stopnja brezposelnosti") +
  labs(title = "Napoved stopnje brezposelnosti v Turčiji za moške s srednjo izobrazbo do \n leta 2030")
graf_napoved

#analiza Slovenija

analiza1 <- ggplot(uvoz_4, aes(x=Leto, y=Stopnja_brezposelnosti)) +
  geom_point(size=1, col="blue") +
  geom_smooth(method="loess", formula= y~x, color="deeppink", size=0.2) +
  facet_wrap(~regija) +
  scale_x_continuous("Leto",  breaks = seq(2008, 2019, 5)) +
  theme(panel.background = element_rect((fill="white")), axis.text= element_text(size=6),
        text= element_text(size=10), strip.background =element_rect(fill="white"),
        strip.text.x = element_text(size = 9)) +
  labs("Analiza stopnje brezposelnosti po regijah") +
  ylab("Stopnja brezposelnosti")
analiza1

analiza2 <- ggplot(uvoz_4, aes(x=Leto, y=Stopnja_brezposelnosti)) +
  geom_point(size=1, col="blue") +
  geom_smooth(method="loess", formula= y~x, color="deeppink", size=0.2) +
  scale_x_continuous("Leto",  breaks = seq(2008, 2019, 3)) +
  theme(panel.background = element_rect((fill="white")), axis.text= element_text(size=6),
        text= element_text(size=10)) +
  labs("Analiza brezposelnosti po regijah") +
  ylab("Stopnja brezposelnosti")
analiza2


#!/usr/bin/Rscript
library(data.table)
library(ggplot2)

args = commandArgs(trailingOnly=TRUE)
if(length(args)==0){
    stop("You have to provide a file name.")
}
filename=args[1]

factor<-1
if(length(args)>1 & args[2]=="invert"){
    factor=-1
}
print(factor)

data <- read.csv(paste(filename,".csv", sep=""))
data$timestamp=round(data$timestamp/1000)
data$value=factor*data$value

lo <- loess(data$value~data$timestamp)
minTime=min(data$timestamp)
maxTime=max(data$timestamp)
smoothedTime=seq(minTime, maxTime, 1)
smoothedValues=predict(lo, smoothedTime)

data$timestamp <- as.POSIXct(data$timestamp, origin="1970-01-01")
smoothedTimestamp=as.POSIXct(smoothedTime, origin="1970-01-01")

png(paste(filename, ".png", sep=""))
qplot(data$timestamp, data$value)+geom_point(aes(x=smoothedTimestamp, y=smoothedValues))
dev.off()

dt1=data.table(data)
setkey(dt1, timestamp)
dt2=data.table(timestamp=smoothedTimestamp, valueSmoothed=smoothedValues)
setkey(dt2, timestamp)

merged<-dt1[dt2,]
analysed<-merged[,list(
    timestamp=timestamp,
    value=ifelse(is.na(value), valueSmoothed, value)
)]

png(paste(filename, "_analysed.png", sep=""))
qplot(analysed$timestamp, analysed$value)
dev.off()

write.csv(analysed, paste(filename, "_analysed.csv", sep=""))


#########################################################################################################
# Empirical Application Codes of
#
# "Threshold Unit Root Tests with Smooth Transitions"
#
# written by
#
# Dr. Mehmet ÖZCAN
# mehmetozcan@kmu.edu.tr
#
# *NOTES*
# 1)  Caner & Hansen (2001) Threshold Unit Root test and Threshold Effect test
#     programs are taken from Hansen's web page http://www.ssc.wisc.edu/~bhansen/ .
#     However, unit root test program are adjusted to test unit root null hypothesis
#     without any deterministic component.
#
# 2)  There are two indicator which come from Caner & Hansen (2001)'s codes. Caner &
#     Hansen investigate different type of threshol variable type and different trimming
#     intervals. In this study, lagged difference threshold variable and [0.15, 0.85]
#     trimming interval are used for all simulation experiments and empirical application.
#
#     thresh    Type of threshold variable
#  		  1 for long difference,   z(t-1)=y(t-1)-y(t-(m-1))
#  		  2 for lagged difference, z(t-1)=y(t-m)-y(t-m-1)
#  		  3 for lagged level,      z(t-1)=y(t-m)
#     trim      Trimming Range (normalized threshold, lambda)
#  		  1 for [.15,.85]
#  	 	  2 for [.10,.90]
#  		  3 for [.05,.95]
#
# 3) Results are printed to the screen.
#
# 4) All steps of application process are explained below. Please check them before run the codes.
#
# *Instructions*
#
# 1) First, please install required R packcages stated in PART-1
# 2) Run all codes in PART-1
# 3) Before run PART-2, please chose working directory folder that contains your "data.txt" file.
# 4) PART-2 codes analyse both the USA's and Turkey's data. Threfore, before analyse your data try
#    data of this study. It could be found at "data.txt" file in same repository of Dr. Özcan's GitHub page.
#
#
#
#########################################################################################################
# PART -1
#########################################################################################################
# Required Packcages
library(nloptr)
library(zoo)
# Required Functions
#########################################################################################################
# Starting value estimation for LNV(1998) Models (A, B & C) #
startLNV<-function(dta){
tt<-length(dta)
tr<-as.matrix(c(1:tt))
cc<-as.matrix(rep(1,tt))

tauGs<-c()
for(kk in 1:tt){ tauGs[kk]<-(kk/tt) }
gamaGs<-seq(1,10,1)

SSRA<-matrix(0,length(tauGs),length(gamaGs))
SSRB<-matrix(0,length(tauGs),length(gamaGs))
SSRC<-matrix(0,length(tauGs),length(gamaGs))

for(vk in 1:3){
for(vi in 1:(length(gamaGs))){
for(vj in 1:(length(tauGs))){
st<-as.matrix((1/(1+exp(-(gamaGs[vi])*((tr)-(tauGs[vj]*tt))))))
if(vk==1){X<-as.matrix(cbind(cc,st))}
if(vk==2){X<-as.matrix(cbind(cc,tr,st))}
if(vk==3){X<-as.matrix(cbind(cc,tr,st,(tr*st)))}
XX<-(MASS:::ginv(t(X)%*%X, tol=1e-25))
betas<-XX%*%(t(X)%*%dta)
Yhat<-t((t(betas)%*%t(X)))
ehat<-(dta-Yhat)
if(vk==1){SSRA[vj,vi]<-sum((ehat)^2)}
if(vk==2){SSRB[vj,vi]<-sum((ehat)^2)}
if(vk==3){SSRC[vj,vi]<-sum((ehat)^2)}
}
}
}

for(vs in 1:3){
if(vs==1){posA<-which(SSRA == min(SSRA), arr.ind = TRUE);
st<-as.matrix((1/(1+exp(-(gamaGs[posA[2]])*((tr)-(tauGs[posA[1]]*tt))))));
X<-as.matrix(cbind(cc,st))}
if(vs==2){posB<-which(SSRB == min(SSRB), arr.ind = TRUE);
st<-as.matrix((1/(1+exp(-(gamaGs[posB[2]])*((tr)-(tauGs[posB[1]]*tt))))));
X<-as.matrix(cbind(cc,tr,st))}
if(vs==3){posC<-which(SSRC == min(SSRC), arr.ind = TRUE);
st<-as.matrix((1/(1+exp(-(gamaGs[posC[2]])*((tr)-(tauGs[posC[1]]*tt))))));
X<-as.matrix(cbind(cc,tr,st,(tr*st)))}

XX<-(MASS:::ginv(t(X)%*%X, tol=1e-25))

if(vs==1){betasA<-XX%*%(t(X)%*%dta);
betasA<-rbind(betasA,gamaGs[posA[2]],tauGs[posA[1]])}
if(vs==2){betasB<-XX%*%(t(X)%*%dta);
betasB<-rbind(betasB,gamaGs[posB[2]],tauGs[posB[1]])}
if(vs==3){betasC<-XX%*%(t(X)%*%dta);
betasC<-rbind(betasC,gamaGs[posC[2]],tauGs[posC[1]])}
}
list(betasA=betasA, betasB=betasB, betasC=betasC)
}
#########################################################################################################
# LNV(1998) Models (A, B & C) Estimation with Sequential Quadratic Programing
estLNV<-function(yt, X, b0a, b0b, b0c){
tt<-length(yt)
stabA<-function(b){sum((yt-(b[1]*X[,1]+b[2]*(1/(1+exp(-(b[3])*((X[,2])-b[4]*tt))))))^2)}
stabB<-function(b){sum((yt-(b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[4])*((X[,2])-b[5]*tt))))))^2)}
stabC<-function(b){sum((yt-(b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt))))+
b[4]*(X[,2])*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt))))))^2)}

lba<-c(-Inf,-Inf,0,0)
uba<-c(Inf,Inf,Inf,1)

lbb<-c(-Inf,-Inf,-Inf,0,0)
ubb<-c(Inf,Inf,Inf,Inf,1)

lbc<-c(-Inf,-Inf,-Inf,-Inf,0,0)
ubc<-c(Inf,Inf,Inf,Inf,Inf,1)

SA<-nloptr:::slsqp(b0a,fn=stabA,lower=lba,upper=uba, control=list(xtol_rel=1e-25))
SB<-nloptr:::slsqp(b0b,fn=stabB,lower=lbb,upper=ubb, control=list(xtol_rel=1e-25))
SC<-nloptr:::slsqp(b0c,fn=stabC,lower=lbc,upper=ubc, control=list(xtol_rel=1e-25))

staba<-function(b){(b[1]*X[,1]+b[2]*(1/(1+exp(-(b[3])*((X[,2])-b[4]*tt)))))}
yhatA<-staba(SA$par)

stabb<-function(b){b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[4])*((X[,2])-b[5]*tt))))}
yhatB<-stabb(SB$par)

stabc<-function(b){(b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt))))+
b[4]*(X[,2])*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt)))))}
yhatC<-stabc(SC$par)

list(ehat=as.matrix(cbind((yt-yhatA),(yt-yhatB),(yt-yhatC))), yhat=as.matrix(cbind(yhatA,yhatB,yhatC)),BetaA=as.matrix(SA$par),BetaB=as.matrix(SB$par),BetaC=as.matrix(SC$par))
}
#########################################################################################################
# ADF Estimator
linear<-function(dat,p,cons,trend){
    t <- nrow(dat)
    n <- t - 1 - p
    dy <- as.matrix(dat[2:t]-dat[1:(t-1)])
    y  <- as.matrix(dy[(1+p):(t-1)])
    x  <- cbind(dat[(1+p):(t-1)], dy[p:(t-2)])

    if(p>=2){for (k in 2:p) x <- cbind(x,dy[(p+1-k):(t-1-k)])}
    if(cons==1 & trend==0)  x <- cbind(rep(1,n), x)
    if(cons==1 & trend==1)  x <- cbind(rep(1,n),seq(1,n,1),x)

    kx     <- ncol(x)
    xx     <- solve(t(x)%*%x, tol=1e-25)
    bols   <- xx%*%(t(x)%*%y)
    eols   <- y - x%*%bols
    sols   <- t(eols)%*%eols
    sigols <- sols/(n-kx)
    seols  <- sqrt(diag(xx)%*%sigols)
    rho    <- bols[1+cons+trend]
    tadf   <- rho/seols[1+cons+trend]
    ar0    <- as.matrix(bols[(cons+trend+2):(cons+trend+1+p)])
    bic<-log((sum(eols^2))/t)+(length(bols)*(log(t)/t))
    aic<-log((sum(eols^2))/t)+(length(bols)*(2/t))
    list(ar0=ar0,eols=eols,aic=aic,bic=bic,tadf=tadf,rho=rho)
}
#########################################################################################################
# Caner & Hansen (2001) Estimator
tur_est2 <- function(dat,p,mmin,mmax,m,constant,trend){
  t <- nrow(dat)
  n <- t - 1 - p
  mn <- mmax-mmin+1
  ms <- as.matrix(seq(mmin,mn,1))
  dy <- as.matrix(dat[2:t]-dat[1:(t-1)])
  y <- as.matrix(dy[(1+p):(t-1)])
  if(constant==1) x <- matrix(1,n,1)
  if (trend==1) x <- cbind(x,as.matrix(seq(1,n,1)))
  if(constant==1){x <- cbind(x,dat[(1+p):(t-1)],dy[p:(t-2)])}else{
  x <- cbind(dat[(1+p):(t-1)],dy[p:(t-2)])}
  if(p>1) for (ki in 2:p) x <- cbind(x,dy[(p+1-ki):(t-1-ki)])

  if (sum(coef)==0){
      xi_ns <- as.matrix(seq(1,p,1)+1+constant+trend)
        }else{
      idex <- colSums(as.matrix(coef%*%matrix(1,1,p))==(matrix(1,nrow(coef),1)%*%seq(1,p,1)))
      xi_ns <- seq(1,p,1)
      xi_ns <- as.matrix(xi_ns[idex==0]+1+constant+trend)
    }

  if (trend==0){
        if(constant==0){
	        if (sum(coef)==0){
            xi_s <- rbind(1)
                }else{xi_s <- rbind(1,(coef+1))
            }
        }
    }
  if (trend==0){
        if(constant==1){
	        if (sum(coef)==0){
            xi_s <- rbind(1,2)
                }else{
                xi_s <- rbind(1,2,(coef+2))
            }
        }
    }
  if (trend==1){
        if(constant==1){
	        if (sum(coef)==0){
            xi_s <- rbind(1,2,3)
                }else{
                xi_s <- rbind(1,2,3,(coef+3))
            }
         }
    }
  xs <- as.matrix(x[,xi_s])
  xns <- as.matrix(x[,xi_ns])
  if (thresh==1){
      qs <- dat[(1+p):(t-1)]-dat[(1+p-mmin):(t-1-mmin)]
      qs <- as.matrix(qs)
      if(p>1){
	  for (mi in (mmin+1):mmax){
          qs <- cbind(qs,(dat[(1+p):(t-1)]-dat[(1+p-mi):(t-1-mi)]))
      }
	  }
  }
  if (thresh==2){
      qs <- dat[(1+p-mmin+1):(t-1-mmin+1)]-dat[(1+p-mmin):(t-1-mmin)]
      qs <- as.matrix(qs)
      if(p>1){
	  for (mi in (mmin+1):mmax){
          qs <- cbind(qs,(dat[(1+p-mi+1):(t-1-mi+1)]-dat[(1+p-mi):(t-1-mi)]))
      }
	  }
  }
  if (thresh==3){
      qs <- dat[(1+p-mmin+1):(t-mmin)]
      qs <- as.matrix(qs)
      if(p>1){
	  for (mi in (mmin+1):mmax){
          qs <- cbind(qs,(dat[(1+p-mi+1):(t-mi)]))
      }
	  }
  }
  kx    <- ncol(x)
  ks    <- nrow(coef)+1+constant+trend
  xx    <- solve(t(x)%*%x, tol=1e-25)
  bols  <- xx%*%(t(x)%*%y)
  eols  <- y - x%*%bols
  sols  <- t(eols)%*%eols
  wwss  <- matrix(0,mn,1)
  smins <- matrix(0,mn,1)
  lams  <- matrix(0,mn,1)
  ws    <- matrix(0,mn,1)
  r1    <- matrix(0,mn,1)
  r2    <- matrix(0,mn,1)
  t1    <- matrix(0,mn,1)
  t2    <- matrix(0,mn,1)
  rur <- rbind(1,(ks+1))+trend+constant
  indx <- 1:(n)
  pi1 <-.2-.05*trim
  pi2 <-.8+.05*trim
  for (mi in 1:mn){
    q <- qs[,mi]
    qq <- unique(q)
    qq <- as.matrix(sort(qq))
    qq <- as.matrix(qq[(floor(n*pi1)+1):(ceiling(n*pi2)-1)])
    qn <- nrow(qq)
    s  <- matrix(0,qn,1)
    wws<- matrix(0,qn,1)
    for (qi in 1:qn){
      d1      <- as.matrix((q<qq[qi]))
      d2      <- 1-d1
      xz      <- cbind((xs*(d1%*%matrix(1,1,ncol(xs)))),(xs*(d2%*%matrix(1,1,ncol(xs)))),xns)
      xxi     <- solve(t(xz)%*%xz, tol=1e-25)
      bthresh <- xxi%*%(t(xz)%*%y)
      e       <- y-xz%*%bthresh
      s[qi]   <- t(e)%*%e
      v       <- xxi*as.vector((t(e)%*%e)/(n-kx-ks))
      vd      <- diag(v)
      ts      <- as.matrix(bthresh[rur]/sqrt(vd[rur]))
      wws[qi] <- t(ts)%*%ts
    }
    qi         <- which.max(wws)
    lam        <- qq[qi]
    smin       <- s[qi]
    wwsmax     <- wws[qi]
    ws[mi]     <- (n-kx-ks)*(sols-smin)/smin
    smins[mi]  <- smin
    lams[mi]   <- lam
    wwss[mi]   <- wwsmax
    d1         <- as.matrix((q<lam))
    d2         <- 1-d1
    xz         <- cbind((xs*(d1%*%matrix(1,1,ncol(xs)))),(xs*(d2%*%matrix(1,1,ncol(xs)))),xns)
    mmi        <- solve(t(xz)%*%xz, tol=1e-25)
    bthresh    <- mmi%*%(t(xz)%*%y)
    e          <- y - xz%*%bthresh
    v          <- mmi*as.vector((t(e)%*%e)/(n-kx-ks))
    vd         <- diag(v)
    ts         <- as.matrix(bthresh[rur]/sqrt(vd[rur]))
    r1[mi]     <- t(ts^2)%*%(ts<0)
    r2[mi]     <- t(ts)%*%ts
    t1[mi]     <- -ts[1]
    t2[mi]     <- -ts[2]
  }
  if (m != 0) {mi <- m-mmin+1}else{mi<- which.max(wwss)}
  mhat     <- ms[mi]
  w        <- ws[mi]
  lam      <- lams[mi]
  q        <- qs[,mi]
  d1       <- as.matrix((q<lam))
  d2       <- 1-d1
  xz       <- cbind((xs*(d1%*%matrix(1,1,ncol(xs)))),(xs*(d2%*%matrix(1,1,ncol(xs)))),xns)
  mmi      <- solve(t(xz)%*%xz, tol=1e-25)
  bthresh  <- mmi%*%(t(xz)%*%y)
  e        <- y - xz%*%bthresh
  ee       <- t(e)%*%e
  v        <- mmi*as.vector((ee)/(n-kx-ks))
  vd       <- diag(v)
  v1       <- vd[1:ks]
  v2       <- vd[(ks+1):(2*ks)]
  b1       <- bthresh[1:ks]
  b2       <- bthresh[(ks+1):(2*ks)]
  ts       <- as.matrix(((b1-b2)^2)/(v1+v2))
  bs_s     <- cbind(b1,sqrt(v1),matrix(0,ks,1),b2,sqrt(v2))
  bs_ns    <- cbind(bthresh[(1+2*ks):(kx+ks)],sqrt(vd[(1+2*ks):(kx+ks)]))
  ar01     <-bthresh[(2+constant+trend):(ks)]
  ar02     <-bthresh[(2+constant+trend+ks):(ks*2)]
  leng     <-sum(x[,ncol(x)]>lam)
list(mhat=mhat,lam=lam,e=e,bs_s=bs_s,ar01=ar01,ar02=ar02,b1=b1,b2=b2,r1=r1,r2=r2,t1=t1,t2=t2,ts=ts,ws=ws,w=w,
wws=wws, wwss=wwss,leng=leng,vd=vd)
}
# Caner & Hansen (2001) Threshold Effect Wald Test Bootstrap p-values
pvWald<-function(dat,p,ar0,eols,rho,boot,w){
t <- nrow(dat)
n <- t - 1 - p
y0 <- dat-mean(dat)
y0 <- as.matrix(y0[1:(1+p)])
aa <- matrix(0,p+1,1)
aa[1] <- 1 + rho
aa[1:p] <- aa[1:p] + ar0
aa[2:(p+1)] <- aa[2:(p+1)] - ar0
bootw <- matrix(0,boot,1)
for (ib in 1:boot){
    eols_c <- as.matrix(eols[ceiling(runif(t)*n)])
    datb <- y0
for (i in (nrow(y0)+1):(nrow(eols_c))){
        datbb <- eols_c[i]
        for (j in 1:nrow(y0)) datbb <- datbb + aa[j]*datb[(i-j)]
        datb <- rbind(datb,datbb)
    }
out       <- tur_est2(datb,p,1,p,0,0,0)
bootw[ib] <- out$w
}
pw <- mean(bootw > w)
cbind(w,pw)
}

#########################################################################################################
# 5% Criticals T=200
R1A <- 20.82907
R2A <- 21.07073
R1B <- 26.67934
R2B <- 26.80033
R1C <- 29.65022
R2C <- 29.69269
LNVa<- -4.161
LNVb<- -4.629
LNVc<- -4.867
ADFm<- -2.8759
ADFt<- -3.4326 # MacKinnon (1991) based Critical value

#########################################################################################################
# PART - 2
#########################################################################################################
# Aplication
# select working directory file.
# setwd("your folder directory")
# read data
D   <- read.table("data.txt")
tri <- D[,1]
usi <- D[,2]
# logarithms
tri <-as.matrix(log(tri))
usi <-as.matrix(log(usi))
# estimation parameter of LNV smooth transition functions
tr    <-as.matrix(c(1:length(tri)))
cc    <-as.matrix(rep(1,length(tri)))
X     <-as.matrix(cbind(cc,tr))
SLNVtr<- startLNV(tri)
SLNVus<- startLNV(usi)
b0atr <- SLNVtr$betasA; b0btr  <- SLNVtr$betasB; b0ctr  <- SLNVtr$betasC
b0aus <- SLNVus$betasA; b0bus  <- SLNVus$betasB; b0cus  <- SLNVus$betasC

ELNVtr<- estLNV(tri, X, b0atr, b0btr, b0ctr)
ELNVus<- estLNV(usi, X, b0aus, b0bus, b0cus)
Ytr   <- as.matrix(ELNVtr$yhat)
Yus   <- as.matrix(ELNVus$yhat)
Dtr   <- as.matrix(ELNVtr$ehat)
Dus   <- as.matrix(ELNVus$ehat)
# plots
# TR
par(mfrow=c(3,1))
plot(ts(Ytr[,1], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model A",ylim=c(min(tri),max(tri)))
mtext(side=3,text=paste("industrial production and fitted smooth transition for Turkey"),line=2.5,lwd=2,cex=1)
lines(ts(tri, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(tri),1),round(max(tri),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(tri),1),round(max(tri),1),0.1), col="lightgray", lty="dotted")
plot(ts(Ytr[,2], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model B",ylim=c(min(tri),max(tri)))
lines(ts(tri, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(tri),1),round(max(tri),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(tri),1),round(max(tri),1),0.1), col="lightgray", lty="dotted")
plot(ts(Ytr[,3], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model C",ylim=c(min(tri),max(tri)))
lines(ts(tri, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(tri),1),round(max(tri),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(tri),1),round(max(tri),1),0.1), col="lightgray", lty="dotted")

# US
par(mfrow=c(3,1))
plot(ts(Yus[,1], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model A",ylim=c(min(usi),max(usi)))
mtext(side=3,text=paste("industrial production and fitted smooth transition for USA"),line=2.5,lwd=2,cex=1)
lines(ts(usi, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(usi),1),round(max(usi),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(usi),1),round(max(usi),1),0.1), col="lightgray", lty="dotted")
plot(ts(Yus[,2], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model B",ylim=c(min(usi),max(usi)))
lines(ts(usi, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(usi),1),round(max(usi),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(usi),1),round(max(usi),1),0.1), col="lightgray", lty="dotted")
plot(ts(Yus[,3], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model C",ylim=c(min(usi),max(usi)))
lines(ts(usi, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(usi),1),round(max(usi),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(usi),1),round(max(usi),1),0.1), col="lightgray", lty="dotted")

# Extraction of Estimated Data
# write.table(as.matrix(cbind(tri,Ytr[,1],Ytr[,2],Ytr[,3])),"TRest.txt",row.names=FALSE,col.names=FALSE)
# write.table(as.matrix(cbind(usi,Yus[,1],Yus[,2],Yus[,3])),"USest.txt",row.names=FALSE,col.names=FALSE)

# ADF Test
maxp<- 10
BIC <- matrix(0,maxp,2)
for(i in 1:maxp){
adftr <- linear(as.matrix(tri),i,1,1)
adfus <- linear(as.matrix(usi),i,1,1)
BIC[i,1]<-adftr$bic
BIC[i,2]<-adfus$bic
}
ptr <- which.min(BIC[,1])
pus <- which.min(BIC[,2])

adftr0 <- linear(as.matrix(tri),ptr,1,1)
adfus0 <- linear(as.matrix(usi),pus,1,1)

# LNV Test
BICL <- matrix(0,maxp,6)
for(i in 1:maxp){
adftra <- linear(as.matrix(Dtr[,1]),i,1,1)
adftrb <- linear(as.matrix(Dtr[,2]),i,1,1)
adftrc <- linear(as.matrix(Dtr[,3]),i,1,1)

adfusa <- linear(as.matrix(Dus[,1]),i,1,1)
adfusb <- linear(as.matrix(Dus[,2]),i,1,1)
adfusc <- linear(as.matrix(Dus[,3]),i,1,1)

BICL[i,1]<-adftra$bic; BICL[i,2]<-adftrb$bic; BICL[i,3]<-adftrc$bic;
BICL[i,4]<-adfusa$bic; BICL[i,5]<-adfusb$bic; BICL[i,6]<-adfusc$bic
}
ptra <- which.min(BICL[,1]); ptrb <- which.min(BICL[,2]); ptrc <- which.min(BICL[,3]);
pusa <- which.min(BICL[,4]); pusb <- which.min(BICL[,5]); pusc <- which.min(BICL[,6]);
PLNV <-cbind(ptra,ptrb,ptrc,pusa,pusb,pusc)

adftrA <- linear(as.matrix(Dtr[,1]),ptra,1,1)
adftrB <- linear(as.matrix(Dtr[,2]),ptrb,1,1)
adftrC <- linear(as.matrix(Dtr[,3]),ptrc,1,1)

adfusA <- linear(as.matrix(Dus[,1]),pusa,1,1)
adfusB <- linear(as.matrix(Dus[,2]),pusb,1,1)
adfusC <- linear(as.matrix(Dus[,3]),pusc,1,1)

# Caner & Hansen (2001) Test with Smooth Transition
# Caner & Hansen (2001) TAR Model Estimation Settings
thresh   <- 2
trim     <- 1
#
MAXR <- matrix(0,maxp,6)
for(i in 1:maxp){
coef   <- matrix(c(1:i),i,1)
tarAtr <-tur_est2(as.matrix(Dtr[,1]),i,1,i,0,0,0)
tarBtr <-tur_est2(as.matrix(Dtr[,2]),i,1,i,0,0,0)
tarCtr <-tur_est2(as.matrix(Dtr[,3]),i,1,i,0,0,0)

tarAus <-tur_est2(as.matrix(Dus[,1]),i,1,i,0,0,0)
tarBus <-tur_est2(as.matrix(Dus[,2]),i,1,i,0,0,0)
tarCus <-tur_est2(as.matrix(Dus[,3]),i,1,i,0,0,0)

MAXR[i,1]<-tarAtr$r1[tarAtr$mhat]; MAXR[i,2]<-tarBtr$r1[tarBtr$mhat]; MAXR[i,3]<-tarCtr$r1[tarCtr$mhat];
MAXR[i,4]<-tarAus$r1[tarAus$mhat]; MAXR[i,5]<-tarBus$r1[tarBus$mhat]; MAXR[i,6]<-tarCus$r1[tarCus$mhat]
}
ptrA <- which.max(MAXR[,1]); ptrB <- which.max(MAXR[,2]); ptrC <- which.max(MAXR[,3]);
pusA <- which.max(MAXR[,4]); pusB <- which.max(MAXR[,5]); pusC <- which.max(MAXR[,6]);
PLCH <- cbind(ptrA,ptrB,ptrC,pusA,pusB,pusC)

coef   <- matrix(c(1:ptrA),ptrA,1)
tartrA <- tur_est2(as.matrix(Dtr[,1]),ptrA,1,ptrA,0,0,0)
coef   <- matrix(c(1:ptrB),ptrB,1)
tartrB <- tur_est2(as.matrix(Dtr[,2]),ptrB,1,ptrB,0,0,0)
coef   <- matrix(c(1:ptrC),ptrC,1)
tartrC <- tur_est2(as.matrix(Dtr[,3]),ptrC,1,ptrC,0,0,0)

coef   <- matrix(c(1:pusA),pusA,1)
tarusA <- tur_est2(as.matrix(Dus[,1]),pusA,1,pusA,0,0,0)
coef   <- matrix(c(1:pusB),pusB,1)
tarusB <- tur_est2(as.matrix(Dus[,2]),pusB,1,pusB,0,0,0)
coef   <- matrix(c(1:pusC),pusC,1)
tarusC <- tur_est2(as.matrix(Dus[,3]),pusC,1,pusC,0,0,0)

# Caner & Hansen (2001) Threshold Effect test statistics and p-values #
set.seed(12345)
boot<-1000
# Turkey
coef    <- matrix(c(1:ptrA),ptrA,1)
lnWAtr  <- linear(as.matrix(Dtr[,1]),ptrA,0,0)
pvalAtr <- pvWald(as.matrix(Dtr[,1]),ptrA,lnWAtr$ar0,lnWAtr$eols,lnWAtr$rho,boot,tartrA$w)
coef    <- matrix(c(1:ptrB),ptrB,1)
lnWBtr  <- linear(as.matrix(Dtr[,2]),ptrB,0,0)
pvalBtr <- pvWald(as.matrix(Dtr[,2]),ptrB,lnWBtr$ar0,lnWBtr$eols,lnWBtr$rho,boot,tartrB$w)
coef    <- matrix(c(1:ptrC),ptrC,1)
lnWCtr  <- linear(as.matrix(Dtr[,3]),ptrC,0,0)
pvalCtr <- pvWald(as.matrix(Dtr[,3]),ptrC,lnWCtr$ar0,lnWCtr$eols,lnWCtr$rho,boot,tartrC$w)
# USA
coef    <- matrix(c(1:pusA),pusA,1)
lnWAus  <- linear(as.matrix(Dus[,1]),pusA,0,0)
pvalAus <- pvWald(as.matrix(Dus[,1]),pusA,lnWAus$ar0,lnWAus$eols,lnWAus$rho,boot,tarusA$w)
coef    <- matrix(c(1:pusB),pusB,1)
lnWBus  <- linear(as.matrix(Dus[,2]),pusB,0,0)
pvalBus <- pvWald(as.matrix(Dus[,2]),pusB,lnWBus$ar0,lnWBus$eols,lnWBus$rho,boot,tarusB$w)
coef    <- matrix(c(1:pusC),pusC,1)
lnWCus  <- linear(as.matrix(Dus[,3]),pusC,0,0)
pvalCus <- pvWald(as.matrix(Dus[,3]),pusC,lnWCus$ar0,lnWCus$eols,lnWCus$rho,boot,tarusC$w)

# Tables
trit<-ts(diff(tri,1),start<-c(2004,2),frequency=12)
usit<-ts(diff(usi,1),start<-c(2004,2),frequency=12)
ntr <-length(tri)
nus <-length(usi)
printlog<-function(tri,usi){
cat ("\n")
cat ("Parameter Estimation Result of Smooth Transition for Industrial Production Index of Turkey" , "\n")
cat ("Number of Observations:", ntr                                                               , "\n")
cat ("Optimization          : Sequential Quadratic Programming"                                   , "\n")
cat ("\n")
cat ("Model A"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(trit))[round((ELNVtr$BetaA[4]*ntr))])
cat ("Mid Point Tau               :", ELNVtr$BetaA[4]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVtr$BetaA[3]                                             , "\n")
cat ("\n")
cat ("Model B"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(trit))[round((ELNVtr$BetaB[5]*ntr))])
cat ("Mid Point Tau               :", ELNVtr$BetaB[5]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVtr$BetaB[4]                                             , "\n")
cat ("\n")
cat ("Model C"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(trit))[round((ELNVtr$BetaC[6]*ntr))])
cat ("Mid Point Tau               :", ELNVtr$BetaC[6]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVtr$BetaC[5]                                             , "\n")
cat ("\n")
cat ("*******************************************************************************************", "\n")
cat ("\n")
cat ("Parameter Estimation Result of Smooth Transition for Industrial Production Index of USA"    , "\n")
cat ("Number of Observations:", nus                                                               , "\n")
cat ("Optimization          : Sequential Quadratic Programming"                                   , "\n")
cat ("\n")
cat ("Model A"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(usit))[round((ELNVus$BetaA[4]*nus))])
cat ("Mid Point Tau               :", ELNVus$BetaA[4]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVus$BetaA[3]                                             , "\n")
cat ("\n")
cat ("Model B"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(usit))[round((ELNVus$BetaB[5]*nus))])
cat ("Mid Point Tau               :", ELNVus$BetaB[5]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVus$BetaB[4]                                             , "\n")
cat ("\n")
cat ("Model C"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(usit))[round((ELNVus$BetaC[6]*nus))])
cat ("Mid Point Tau               :", ELNVus$BetaC[6]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVus$BetaC[5]                                             , "\n")
cat ("\n")
cat ("*******************************************************************************************", "\n")
cat ("\n")
}

printadf<-function(tri,usi,ptr,pus){
cat ("\n")
cat ("ADF Results for Industrial Production Index of Turkey" , "\n")
cat ("Number of Observations:", length(tri)                  , "\n")
cat ("Selected Optimal Lag  :", ptr, "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Model Type            : Constant & Trend"              , "\n")
cat ("Test Statistics       :", adftr0$tadf                  , "\n")
cat ("5% Critical Value     :",ADFt                          , "\n")
cat ("\n")
cat ("ADF Results for Industrial Production Index of USA"    , "\n")
cat ("Number of Observations:", length(usi)                  , "\n")
cat ("Selected Optimal Lag  :", pus, "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Model Type            : Constant & Trend"              , "\n")
cat ("Test Statistics       :", adfus0$tadf                  , "\n")
cat ("5% Critical Value     :",ADFt                          , "\n")
}

printlnv<-function(tri,usi,PLNV){
cat ("\n")
cat ("LNV Results for Industrial Production Index of Turkey" , "\n")
cat ("Number of Observations:", length(tri)                  , "\n")
cat ("\n")
cat ("Model A"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[1]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adftrA$tadf                  , "\n")
cat ("5% Critical Value     :", LNVa                         , "\n")
cat ("\n")
cat ("Model B"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[2]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adftrB$tadf                  , "\n")
cat ("5% Critical Value     :", LNVb                         , "\n")
cat ("\n")
cat ("Model C"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[3]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adftrC$tadf                  , "\n")
cat ("5% Critical Value     :", LNVc                         , "\n")
cat ("\n")
cat ("******************************************************", "\n")
cat ("\n")
cat ("LNV Results for Industrial Production Index of USA" , "\n")
cat ("Number of Observations:", length(usi)                  , "\n")
cat ("\n")
cat ("Model A"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[4]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adfusA$tadf                  , "\n")
cat ("5% Critical Value     :", LNVa                         , "\n")
cat ("\n")
cat ("Model B"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[5]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adfusB$tadf                  , "\n")
cat ("5% Critical Value     :", LNVb                         , "\n")
cat ("\n")
cat ("Model C"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[6]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adfusC$tadf                  , "\n")
cat ("5% Critical Value     :", LNVc                         , "\n")
cat ("\n")
}

printlch<-function(tri,usi,PLCH){
cat ("\n")
cat ("New Combined Caner & Hansen (2001) Results for Industrial Production Index of Turkey"            , "\n")
cat ("Number of Observations:", length(tri)                                                            , "\n")
cat ("\n")
cat ("Model A"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[1]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tartrA$r1[tartrA$mhat],"  / R2 Test Statistics   :",tartrA$r2[tartrA$mhat] , "\n")
cat ("R1 5% Critical Value :",R1A                   ,"/ R2 5% Critical Value :",R2A                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalAtr[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalAtr[2]                                                               , "\n")
cat ("\n")
cat ("Model B"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[2]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tartrB$r1[tartrB$mhat],"/ R2 Test Statistics   :",tartrB$r2[tartrB$mhat] , "\n")
cat ("R1 5% Critical Value :",R1B                   ,"/ R2 5% Critical Value :",R2B                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalBtr[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalBtr[2]                                                               , "\n")
cat ("\n")
cat ("Model C"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[3]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tartrC$r1[tartrC$mhat],"/ R2 Test Statistics   :",tartrC$r2[tartrC$mhat] , "\n")
cat ("R1 5% Critical Value :",R1C                   ,"/ R2 5% Critical Value :",R2C                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalCtr[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalCtr[2]                                                               , "\n")
cat ("\n")
cat ("************************************************************************************************", "\n")
cat ("\n")
cat ("New Combined Caner & Hansen (2001) Results for Industrial Production Index of USA"               , "\n")
cat ("Number of Observations:", length(usi)                                                            , "\n")
cat ("\n")
cat ("Model A"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[4]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tarusA$r1[tarusA$mhat],"/ R2 Test Statistics   :",tarusA$r2[tarusA$mhat] , "\n")
cat ("R1 5% Critical Value :",R1A                   ,"/ R2 5% Critical Value :",R2A                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalAus[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalAus[2]                                                               , "\n")
cat ("\n")
cat ("Model B"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[5]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tarusB$r1[tarusB$mhat],"/ R2 Test Statistics   :",tarusB$r2[tarusB$mhat] , "\n")
cat ("R1 5% Critical Value :",R1B                   ,"/ R2 5% Critical Value :",R2B                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalBus[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalBus[2]                                                               , "\n")
cat ("\n")
cat ("Model C"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[6]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tarusC$r1[tarusC$mhat],"/ R2 Test Statistics   :",tarusC$r2[tarusC$mhat] , "\n")
cat ("R1 5% Critical Value :",R1C                   ,"/ R2 5% Critical Value :",R2C                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalCus[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalCus[2]                                                               , "\n")
cat ("\n")
}

printlog(tri,usi)
printadf(tri,usi,ptr,pus)
printlnv(tri,usi,PLNV)
printlch(tri,usi,PLCH)

# END


#fitting semivariograms to data.
#clear environment, load pacakges
rm(list=ls())
library (sp)
library(gstat)
library(boot)
library(data.table)

#Load Talbot 2014 PNAS data.
d <- data.table(readRDS('/fs/data3/caverill/NEFI_microbial/prior_data/tal_core_data.rds'))
d$relEM <- (d$relEM * (length(d$relEM) - 1) + 0.5) / length(d$relEM)
d$relEM <- logit(d$relEM)
d <- d[,.(relEM,pH, moisture, cn, mat30, map30, doy, horizon, epoch_date, site, latitude, longitude)]
d <- d[complete.cases(d),]

#set coordinates
coordinates(d) <- ~longitude + latitude
bubble(d, zcol = 'relEM', fill=T, do.sqrt = F, maxsize=3)

#fit variogram
vario.1 <- variogram(relEM~1, data = d) #get semivariance values
vario.model.1 <- fit.variogram(vario.1, vgm(model='Sph', nugget=T)) #fit a variogram model with a Spherical error structure and a "nugget" (nugget = intercept)
#plot your semivariance and your model.
plot(vario.1, model=vario.model.1)

#We can repeat this with the residuals of a fitted model.
m <-  lm(relEM ~ pH + cn + moisture + mat30 + map30 + horizon + doy, data = d)
summary(m)
d$resid <- residuals(m)

#fit variogram to residuals
vario.2 <- variogram(resid~1, data = d) #get semivariance values
vario.model.2 <- fit.variogram(vario.2, vgm(model='Sph', nugget=T)) #fit a variogram model with a Spherical error structure and a "nugget" (nugget = intercept)
#plot your semivariance and your model.
<<<<<<< HEAD
plot(vario.2, model=vario.model.1)
=======
plot(vario.2, model=vario.model.1)
>>>>>>> 86f6aad5e093b910fe7cc8ff293b9089204f114c


#' Title
#'
#' @param observed   observed values of dependent variable.
#' @param predicted  predicted values of dependent variable.
#' @param norm       Normalize RMSE score to the mean abundance of the observed values? Default is FALSE.
#'
#' @return           returns RMSE score.
#' @export
#'
#' @examples
rmse <- function(observed, predicted, norm = F){
  #compatability tests.
  if(sum(is.na(observed )) > 0){stop('Error: NAs in observed vector.' )}
  if(sum(is.na(predicted)) > 0){stop('Error: NAs in predicted vector.')}
  if(length(observed) != length(predicted)){stop('Error: predicted and observed vectors must be the same length.')}

  #get sample size.
  N <- length(observed)

  #calculate residual sums of squares relative to actual prediction (i.e. "1:1 line")
  SS.res <- sum((observed - predicted)^2)

  #divide by sample size, take square root.
  obs.rmse <- sqrt(SS.res / N)

  #Normalize RMSE score, if desired.
  if(norm == T){
    obs.rmse <- obs.rmse / mean(observed)
  }

  #return RMSE.
  return(obs.rmse)
}


data1 <- read.csv("../submission/02_xgb_nummodel10_mvalid0.8424.csv")
data2 <- read.csv("../submission/01_nn_nummodel10_mvalid0.8416.csv")
data3 <- read.csv("../submission/03_xgb_with_knn_nummodel10_mvalid0.8497.csv")

submission <- data1

submission[,2] <- 0.5 * data1[,2] + 0.25 * data2[,2] + 0.25 * data3[,2]

show_df <- data.frame(xgb = data1[,2], nn = data2[,2], knn = data3[,2], sub = submission[,2])
print(head(show_df))

write.table(submission, "../submission/04_all_averaging.csv", row.names = FALSE, sep = ",", quote = FALSE)


bayesianRegression = function(y, X,  prior_var_vec, iters = 100){
	#' Generate MCMC Samples of Bayesian Linear Regression
	#'
	#' \code{bayesianRegression} generates MCMC samples from Bayesian Linear Regression.
	#' Assumes prior mean centered at 0.
    #' Written by Daniel Kirsner
	#' @param y <nX1> observed data vector
	#' @param X <nXp> design matrix (takes objects of class matrix or sparce Matrix)
	#' @param prior_var_vec <px1> prior variance vector
	#' @param iters Integer; number of desired output iterations
    n = length(y)
	p = dim(X)[2]
	stopifnot(length(prior_var_vec) == p)

	#Data augmentation
	X_aug = as.matrix(rbind(X, diag(p)))
	y_aug = c(y, rep(0, p))
	y_aug = as.numeric(y_aug)

	bayesian_model=lm(y_aug~0+X_aug) #, weights = 1/prior_var_vec)
	mcmc_mat=MASS::mvrnorm(iters,coef(bayesian_model), vcov(bayesian_model))
    return(mcmc_mat)
}