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

# libraries
library(readr)
library(dplyr)
library(tidyr)
library(TSA)
library(tseries)
library(forecast)
library(fUnitRoots)
library(lmtest)
library(fGarch)
library(CombMSC)
library(stats)
library(FitAR)

# data preparation
waste <- read_csv("Waste_collected_per_month.csv")

waste <- waste %>% separate(date, into = c("month", "day","year"), sep = "/")  %>%
  separate(year, into = c("year", "time"), sep = " ") %>%
  arrange(year, month, day) %>% select(month, year, residential)

View(head(waste))
View(tail(waste))

# converting dataframe into time series
wasteTS = ts(waste$residential, start = c(2009,4), end = c(2020,3), frequency = 12)
wasteTS

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

# Functions for Time Series
plot_ts <- function(ts, transformation)
{
  win.graph(width = 45,
            height = 30,
            pointsize = 15)
  plot(ts,
       ylab = "Waste",
       main = c(paste0(toString(transformation),
                       " plot of Waste")),
       type="o")
  points(y=ts,x=time(ts), pch=as.vector(season(ts)))
}

# Function for ACF and PACF
autoCorrelation <- function(ts, time_series)
{
  win.graph(width = 20,
            height = 15,
            pointsize = 15)

  par(mfrow=c(2,1))
  acf(ts,
      lag.max = 48,
      main = c(paste0("ACF plot of ",toString(time_series))))

  pacf(ts,
       lag.max = 48,
       main = c(paste0("PACF plot of ",toString(time_series))))
  par(mfrow=c(1,1))
}

# Functions for its Residual Analysis
residual_model <- function(model, modelname)
{
  res.model = rstandard(model)
  win.graph(width = 20,
            height = 15,
            pointsize=15)

  par(mfrow=c(3,2))

  plot(y = res.model,
       x = as.vector(time(wasteTS)),
       main = c(paste0("Time Series plot of Standardised residuals of
                       fitted ", toString(modelname))),
       xlab = 'Time',
       ylab = 'Standardized Residuals',
       type = 'o')

  hist(res.model,
       main = c(paste0("Histogram of Standardised residuals of
                       fitted ", toString(modelname))),
       xlab='Standardized Residuals')

  qqnorm(y=res.model,
         main = c(paste0("QQ plot of standardised residuals of
                         fitted ", toString(modelname))))

  qqline(y=res.model,
         col = 2,
         lwd = 1,
         lty = 2)

  print(shapiro.test(res.model))

  acf(res.model,
      lag.max = 48,
      main = c(paste0("ACF plot of standardised residuals of
                      fitted ", toString(modelname))))

  pacf(res.model,
       lag.max = 48,
       main = c(paste0("PACF plot of standardised residuals of
                       fitted ", toString(modelname))))

  k=0
  LBQPlot(res.model,lag.max = 30, StartLag = k + 1, k = 0, SquaredQ = FALSE)
  par(mfrow=c(1,1))
}

# Function for SARIMA model
SARIMA <- function(p,d,q, modelname)
{
  ml = arima(wasteTSBC,order=c(p,d,q),
             seasonal = list(order = c(2,1,1), period = 12),
             method = "ML")

  print(coeftest(ml))
  residual_model(ml,toString(modelname))

  Model <- modelname

  AIC <- AIC(ml)
  aic <- cbind.data.frame(Model,AIC)
  AIC_SCORE <- rbind(AIC_SCORE, aic)
  AIC_SCORE <<- AIC_SCORE

  BIC <- AIC(ml,k=(log(length(wasteTS))))
  bic <- cbind.data.frame(Model,BIC)
  BIC_SCORE <- rbind(BIC_SCORE, bic)
  BIC_SCORE <<- BIC_SCORE
}

#----------------------------------------------------------------------
# Descriptive Analysis
#----------------------------------------------------------------------

# Original Time Series

par(mar=c(1,1,1,1))
plot_ts(wasteTS, "Time Series")

# ACF and PACF of original Time Series
autoCorrelation(wasteTS, "Time Series")

win.graph(width = 20,
          height = 15,
          pointsize=15)
# Scatter Plot of Consecutive Years
plot(y=wasteTS,
     x=zlag(wasteTS),
     ylab='Residential Waste (Tonnes)',
     xlab='Previous Month Residential Waste (Tonnes)',
     main = "Scatter plot of Residential Waste (Tonnes) in consequtive months")

# Correlation of Consecutive Years
y = wasteTS
x = zlag(wasteTS)
index = 2:length(x)
cor(y[index],x[index]) %>% round(3)

# -----------------------------------------------------------------------
# Box-cox Transformation
# -----------------------------------------------------------------------

win.graph(width = 20,
          height = 15,
          pointsize=15)
BC <- BoxCox.ar(wasteTS)

# box-cox confidence Interval
BC$ci

# maximum likelihood
lambda <- BC$lambda[which(max(BC$loglike) == BC$loglike)]
lambda

# box-cox transformation
wasteTSBC = ((wasteTS^lambda)-1)/lambda

plot_ts(wasteTSBC, "Box-Cox Transformation Time Series")

autoCorrelation(wasteTSBC, "Box-Cox Transformation Time Series")

# -----------------------------------------------------------------------
# Residual Approach SARIMA Models
# -----------------------------------------------------------------------

m1.temp = arima(wasteTSBC,order=c(0,0,0),
                seasonal = list(order = c(0,1,0), period = 12))
res.m1 = residuals(m1.temp)
plot_ts(res.m1,"Residuals SARIMA(0,0,0)x(0,1,0)")
autoCorrelation(res.m1,"Residuals SARIMA(0,0,0)x(0,1,0)")

m2.temp = arima(wasteTSBC,order=c(0,0,0),
                seasonal = list(order = c(2,1,1), period = 12))
res.m2 = residuals(m2.temp)
plot_ts(res.m2,"Residuals SARIMA(0,0,0)x(2,1,1)")
autoCorrelation(res.m2,"Residuals SARIMA(0,0,0)x(2,1,1)")

# P = 2, D = 1, Q = 1

# p = (1,2)
# q = (1,2,3)

# SARIMA(1,0,1)x(2,1,1),
# SARIMA(1,0,2)x(2,1,1),
# SARIMA(1,0,3)x(2,1,1),
# SARIMA(2,0,1)x(2,1,1),
# SARIMA(2,0,2)x(2,1,1),
# SARIMA(2,0,3)x(2,1,1),

m3.temp = arima(wasteTSBC,order=c(2,0,2),
                seasonal = list(order = c(2,1,1), period = 12))
res.m3 = residuals(m3.temp)
plot_ts(res.m3,"Residuals SARIMA(2,0,2)x(2,1,1)")
autoCorrelation(res.m3,"Residuals SARIMA(2,0,2)x(2,1,1)")

# -----------------------------------------------------------------------
# EACF
# -----------------------------------------------------------------------
eacf(res.m2)
# SARIMA(0,0,0)x(2,1,1),
# SARIMA(0,0,1)x(2,1,1),

# -----------------------------------------------------------------------
# BIC
# -----------------------------------------------------------------------
win.graph(width = 10,
          height = 10,
          pointsize = 15)
res = armasubsets(y=res.m2,
                  nar=8,
                  nma=8,
                  y.name='test',
                  ar.method='ols')
plot(res)
# SARIMA(1,0,3)x(2,1,1),
# SARIMA(3,0,3)x(2,1,1),

# -----------------------------------------------------------------------
# set of possible SARIMA models;
# -----------------------------------------------------------------------

# SARIMA(0,0,0)x(2,1,1),
# SARIMA(0,0,1)x(2,1,1),
# SARIMA(1,0,1)x(2,1,1),
# SARIMA(1,0,2)x(2,1,1),
# SARIMA(1,0,3)x(2,1,1),
# SARIMA(2,0,1)x(2,1,1),
# SARIMA(2,0,2)x(2,1,1),
# SARIMA(2,0,3)x(2,1,1),
# SARIMA(3,0,3)x(2,1,1)

# -----------------------------------------------------------------------
# creating null data frame for AIC and BIC
# -----------------------------------------------------------------------

AIC_SCORE <- data.frame(Model = c(),
                        AIC = c())

BIC_SCORE <- data.frame(Model = c(),
                        BIC = c())

# -----------------------------------------------------------------------
# Model Fitting
# -----------------------------------------------------------------------

# SARIMA(0,0,0)x(2,1,1),
SARIMA(0,0,0,"SARIMA(0,0,0) X (2,1,1)")

# SARIMA(0,0,1)x(2,1,1)
SARIMA(0,0,1,"SARIMA(0,0,1) X (2,1,1)")

# SARIMA(1,0,1)x(2,1,1)
SARIMA(1,0,1,"SARIMA(1,0,1) X (2,1,1)")

# SARIMA(1,0,2)x(2,1,1)
SARIMA(1,0,2,"SARIMA(1,0,2) X (2,1,1)")

# SARIMA(1,0,3)x(2,1,1)
SARIMA(1,0,3,"SARIMA(1,0,3) X (2,1,1)")

# SARIMA(2,0,1)x(2,1,1)
SARIMA(2,0,1,"SARIMA(2,0,1) X (2,1,1)")

# SARIMA(2,0,2)x(2,1,1)
SARIMA(2,0,2,"SARIMA(2,0,2) X (2,1,1)")

# SARIMA(2,0,3)x(2,1,1)
SARIMA(2,0,3,"SARIMA(2,0,3) X (2,1,1)")

# SARIMA(3,0,3)x(2,1,1)
SARIMA(3,0,3,"SARIMA(3,0,3) X (2,1,1)")

# -----------------------------------------------------------------------
# Finding Best Model
# -----------------------------------------------------------------------
AIC_SCORE %>% unique() %>%  arrange(AIC)
BIC_SCORE %>% unique() %>%  arrange(BIC)

# -----------------------------------------------------------------------
# SARIMA(3,0,3)x(2,1,1) is best model, now, let's try overfit
# -----------------------------------------------------------------------

# SARIMA(4,0,3)x(2,1,1)
SARIMA(4,0,3,"SARIMA(4,0,3) X (2,1,1)")

# SARIMA(3,0,4)x(2,1,1)
SARIMA(3,0,4,"SARIMA(3,0,4) X (2,1,1)")

# -----------------------------------------------------------------------
# SARIMA(3,0,4)x(2,1,1) is best model, now, let's try overfit
# -----------------------------------------------------------------------

# SARIMA(3,0,5)x(2,1,1)
SARIMA(3,0,5,"SARIMA(3,0,5) X (2,1,1)")

# SARIMA(4,0,4)x(2,1,1)
SARIMA(4,0,4,"SARIMA(4,0,4) X (2,1,1)")

# -----------------------------------------------------------------------
# SARIMA(3,0,5)x(2,1,1) is best model, now, let's try overfit
# -----------------------------------------------------------------------

# SARIMA(3,0,6)x(2,1,1)
SARIMA(3,0,6,"SARIMA(3,0,6) X (2,1,1)")

# SARIMA(4,0,5)x(2,1,1)
SARIMA(4,0,5,"SARIMA(4,0,5) X (2,1,1)")

# -----------------------------------------------------------------------
# SARIMA(4,0,5)x(2,1,1) is best model, now, let's try overfit
# -----------------------------------------------------------------------

# SARIMA(4,0,6)x(2,1,1)
SARIMA(4,0,6,"SARIMA(4,0,6) X (2,1,1)")

# SARIMA(5,0,5)x(2,1,1)
SARIMA(5,0,5,"SARIMA(5,0,5) X (2,1,1)")

# -----------------------------------------------------------------------
# Forecasting
# -----------------------------------------------------------------------
forecasting = Arima(wasteTS,order=c(4,0,5),
                    seasonal=list(order=c(2,1,1), period=12),
                    lambda = -0.1,
                    method = "ML")
prediction = forecast(forecasting, h = 10)

win.graph(width = 10,
          height = 10,
          pointsize = 15)
plot(prediction)

prediction


#' Compute trace of a square matrix, that is, the sum
#' of its diagonal elements.
#'
#' @param m a square matrix
#'
#' @return trace of input matrix
tr <- function(m) {
    sum(diag(m))
}


#'@title calcHMBulbousBowRes
#'
#'@description Calculate bulbous bow resistance (\code{Rb}) (kN) from the
#'Holtrop & Mennen method.
#'
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'@param forwardDraft Forward draft (deviation from actual draft indicates trim)
#' (vector of numericals, m)
#'@param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#'@param Abt Traverse bulb area (vector of numericals, m^2) (see
#' \code{\link{calcAbt}})
#'@param hb Center of bulb area above keel line (vector of numericals, m)
#' (see \code{\link{calchb}})
#'@param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#'
#'@return \code{Rb} (vector of numericals, kN)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcAbt}}
#'\item \code{\link{calchb}}
#'}
#'
#'@family Holtrop-Mennen Calculations
#'@family Resistance Calculations
#'
#'@examples
#' calcHMBulbousBowRes(seq(1,5,1),13.57,13.57,25.09,5.43,seawaterDensity=1.025)
#'
#'@export

calcHMBulbousBowRes<-function(shipSpeed,maxDraft,forwardDraft,
                            Abt,hb,seawaterDensity=1.025){
Rb<-
  0.11*exp(-3*((
  (0.56*sqrt(Abt)/(forwardDraft-1.5*hb))
)^-2))*((
  (shipSpeed)/sqrt(9.81*(forwardDraft-hb-0.25*sqrt(Abt))+0.15*((shipSpeed)^2))
)^3)*(Abt^1.5)*seawaterDensity*9.81/(1+((
  (shipSpeed)/sqrt(9.81*(forwardDraft-hb-0.25*sqrt(Abt))+0.15*((shipSpeed)^2))
)^2))

return(Rb)
}


'
Аналогично заданию 2, проверить работу арифметических операторов для векторов. Последовательно использовать векторы:
1) одного типа, одного размера
2) одного типа, разных размеров
3) разных типов, одного размера
4) разных типов, разного размера
Обобщить результаты расчетов в виде правил вычисления результирующего вектора.
'

#Одного типа, одного размера
vector1 <- c(1,2,3,4)
vector2 <- c(4,6,3,6)
vector1 + vector2
vector1 - vector2
vector1 * vector2
vector1 / vector2

#Одного типа, разных размеров
vector1 <- c(1,2,3,4, 4,5,2)
vector2 <- c(4,6,3,6)
vector1 + vector2
vector1 - vector2
vector1 * vector2
vector1 / vector2

#Разных типов, одного размера
vector1 <- c(TRUE, FALSE, TRUE, TRUE)
vector2 <- c(4,6,3,6)
vector1 + vector2
vector1 - vector2
vector1 * vector2
vector1 / vector2

#Разных типов, разного размера
vector1 <- c(TRUE, FALSE, TRUE, TRUE)
vector2 <- c(4,6,3,6,6,2,6,2,5)
vector1 + vector2
vector1 - vector2
vector1 * vector2
vector1 / vector2


boltzmann <- 3.167e-6 #hartree/K

calcul.partition <- function(valeurs, temperature){
	expo <- exp(-valeurs/(temperature * boltzmann))
	return(sum(expo))
}

calcul.energie <- function(valeurs, temperature){
	derivee <- (calcul.partition(valeurs, temperature + 1) - calcul.partition(valeurs, temperature - 1)) / 2 #Premier ordre, dT = 1
	energie <- 2 * boltzmann * temperature^2 * derivee
	energie <- energie + min(valeurs) #Energie de point 0
	return(energie)
}


mean_men<-177 #mean
sd_men<-10 #standard deviation
val_men<-200 #target value
z_mean<-(val_men - mean_men)/sd_men # calculating z-score
p_men<-pnorm(z_mean) #area under the curve from -infinity till the taget value
p_target<-1 - p_men #area under the curve is 1. So substracting from 1 toget the target area
Prob_target<-p_target*100

R Community/R Stats_Basics Part 1/Assignment4.r


Groesse <- c(176, 166, 172, 184, 179, 170, 176)
Gewicht <- c(65, 55, 67, 82, 75, 65, 75)

cor(Gewicht, Groesse, method="pearson")
reg <- lm(Gewicht~Groesse)
summary(reg)

plot(Gewicht~Groesse)
abline(reg)


#' Random PCA
#'
#' @param x
#' The input data matrix.
#' @param k
#' The number of singular values and/or left/right singular vectors
#' to estimate.
#' @param q
#' An integer exponent, say 1, 2, or 3.  See the paper for details.
#' @param retx
#' Logical;  determines if the rotated data should be returned.
#' @param center,scale
#' Logical; determines if the data should be centered/scaled first.
#'
#' @return
#' An object of class \code{prcomp}.
#'
#' @references
#' Halko, Martinsson, and Tropp. 2011. Finding structure with
#' randomness: probabilistic algorithms for constructing approximate
#' matrix decompositions. SIAM Review 53 217-288.
#'
#' Duda, R. O., Hart, P. E., & Stork, D. G. (2012). Pattern classification,
#' chapter 10. John Wiley & Sons.
#'
#' @author
#' Drew Schmidt
#'
#' @examples
#' \dontrun{
#' x <- matrix(rnorm(30), 10)
#'
#' rpca(x)
#' }
#'
#' @keywords SVD PCA
#' @name rpca
#' @rdname rpca
#' @export
rpca <- function(x, k=1, q=3, retx=TRUE, center=TRUE, scale=FALSE)
{
  if (class(x) != "ddmatrix")
    x <- as.matrix(x)

  assert.type(retx, "logical")
  assert.type(center, "logical")
  assert.type(scale, "logical")

  # Check needs to be here so we don't do anything demanding before possibly needing to error out
  rsvd.checkargs(x=x, k=k, q=q, retu=FALSE, retvt=TRUE)

  assert.type(x, "numeric")

  if (center || scale)
    x <- scale(x, center=center, scale=scale)

  svd <- rsvd(x=x, k=k, q=q, retu=FALSE, retvt=TRUE)
  svd$d <- svd$d / sqrt(nrow(x) - 1L)

  if (center)
    center <- attr(x, "scaled:center")[1:k]
  if (scale)
    scale <- attr(x, "scaled:scale")[1:k]

  pca <- list(sdev=svd$d, rotation=t(svd$vt), center=center, scale=scale)

  if (is.matrix(x))
    colnames(pca$rotation) <- paste0("PC", 1:ncol(pca$rotation))
#  else #FIXME

  if (retx)
    pca$x <- x %*% pca$rotation
  class(pca) <- "prcomp"

  return(pca)
}


#' Updates the weight matrix of an ART network.
#'
#' This function returns a new weight matrix that has "learned" the input
#' in the given category, as well as a value correspoding to whether or
#' not the weight matrix was changed (0 = no change; 1 = change).
#' @title ART_Update_Weights
#' @param input Vector of size NumFeatures that contains the input signal into the network.
#' @param weight Matrix of size NumFeatures-by-NumCategories which holds the weights of the network.
#' @param categoryNumer Number of the category that codes the current input.
#' @param learningRate Rate at which the network should learn new inputs.
#' @return List containing the UPDATEDWEIGHT and WEIGHTCHANGE. The UPDATEDWEIGHT is a matrix of size NumFeatures-by-NumCategories
#' that holds the new weights of the network after the input has been successfully learned.
#' The WEIGHTCHANGE is a value (0 or 1) which relays whether or not
#' the weight matrix was changed during this updating. Here, 0 represents
#' no change and 1 represents a change.
#' @details The length of the INPUT vector must equal the number of rows in the WEIGHT matrix, the CATEGORYNUMBER must
#' be in the range [1, NumCategories], and the LEARNINGRATE must be in the range [0, 1].
ART_Update_Weights = function(input, weight, categoryNumber, learningRate)
{
  # Get the number of features from the weight matrix.
  numFeatures = ncol(weight);
  numCategories = nrow(weight);
  # Check the input parameters for correct ranges.
  if(length(input) != numFeatures)
  {
    stop('The length of the input and rows of the weights do not match.');
  }
  if((categoryNumber < 1) | (categoryNumber > numCategories))
  {
    stop('The category number must be in the range [1, NumCategories].');
  }
  if((learningRate < 0) | (learningRate > 1))
  {
    stop('The learning rate must be within the range [0, 1].');
  }

  weightChange = 0;
  for (i in 1:numFeatures)
  {
    if(input[i] < weight[categoryNumber,i])
    {
      weight[categoryNumber,i] = (learningRate * input[i]) + ((1 - learningRate) * weight[categoryNumber,i]);
      weightChange = 1;
    }
  }

  # Return the updated weight matrix.
  updatedWeight = weight;
  return (list(updatedWeight, weightChange));
}


## Kenshu 2018.12.26
## 岡村
## 必要なRパッケージなど：MuMIn，TMB，Rtools
##

## データの読み込みと下調べ

dat1 <- read.csv("dat1.csv")   #  データの読み込み

head(dat1)   #  最初の6行を表示

table(dat1$count)    #  countデータの内訳を見る

plot(count~year, data=dat1)    #  年トレンドのプロット

tapply(dat1$count,dat1$year,mean)     #  countデータの年平均

tapply(dat1$count,list(dat1$plant,dat1$year), mean)         #  countデータの年/植生別の平均

plot(count~year, data=subset(dat1,plant=="tree"))      #  plant="tree"に対する年トレンド
plot(count~year, data=subset(dat1,plant=="shrub"))       #  plant="shrub"に対する年トレンド

## 正規線形回帰モデル

b <- cov(dat1$count, dat1$year)/var(dat1$year)     #  　線形回帰の傾きの最小二乗推定値
a <- mean(dat1$count)-b*mean(dat1$year)     #  　線形回帰の切片の最小二乗推定値
c(a,b)        #  　最小二乗推定値の表示

lm(count~year, data=dat1)        #    countの年変化の線形回帰

lm(count~year*plant, data=dat1)       #    count~year+plant+year:plantの線形回帰

# AICのシミュレーション

Res.aic <- NULL     #   結果の入れ物を作る
Sim <- 10000      #   シミュレーション回数（10000回ぐらいしないと良い結果にならない）
set.seed(1234)      #   乱数の初期値を設定
for (n in c(10,100,500,1000)){       #   サンプルサイズを10, 100, 500, 1000と変化させる
  z <- matrix(rnorm(n*Sim, 0, 1),nrow=Sim,ncol=n)      #   シミュレーション回数分データを発生（applyを使うため行列形式にしている）
  TL <- apply(z,1,function(z) integrate(function(x) dnorm(x,0,1)*dnorm(x,mean(z),sqrt(var(z)*(n-1)/n),log=TRUE),-Inf,Inf)$value)
  #  平均対数尤度   \int Q(x) P(x|\theta)．分散に(n-1)/nを掛けているのは，不偏分散を最尤推定量にするため（研修ではここ間違ってました．失礼しました）．dnormは正規分布の確率密度関数 dnorm(x, 平均, 標準偏差)
  EL <- apply(z,1,function(z) mean(dnorm(z,mean(z),sqrt(var(z)*(n-1)/n),log=TRUE)))
  #  標本に対する対数尤度の平均．
  Res.aic <- cbind(Res.aic, n*(EL-TL))
  #   2つの差はパラメータ数（この場合，平均と分散の2個）になることが期待される
}
colnames(Res.aic) <- c(10,100,500,1000)     #  列の名前をサンプルサイズにする
colMeans(Res.aic)       #  Res.aicはSim × 4の行列になっていて，列平均をとっている．これの値が2になっていれば，AICの-2*(対数尤度-パラメータ数)のパラメータ数を引くというところが正しいというのが確かめられたことになる

res.n0 <- lm(count~year,data=dat1)     #  count~yearの線形回帰の結果をres.n0の中に格納
res.n1 <- lm(count~year*plant,data=dat1)        #  count~year*plantの線形回帰の結果をres.n1という変数の中に格納
logLik(res.n0);logLik(res.n1)        #  res.n0とres.n1の対数尤度を表示
AIC(res.n0,res.n1)        #  res.n0とres.n1のAICを表示

plot(count~year,data=dat1,pch=as.numeric(plant)+1,col=as.numeric(plant)+1)　　　　       # 散布図を描く．データ点の形や色をplantで変える
year <- 0:9     #  年 0~9を変数として定義しておく
lines(year,res.n1$coef[1]+res.n1$coef[2]*year,col="red")     #  linesでモデルから得られた線を散布図に上書きする（plant="shrub"のとき）
lines(year,res.n1$coef[1]+res.n1$coef[3]+(res.n1$coef[2]+res.n1$coef[4])*year,col="green",lty=2)     #  linesでモデルから得られた線を散布図に上書きする（plant="tree"のとき）

library(MuMIn)     # モデル選択を行うためのパッケージ．installしてない人は事前にinstall.packages("MuMIn")としてください．
options(na.action = "na.fail") # 欠測値の取り扱いに関する設定（これをしないとdredgeが動かない）．欠測値があったときに，欠測値を無視しない．
dredge(res.n1,rank="AIC")   #  フルモデルから変数を除いたすべての組み合わせでモデルを比較．rank="AIC"でAICを使う（defaultはAICc）

## ポアソン回帰

# ポアソン回帰の尤度関数
Poisson.reg <- function(p,dat){
  lambda <- exp(p[1]+p[2]*dat$year)      # ポアソンの平均ラムダはいつも正なので，線形モデルを指数変換する．log(lambda)=a+b*yearとなるので，log link関数という．
  -sum(dat$count*log(lambda)-lambda)     # optimなど最適化関数は最小値を求めるので，対数尤度にマイナス符号をつける
}

optim(c(log(6),-0.07),Poisson.reg,dat=dat1,method="BFGS")    #  optim(パラメータの初期値, 最適化する関数, データ, method=最適化の方法)

glm(count~year,family=poisson,data=dat1)    #  count~yearのポアソン回帰   family=poissonでポアソン分布を指定

glm(count~year*plant,family=poisson,data=dat1)   #  count~year+plant+year:plantのポアソン回帰

res.p1 <- glm(count~year*plant,family=poisson,data=dat1)     #  フルモデルをres.p1に格納
dredge(res.p1,rank="AIC")      # AICでモデル選択

#  正規線形回帰の場合と同様，ポアソン回帰のあてはまりの図を作成
plot(count~year,data=dat1,pch=as.numeric(plant)+1,col=as.numeric(plant)+1)
year <- 0:9
lines(year,exp(res.p1$coef[1]+res.p1$coef[2]*year),col="red")
lines(year,exp(res.p1$coef[1]+res.p1$coef[3]+(res.p1$coef[2]+res.p1$coef[4])*year),col="green",lty=2)

## ロジスティック回帰

# ロジスティック回帰の対数尤度関数
Logit.reg <- function(p,dat){
  prob <- 1/(1+exp(-(p[1]+p[2]*dat$year)))     #  確率は0~1の間の数字なので，こういう変換をしてやる．逆関数はlogit=log(p/(1-p))
  -sum(dat$count*log(prob)+(10-dat$count)*log(1-prob))     # 二項分布の式から
}

optim(c(0,0),Logit.reg,dat=dat1,method="BFGS")    # optimで最適化

glm(cbind(count,10-count)~year,family=binomial,data=dat1)     # glmだと cbind(成功回数，失敗回数) ~ yearのような書き方にする．他に，0と1だけの結果ならz ~ yearのような書き方も可．

res.l1 <- glm(cbind(count,10-count)~year*plant,family=binomial,data=dat1)     # ロジスティック回帰のフルモデル
dredge(res.l1,rank="AIC")       #  AICでモデル選択

## N-混合モデル

# N混合モデルの発見関数の部分（二項分布モデル）
detect.f <- function(p, dat, N, n=10){
  y <- dat$count    #  応答変数
  X <- cbind(1,as.numeric(dat$plant)-1)     #  plantはカテゴリーなので，0 (shrub) か1 (tree)に変換してやる．model.matrix関数を使うこともできる
  r <- c(1/(1+exp(-X%*%p)))    #  1匹あたりの発見確率をplantとリンクする．X%*%pは行列とベクトルの掛算

  dbinom(y,n,1-(1-r)^N)     #  二項確率モデル．個体はNいるので，少なくとも1回発見する確率は1-(1-r)^Nとなる．
}

log(detect.f(c(1,1),dat1,2*dat1$count))[1:5]    #  発見モデルがちゃんと動くかテスト

# N混合モデルの個体数変動の部分（ポアソン分布モデル）
pop.f <- function(p, dat, N){
  X <- cbind(1,dat$year)    #  説明変数の行列
  lambda <- c(exp(X%*%p))    #  平均個体数（年で変化する）

  dpois(N,lambda)     #  ポアソン尤度
}

# N混合モデルの尤度関数
popdet.f <- function(p, dat, max.N=100, n=10){
  Pop <- function(i) {
    pop1 <- pop.f(p[3:4],dat[i,],0:max.N)       #  個々のデータに対して，ポアソン確率を0からmax.Nまで計算する
    pop1 <- pop1/sum(pop1)    # max.N=100で打ち切ったので，確率にするため全部の和で割ってやる
    pop1
  }
  like <- sapply(1:nrow(dat), function(i) sum(detect.f(p[1:2],dat[i,],0:max.N,n)*Pop(i)))      #  0~max.Nを足し合わせた周辺尤度関数を各データ（行）に対して計算
  -sum(log(like))    # 対数尤度にして足し合わせる
}

(res.nm <- optim(c(0,0,0,0),popdet.f,dat=dat1,max.N=100,method="BFGS"))     # optimで最適化  ()でくくると結果が表示される

table(dat1$plant,dat1$year)      #  plantのyearによる変化を見てやって，個体数変化の解釈をする

# N混合モデルの曲線をプロットしてやる
plot(count~year,data=dat1)
lines(year,exp(res.nm$par[3]+res.nm$par[4]*year))

## 精度計算と信頼区間（対数正規モデル）

# 精度計算のため，hessian=TRUEとしてヘッセ行列を取り出す
(res.nm <- optim(c(0,0,0,0),popdet.f,dat=dat1,max.N=100,method="BFGS",hessian=TRUE))

# ヘッセ行列の逆行列はパラメータ推定値の分散共分散行列になっている
(var.nm <- solve(res.nm$hessian))

# パラメータは個体数をlog scaleで見たものなので元のスケールに戻してやる
pred.N <- function(p,year) exp(p[3]+p[4]*year)
(E.N <- pred.N(res.nm$par,year))

# 個体数推定値をパラメータで微分したもの（数値微分）を計算して，デルタ法で個体数の分散や標準誤差，CVを計算
DN <- function(p,year,d=0.0001){
  dp <- diag(d,length(p))
  apply(dp,1,function(x) (pred.N(p+x,year)-pred.N(p-x,year))/(2*d))
}
dN <- DN(res.nm$par,0:9)
(var.N <- apply(dN, 1, function(x) x%*%var.nm%*%x))
(se.N <- sqrt(var.N))

(CV.N <- se.N/E.N)

# 上のCVを使って対数正規の95%信頼区間をプロットしてやる
plot(count~year,data=dat1)
lines(year,E.N)
alpha <- 0.05
C.ci <- exp(qnorm(1-alpha/2)*sqrt(log(1+CV.N^2)))
Lo.lim <- E.N/C.ci
Up.lim <- E.N*C.ci
arrows(year,Lo.lim,year,Up.lim,angle=90,code=3,length=0.03,col="blue")

## ブートストラップ信頼区間
# 上では対数正規を使ったが，個体数に対数正規の仮定をおかないで信頼区間を作りたい

# ノンパラメトリックブートストラップ
B <- 1000
b.boot <- NULL
for (i in 1:B){
  res.n0.b <- lm(count~year, data=dat1[sample(100,replace=TRUE),])    # リサンプリングしたデータに線形回帰をフィット
  b.boot <- c(b.boot, res.n0.b$coef[2])     #  傾きの推定値をとっておく
}
quantile(b.boot,probs=c(0.025,0.975))     #  quantile関数で95%信頼区間を出す

# 残差ブートストラップ
# 上のノンパラブートストラップでは，説明変数の出現頻度も変わってしまう，それが望ましくない場合もある．そこで残差をブートストラップする．
resid.n0 <- residuals(res.n0)     #  残差を計算
b.rb <- NULL
for (i in 1:B){
  count.rb <- predict(res.n0)+resid.n0[sample(100,replace=TRUE)]      #  リサンプリングした残差を予測値に足して，新たなデータを作る（ここも研修のとき間違ったコードでした．すいません）
  res.n0.rb <- lm(count.rb~year, data=dat1)     # 新たなデータに線形回帰モデルをフィット
  b.rb <- c(b.rb, res.n0.rb$coef[2])      #  傾きをとっておく
}
quantile(b.rb,probs=c(0.025,0.975))     #  95%信頼区間

#  パラメトリックブートストラップ
#  ポアソンの場合，カウントデータが応答変数になるので残差ブートストラップは望ましくない
res.p0 <- glm(count~year,family=poisson,data=dat1)     #  ポアソン回帰の結果
pred.p0 <- predict(res.p0,type="response")     # 予測値を計算してやる．predictはdefaultで線形予測子を返すので，type="response"として元のスケールに戻してやる（正規分布の場合はidentity linkなのでこの操作必要なかった）
b.pb <- NULL
for (i in 1:B){
  count.pb <- rpois(100,pred.p0)      #  予測値を使ってポアソン乱数を発生
  res.p0.pb <- glm(count.pb~year,family=poisson,data=dat1)      #  生成したデータにポアソン回帰を実行
  b.pb <- c(b.pb, res.p0.pb$coef[2])    #  傾きを記録する
}
quantile(b.pb,probs=c(0.025,0.975))     #  95%信頼区間

# N混合モデルの確率を計算する関数
dnm <- function(x, p, year, plant, max.N=100, n=10){
  lambda <- exp(p[3]+p[4]*year)
  pop1 <- dpois(0:max.N,lambda)
  pop1 <- pop1/sum(pop1)
  pop1
  r <- 1/(1+exp(-(p[1]+p[2]*plant)))
  sum(dbinom(x,n,1-(1-r)^(0:max.N))*pop1)
}

# 各データに対して，発見数が0から10までの場合の確率を計算してやる
prob.nm <- sapply(1:100, function(i) sapply(0:10,function(x) dnm(x,res.nm$par,as.numeric(dat1$year[i]),as.numeric(dat1$plant[i])-1)))
cprob.nm <- apply(prob.nm,2,cumsum)     #  累積確率分布を計算

dat1.cb <- dat1
d <- 10^(-10)     #  数値計算の精度の調整のために必要
b.nm <- NULL
for (i in 1:B){
  z.cb <- runif(100,0,1)      # 一様乱数を発生
  count.nm <- sapply(1:100, function(x) which(cprob.nm[,x] >= z.cb[x]-d)[1]-1)     #  上で計算した累積確率との比較で，データ（0~10）を作り出してやる
  dat1.cb$count <- count.nm      #  できたデータを応答変数にする
  res.nm.cb <- optim(c(0,0,0,0),popdet.f,dat=dat1.cb,max.N=100,method="BFGS")     # N混合モデルによるパラメータ推定
  b.nm <- rbind(b.nm, exp(res.nm.cb$par[3]+res.nm.cb$par[4]*year))      # 0~9年の個体数推定値を計算
}
CI.cb <- apply(b.nm,2,quantile,probs=c(0.025,0.975))       # 信頼区間を計算

# N混合モデルのブートストラップ信頼区間をプロット
plot(count~year,data=dat1)
lines(year,E.N)
arrows(year,CI.cb[1,],year,CI.cb[2,],angle=90,code=3,length=0.03,col="blue")

## Template Model Builder実例
# 上のN混合モデルのbooststrap計算は結構時間がかかる．そこでTMBを使って高速化してやる．

sink("nm.cpp")      # nm.cppというcppファイルを作ってやる．
#  nm.cppにTMBのための関数を書いてやる．
cat("// N-mixture model

#include <TMB.hpp>

/* Parameter estimation */
template<class Type>
Type objective_function<Type>::operator() ()
{
  // Data Section //
  DATA_INTEGER(Nmax);
  DATA_SCALAR(n);
  DATA_MATRIX(DAT);

  // Parameter Section //
  PARAMETER_VECTOR(P);

  int N=DAT.rows();

  matrix<Type> Pois(Nmax+1,N);
  vector<Type> D(N);
  vector<Type> Log_Lambda(N);
  vector<Type> R(N);
  vector<Type> BP(N);

  Type d=1e-15;

  Type f=0;

  for (int j=0;j<N;j++){
    R(j) = 1/(1+exp(-(P(0)+P(1)*DAT(j,2))));
    Log_Lambda(j) = P(2)+P(3)*DAT(j,1);
    for (int i=0;i<=Nmax;i++){
      Pois(i,j) = exp(Type(i)*Log_Lambda(j)-exp(Log_Lambda(j))-lgamma(Type(i)+1));
      D(j) += Pois(i,j);
    }

    for (int i=0;i<=Nmax;i++){
      BP(j) += exp(lgamma(n+1) - lgamma(DAT(j,0)+1) - lgamma(n-DAT(j,0)+1)+DAT(j,0)*log(1-pow(1-R(j),i)+d)+(n-DAT(j,0))*log(pow(1-R(j),i)+d))*Pois(i,j)/D(j);
    }
    f -= log(BP(j));
  }

  return f;
}",fill=TRUE)
sink()

library(TMB)     # TMBを読み込む
compile("nm.cpp")      #  nm.cppをコンパイル
dyn.load(dynlib("nm"))     # nmの実行ファイルを作る

#  TMB用にデータを加工する
dat2 <- dat1[,-3]
dat2[,3] <- as.numeric(dat2[,3])-1
dat <- list(Nmax=100, n=10, DAT=as.matrix(dat2))
parms <- list(P=c(0,0,0,0))
obj <- MakeADFun(data=dat,parameters=parms,DLL="nm")      # これで自動微分した関数を作ってやる
(res.nm.tmb <- optim(obj$par,obj$fn,obj$gr,method="BFGS",hessian=TRUE))      #  自動微分により得られたgradientなどを使うことにより高速化

#  上のTMB関数を使ってブートストラップ信頼区間を計算する．TMBを使わない場合に比べて大分速くなる．
dat1.cb.tmb <- dat1
d <- 10^(-10)
b.nm.tmb <- NULL
for (i in 1:B){
  z.cb.tmb <- runif(100,0,1)
  count.nm.tmb <- sapply(1:100, function(x) which(cprob.nm[,x] >= z.cb.tmb[x]-d)[1]-1)
  dat2[,1] <- count.nm.tmb
  dat <- list(Nmax=100, n=10, DAT=as.matrix(dat2))
  parms <- list(P=c(0,0,0,0))
  obj <- MakeADFun(data=dat,parameters=parms,DLL="nm")
  res.nm.cb.tmb <- optim(obj$par,obj$fn,obj$gr,method="BFGS")
  b.nm.tmb <- rbind(b.nm.tmb, exp(res.nm.cb.tmb$par[3]+res.nm.cb.tmb$par[4]*year))
}
CI.cb.tmb <- apply(b.nm.tmb,2,quantile,probs=c(0.025,0.975))

#  TMBで作ったブートストラップ信頼区間を描画する
plot(count~year,data=dat1)
lines(year,E.N)
arrows(year,CI.cb.tmb[1,],year,CI.cb.tmb[2,],angle=90,code=3,length=0.03,col="blue")


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200);

  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b8;
real b9;
real b10;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- mu[n-1]*exp(u+b8*((1-exp(-mu[n-1]/b10))/(mu[n-1]/b10))+b9*((1-exp(-mu[n-1]/b10))/(mu[n-1]/b10)-exp(-mu[n-1]/b10))+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.028,0.01);
b8 ~ normal(0.05,0.01);
b9 ~ normal(0.05,0.01);
b10 ~ normal(0.05,0.01);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

####### read new data Y
setwd("./covid19modelrisk/data/covid19_infected/")

##  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

E=rep(1,length(y))

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.028,b8=0.05,b9=0.05,b10=0.05,sig2=0.0005,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)

####################  trace plot

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=6

pdf(paste("M10_",abn[k],"_p1.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("u","b8","b9","b10"), inc_warmup = T,  nrow = 4, ncol = 1, window = NULL, include = TRUE)

dev.off()

pdf(paste("M10_",abn[k],"_p2.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("sigob","sig2","lambda"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

dev.off()

##################   plot 30/45/60/   length(y)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.95 )

pdf(paste("M10_",abn[k],"_30.pdf",sep=""), width = 16.5, height = 8.50)

m=30

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M10_",abn[k],"_45.pdf",sep=""), width = 16.5, height = 8.50)

m=45

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M10_",abn[k],"_60.pdf",sep=""), width = 16.5, height = 8.50)

m=60

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M10_",abn[k],"_all.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),lwd = 2)

dev.off()

########    log plot          ####################################################

k=1

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(8+N):(7+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/forecast")

pdf(paste("M10_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M10 model for ",name[k],sep=""),lwd = 2)

dev.off()

#####################################################################################################################################################
######################################      forecast          ###################################

GP.r <- function(L, s)
{

v=0
Lp=exp(log(L)+ (v - 1) * log(L + v * s) - v * s - L - lgamma(v + 1))
sLp=Lp

# calculate the vector of cum pmf
v=1
while((sLp<0.9999999) & ((L + v * s )> 0))
{Lp1=exp(log(L)+ (v - 1) * log(L + v * s) - v * s - L - lgamma(v + 1))
Lp=c(Lp,Lp1)
sLp=sLp+Lp1
v=v+1
}

csLp=c(cumsum(Lp),1) ##### add a max for it
x=length(Lp)

# first check if you are in the first interval

U = runif(1)
B = FALSE
i = 1

while(B == FALSE) {

  if(U > csLp[i])  ### U may greater than max of csLp if do not set 1
    { i=i+1}
  else
    {X=i-1
     B=TRUE}

}

return(X)

}

################################################ as.data.frame(fit@sim[[1]][[1]])[1,]

P=20
Mu=matrix(,nrow=90000,ncol=P)
X=matrix(,nrow=90000,ncol=P)

lambda_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,1]
u_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,2]
b8_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,3]
b9_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,4]
b10_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,5]
sig2_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,6]

set.seed(999)

for (r in 1:90000){

Mu[r,1]=y[length(y)]
for (s in 1:(P-1) ){

e=rnorm(1,0,sig2_p[r])

Mu[r,s+1]=Mu[r,s]*exp(u_p[r]+b8_p[r]*((1-exp(-Mu[r,s]/b10_p[r]))/(Mu[r,s]/b10_p[r]))+b9_p[r]*((1-exp(-Mu[r,s]/b10_p[r]))/(Mu[r,s]/b10_p[r])-exp(-Mu[r,s]/b10_p[r]))+e)

}}

for (r in 1:90000){
for (s in 1:(P-1) ){

X[r,s]=GP.r(Mu[r,s]*(1-lambda_p[r]), lambda_p[r])

}}

#X=Mu

Xm=apply(X,2,mean)

X5 <- apply( X , 2 , quantile, probs=0.05 )

X9 <- apply( X , 2 , quantile, probs=0.95 )

Zm=c(y,Xm)
Z5=c(y,X5)
Z9=c(y,X9)

k=1

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

m=length(Zm)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Z9[1:m]), Z5[1:m]), col = "grey80", border = NA)

lines(newx,Z9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Z5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)

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

n=length(y)

u=0.028
b8=0.05
b9=0.05
b10=0.05

x=c()
x[1]=100
for (i in 1:(n-1) ){

x[i+1]=x[i]*exp(u+b8*((1-exp(-x[i]/b10))/(x[i]/b10))+b9*((1-exp(-x[i]/b10))/(x[i]/b10)-exp(-x[i]/b10)))
}
x=round(x)
x

plot(y,ylim=c(min(y,x),max(y,x)))
par(new=TRUE)
plot(x,col="red",ylim=c(min(y,x),max(y,x)))


# Impact factor vs rejection rate
# Written by Jon Tennant, ScienceOpen

# Input data from Figshare (https://figshare.com/s/d81dcba0b9c5400a9c46) after saving as a .csv file
setwd("file pathway")

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

# Create two new vectors
IF<-data[,2]
Rej.rate<-data[,1]

# Perform a simple linear regression
Fit.IF<-lm(Rej.rate~IF)
summary(Fit.IF)
plot(Fit.IF)

# Perform bivariate correlation tests
cor.test(Rej.rate,IF,method="pearson")
cor.test(Rej.rate,IF,method="spearman")
cor.test(Rej.rate,IF,method="kendall")

# Results
# Pearson's: cor=0.0453, p=0.0005
# Spearman's: cor=0.0344, p=0.412
# Kendall's: cor=0.0204, p=0.4706

# Plot the results up and export the plot as a PDF
pdf(file='If vs Rej Rate.pdf', width=14, height=8)
plot(Rej.rate,IF,type="p",pch=1,ylab="Journal impact factor (2014)",xlab="Journal rejection rate")
abline(lm(IF~Rej.rate),lwd=2,col="red",lty=2)
legend("topleft",c("Pearson's: cor=0.453, p=0.0005","Spearman's: cor=0.0344, p=0.412","Kendall's: cor=0.0204, p=0.4706"),border="NA")
dev.off()

# Repeat but with a rejection rate threshold of 0.6
# Note that you can input data with any threshold range you like
data2<-read.csv("modified filename.csv",header=TRUE)

IF.2<-data2[,2]
Rej.rate.2<-data2[,1]

Fit.IF.2<-lm(Rej.rate.2~IF.2)
summary(Fit.IF.2)
plot(Fit.IF.2)

cor.test(Rej.rate.2,IF.2,method="pearson") #cor=0.343, p=1.745^-11
cor.test(Rej.rate.2,IF.2,method="spearman") #cor=0.189, p=0.0003
cor.test(Rej.rate.2,IF.2,method="kendall") #cor=0.131, p=0.0003

pdf(file='If vs Rej Rate, reduced.pdf', width=14, height=8)
plot(Rej.rate.2,IF.2,type="p",pch=1,ylab="Journal impact factor (2014)",xlab="Journal rejection rate")
abline(lm(IF.2~Rej.rate.2),lwd=2,col="red",lty=2)
legend("topleft",c("cor=0.343, p=1.745^-11","cor=0.189, p=0.0003","cor=0.131, p=0.0003"))
dev.off()

# Repeat but with a modified rejection rate threshold of 0.9
data3<-read.csv("modified filename_2.csv",header=TRUE)

IF.3<-data3[,2]
Rej.rate.3<-data3[,1]

Fit.IF.3<-lm(Rej.rate.3~IF.3)
summary(Fit.IF.3)
plot(Fit.IF.3)

cor.test(Rej.rate.3,IF.3,method="pearson") #cor=0.09, p=0.732
cor.test(Rej.rate.3,IF.3,method="spearman") #cor=0.094, p=0.72
cor.test(Rej.rate.3,IF.3,method="kendall") #cor=0.096, p=0.612

pdf(file='If vs Rej Rate, reduced2.pdf', width=14, height=8)
plot(Rej.rate.3,IF.3,type="p",pch=1,ylab="Journal impact factor (2014)",xlab="Journal rejection rate")
abline(lm(IF.3~Rej.rate.3),lwd=2,col="red",lty=2)
legend("topleft",c("cor=0.09, p=0.732","cor=0.094, p=0.72","cor=0.096, p=0.612"))
dev.off()


# 4. faza: Analiza podatkov

#NAPOVED RASTI NETO POVPREČNE PLAČE V SLOVENIJI
#linearna regresija

model <- lm(POVPRECNA.MESECNA.PLACA.SLO ~ MESEC, data=mesecne.place.slo)

#napoved za vsak prvi mesec v letu

prihodnja.leta <- data.frame(MESEC = c("2014-01-01", "2015-01-01", "2015-01-01", "2016-01-01", "2017-01-01", "2018-01-01", "2019-01-01",

                                       "2020-01-01", "2021-01-01", "2022-01-01", "2023-01-01", "2024-01-01", "2025-01-01"))

prihodnja.leta$MESEC <- as.Date(prihodnja.leta$MESEC)

napoved.slo <- mutate(prihodnja.leta, POVPRECNA.MESECNA.PLACA.SLO = predict(model,prihodnja.leta))

napoved.graf <- ggplot(mesecne.place.slo, aes( x = MESEC, y = POVPRECNA.MESECNA.PLACA.SLO)) + geom_point() +

  geom_smooth(method = 'lm', fullrange = TRUE, formula = y~x) +

  geom_point(data = napoved.slo, aes( x = MESEC, y = POVPRECNA.MESECNA.PLACA.SLO),color='red') +
  xlab("Leto") + ylab("Mesečna plača (€)") + ggtitle('Napoved mesečnih januarskih plač')


gauss <- function(a, b) {
  n <- nrow(a)
  det <- 1

  for (i in seq_len(n - 1)) {
    j <- which.max(a[i:n, i]) + i - 1
    if (j != i) {
      a[c(i, j), i:n] <- a[c(j, i), i:n]
      b[c(i, j), ] <- b[c(j, i), ]
      det <- -det
    }

    k <- seq(i + 1, n)
    for (j in k) {
      s <- a[[j, i]] / a[[i, i]]
      a[j, k] <- a[j, k] - s * a[i, k]
      b[j, ] <- b[j, ] - s * b[i, ]
    }
  }

  for (i in seq(n, 1)) {
    if (i < n) {
      for (j in seq(i + 1, n)) {
        b[i, ] <- b[i, ] - a[[i, j]] * b[j, ]
      }
    }
    b[i, ] <- b[i, ] / a[[i, i]]
    det <- det * a[[i, i]]
  }

  list(x=b, det=det)
}

a <- matrix(c(2, 9, 4, 7, 5, 3, 6, 1, 8), 3, 3, byrow=T)
gauss(a, diag(3))


# Functia care genereaza repartitia comuna incompleta

frepcomgen = function(m, n) {
  m=2
  n=3

  # Generam m valori pentru x in intervalul [0, m * 10] si
  # n valori pentru y in [0, n * 10]
  xValues <- sample.int(m * 10, m);
  yValues <- sample.int(n * 10, n);

  # Adaugam in acesti vectori Qi si Pi pentru capetele de tabel
  xValues <- c(xValues, 'Qi')
  yValues <- c(yValues, 'Pi')

  # Construim tabelul de repartitie, reprezentat ca o matrice, unde valoarea -1
  # semnifica faptul ca probabilitatea pentru (X = xi si Y=yi) nu este cunoscuta
  repart <- matrix(-1, nrow=m+1, ncol=n+1)
  rownames(repart) <- xValues
  colnames(repart) <- yValues
  repart[m+1, n+1] = 1

  # Completam repartitia cu valori aleatoare, dar care vor respecta totusi conditia ca
  # suma pe linii/coloane sa fie mai mica ca 1 (sau egala)
  repart[1, 4] <- runif(1, 0, 1)
  repart[1, 1] <- runif(1, 0, repart[1, 4])

  repart[3, 1] <- runif(1, repart[1, 1], 1)

  repart[2, 2] <- runif(1, 0, 1 - repart[3, 1])
  while(repart[3, 2] - repart[2, 2] + repart[1, 1] > repart[1, 4] ||
          repart[3, 1] - repart[1, 1] + repart[2, 2] > 1 - repart[1, 4])
    repart[2, 2] <- runif(1, 0, 1 - repart[3, 1])

  repart[3, 2] <- runif(1, min(repart[2, 2], repart[3, 1]), 1 - max(repart[2, 2], repart[3, 1]))
  while(repart[3, 2] + repart[3, 1] > 1 || repart[2, 2] > repart[3, 2])
    repart[3, 2] <- runif(1, min(repart[2, 2], repart[3, 1]), 1 - max(repart[2, 2], repart[3, 1]))

  return(repart)
}

# Functia fcomplrepcom efectueaza operatii pe linii si coloane pentru a determina valorile
# necunoscute din repartitia comuna
fcomplrepcom <- function(repart) {
  repart[2, 4] = 1 - repart[1, 4]
  repart[1, 2] = repart[3, 2] - repart[2, 2]
  repart[1, 3] = repart[1, 4] - repart[1, 1] - repart[1, 2]
  repart[2, 1] = repart[3, 1] - repart[1, 1]
  repart[2, 3] = repart[2, 4] - repart[2, 2] - repart[2, 1]
  repart[3, 3] = 1 - repart[3, 1] - repart[3, 2]

  data.frame(repart)
}

repart <- frepcomgen(2, 3)
#repart
fcomplrepcom(repart)


# condPvalue: This is the conditional p-value integral described in Andrews, Moreira, and Stock (2007, Journal of Econometrics)
#             P(m,qT) = 1 - Pr(LR > m |QT = qT)
#          m: test stat value
#         qT:  conditional value of Qt
#          k: number of moment conditions (i.e. number of instruments)
#
#        eps: epsilon (for numerical stability, default set based on Andrews, Moreira, and Stock's 2007 recommendation (0.02)
# OUTPUT: a p-value
# NOTE: mimics condivreg.ado's new_try function in Mikusheva and Poi (2006)'s STATA function
condPvalue <- function(m,qT,k,df2,eps = 0.02) {
  if(k == 1) { # Eqivalent to AR #
    return(1 - pf(m,k,df2))
  }
  K = gamma(k/2) / (sqrt(pi) * gamma((k-1)/2))
  if(k == 2) {
    return(1 - 2 * K * integrate(function(x){pchisq( (qT + m)/(1 + qT * sin(x)^2/m),k)},lower=0,upper=pi/2)$value)
  } else if(k == 3) {
    return(1 - 2 * K * integrate(function(x){pchisq( (qT + m)/(1 + qT * x^2/m),k)},lower=0,upper=1)$value)
  } else if(k == 4) {
    nonapproxRegion = 2 * K * integrate(function(x){pchisq( (qT + m)/(1 + qT * x^2/m),k) * (1 - x^2)^((k-3)/2)},lower=0,upper=1-eps)$value
    approxRegion =  2 * K * pchisq( (qT + m) / (1 + qT *(1 - eps/2)^2 /m),k) * (1/2 * (pi/2 - asin(1 - eps)) - (1 - eps)/2 * sqrt( 1- (1 - eps)^2))
    return(1 - nonapproxRegion - approxRegion)
  } else {
    return(1 - 2*K * integrate(function(x){pchisq( (qT + m)/(1 + qT * x^2/m),k) * (1 - x^2)^((k-3)/2)},lower=0,upper=1)$value)
  }
}

### CLR: Generates the CLR confidnece interval
###         Must run ivmodel before you run this code
### INPUT: ivmodel, an object from ivmodel() function
###        alpha, significance level for confidence intervals
### OUTPUT: a list of point estimate, standard error, test statistic, and p-value
CLR = function(ivmodel,beta0=0,alpha=0.05) {
  # Error checking
  if(class(ivmodel) != "ivmodel") {
    print("CLR: You must supply an ivmodel class. See ivmodel function for details")
	return(NULL)
  }
  # Extract objects from ivmodel
  Yadj = ivmodel$Yadj; Dadj = ivmodel$Dadj; ZadjQR = ivmodel$ZadjQR
  Y = ivmodel$Y; D = ivmodel$D

  # Qs, Qst, Qst, Qt #
  YadjANDDadj = cbind(Yadj,Dadj) #You can also use the original Y and D
  PZYadjANDDadj = qr.fitted(ZadjQR,YadjANDDadj);
  RZYadjANDDadj = qr.resid(ZadjQR,YadjANDDadj);

  sigmaHat = (t(RZYadjANDDadj) %*% RZYadjANDDadj) / (ivmodel$n - ivmodel$p - ivmodel$L)
  sigmaHatInv = invTwobyTwoSymMatrix(sigmaHat)

  a0 = c(beta0,1); b0 = c(1,-beta0)
  denomS = t(b0) %*% sigmaHat %*% b0; denomT = t(a0) %*% sigmaHatInv %*% a0
  numT = PZYadjANDDadj %*% sigmaHatInv
  QS = sum( (PZYadjANDDadj %*% b0)^2) / denomS
  QT = sum( (PZYadjANDDadj %*% sigmaHatInv %*% a0)^2) / denomT
  QTS = sum( (PZYadjANDDadj %*% b0) * (PZYadjANDDadj %*% sigmaHatInv %*% a0)) / (sqrt(denomS) * sqrt(denomT))

  LRtest = 1/2 * (QS - QT + sqrt((QS + QT)^2 - 4*(QS *QT - QTS^2)))

  test.stat = matrix(LRtest,1,1)
  QT = as.numeric(QT); LRtest = as.numeric(LRtest)
  p.value = tryCatch({condPvalue(LRtest,QT,ivmodel$L,ivmodel$n - ivmodel$p- ivmodel$L)},error=function(e){0})
  p.value = matrix(p.value,1,1)
  maxEigen = max(quadSolver(a=1,b=-1*(QS + QT),c=QS *QT - QTS^2)) #of Q matrix
  C = tryCatch({uniroot(function(y){condPvalue(m=maxEigen - y,qT = y,k = ivmodel$L,df2=ivmodel$n - ivmodel$p- ivmodel$L) - alpha},
  	            lower=10*.Machine$double.eps,upper=maxEigen - 5*.Machine$double.eps,maxiter=5000)$root},error=function(e){0})
  quadMatrix.CLR = sigmaHatInv %*% t(YadjANDDadj) %*% PZYadjANDDadj %*% sigmaHatInv  - C * sigmaHatInv
  ci.CLR = quadSolver(a=quadMatrix.CLR[1,1],b=2*quadMatrix.CLR[1,2],c=quadMatrix.CLR[2,2])
  if(quadMatrix.CLR[1,1] > 0) {
    if(is.na(ci.CLR[1])) {
      ci.CLR = matrix(c(-Inf,Inf),1,2)
	  info = c("Whole Real Line")
    } else {
	    ci.CLR = matrix(c(-Inf,ci.CLR[1],ci.CLR[2],Inf),2,2,byrow=TRUE)
		info = c(paste("(-Infinity, ",ci.CLR[1,2],"] union [",ci.CLR[2,1],", Infinity)",sep=""))
	  }
  } else {
    ci.CLR = matrix(c(ci.CLR[1],ci.CLR[2]),1,2)
	info = paste("[",ci.CLR[1,1],", ",ci.CLR[1,2],"]",sep="")
  }

  # Package output
  colnames(p.value) = colnames(test.stat) = beta0
  colnames(ci.CLR) = c(paste(as.character(round(alpha/2 * 100,1)),"%"),paste(as.character( round((1-alpha/2) * 100,1)),"%"))

  return(list(test.stat = test.stat,p.value = p.value,ci = ci.CLR,ci.info = info))
}


#more general function, v is assumed to be a vector
spiralv<-function(v){
  n<-sqrt(length(v))
  if(n!=floor(n)) stop(simpleError("length of v should be a square of an integer"))
  if(n==0) stop(simpleError("v should be of positive length"))
  if(n==1) M<-matrix(v,1,1)
  else M<-rbind(v[1:n],cbind(spiralv(v[(2*n):(n^2)])[(n-1):1,(n-1):1],v[(n+1):(2*n-1)]))
  M
}
#wrapper
spiral<-function(n){spiralv(0:(n^2-1))}
#check:
spiral(5)


#############################################################################3
#
# File:    fitgumbeldist.r
# Author:  Alex Stivala
# Created: July 2010
#
# fitgumbeldist.r - compute Gumbest dist. parameters and build plots
#
# R script for fitting Gumbel distribution (finding parameters location
# and scale) and plotting histograms and fit over them.
# Also, compute the z-score and p-values using this, then
# compute coverage-vs-EPQ graph  as used in Ortiz et al 2002 (and earlier
# Levitt and Gerstein (1998) to compare the analytic and observed p-values)
#
#
# Uses commandArgs() R function to get trailing arguments from R command
# line ie after the --args option. The filename of the .slrtab file
# (score and label)
# is obtained from --args.
#
# label is used to separate same fold (1) and different fold (0) scores,
# different distributinos fitted to each
#
# outputs stuff on stdout (including the parameter values) and
# creates PostScript file with histograms and curves, with filename
# derived form input filename: basename_gumbel.eps
#
#    R --vanilla -f plotssehistogram.r --args query200.slrtab
#
# creates query200_gumbel.eps
# and     query200_epq_gumbel.eps
#
# Uses the evir R package for gumbel fitting and the evd package for dbumbel()
#
# $Id: fitgumbeldist.r 3955 2010-07-21 05:52:47Z alexs $
#############################################################################3

library(evir)
library(evd)

#############################################################################3
#
# constants
#
#############################################################################3

colorvec=c('deepskyblue4','brown','red','turquoise','blue','purple','green','cyan','gray20','magenta','darkolivegreen2','midnightblue','magenta3','darkseagreen','violetred3','darkslategray3')
ltyvec=c(1,2,4,5,6,1,2,1,5,6,1,2,4,5,6,1,2)
pchvec=c(20,21,22,23,24,25,19,21,22)

eulergamma <- 0.5772156649015328606

#############################################################################3
#
# functions
#
#############################################################################3

#
# z_gumbel() -  compute Z-score from Gumbel distribution
#
# Parameters:
#    x - score to compute Z-score for
#    gumbel - evd object for Gumbel distribution from gumbel()
#
# Return value:
#    Z-score computed for x according to gum distribution
#
z_gumbel <- function(x, gum )
{
      a<- gum0$par.ests[2]
      b <- gum0$par.ests[1]
      mu <- a + b * eulergamma
      sigma <- ( (pi  / sqrt(6)) * b )
      z <- (x - mu)/sigma
      return (z)
}

#
# pv_gumbel() - compute P-value for Z-score from Gumbel distribution
#
# Parameters:
#    z - Z-score from z_gumbel()
#
# Return value:
#    P-value for the Z-score
#
pv_gumbel <- function(z)
{
    return ( 1 - exp(-exp(-( (pi/sqrt(6)*z + eulergamma) ) ) ) )
}

#############################################################################3
#
# main
#
#############################################################################3

filename <- commandArgs(trailingOnly=TRUE)

# EPS suitable for inserting into LaTeX
postscript(sub('[.]slrtab$','_gumbel.eps',filename),
           onefile=FALSE,paper="special",horizontal=FALSE,
           width = 9, height = 6)

slrtab <- read.table(filename, header=T)
slrtab <- subset(slrtab, score >= 0) # one or two -ve scores sometimes

#
# Fit Gumbel distribution to same fold scores and different fold scores
#

gum0 <- gumbel(subset(slrtab, label == 0)$score)
gum1 <- gumbel(subset(slrtab, label == 1)$score)

cat('different folds: a = ', format(gum0$par.ests[2], digits=16), ' ' )
cat('b = ', format(gum0$par.ests[1], digits=16), '\n')
cat('same fold: a = ', format(gum1$par.ests[2], digits=16), ' ' )
cat('b = ', format(gum1$par.ests[1], digits=16), '\n')

#
# Plot histograms and Gumbel distributions fitted to them
#

h0 <- hist(subset(slrtab, label == 0)$score, breaks=20, plot=F)
h1 <- hist(subset(slrtab, label == 1)$score, breaks=20, plot=F)
xh0 <- c(min(h0$breaks), h0$breaks)
yh0 <- c(0, h0$density, 0)
xh1 <- c(min(h1$breaks), h1$breaks)
yh1 <- c(0, h1$density, 0)

plot(xh0, yh0, type='s', lty=ltyvec[1], col=colorvec[1], xlab='score',ylab='frequency', ylim=c(0,1.0)) # ylim=c(0, max(yh0, yh1)) )
lines(xh1, yh1, type='s', lty=ltyvec[2], col=colorvec[2])

curve(dgumbel(x, gum0$par.ests[2], gum0$par.ests[1]), col=colorvec[3], lty=ltyvec[3], add=T)
curve(dgumbel(x, gum1$par.ests[2], gum1$par.ests[1]), col=colorvec[4], lty=ltyvec[4], add=T)

legend("topright", lty=ltyvec, col=colorvec, bty='n',
       legend=c("Different folds, histogram",
         "Same fold, histogram",
         "Different folds, fitted Gumbel distribution",
         "Same fold, fitted Gumbel distribution") )

dev.off()

#
# compute P-values for all scores
#

pvslrtab <- slrtab
pvslrtab$pvalue <- pv_gumbel(z_gumbel(slrtab$score, gum0))

#
# compute coverage-vs-EPQ graph  as used in Ortiz et al 2002 (and earlier
# Levitt and Gerstein (1998) to compare the analytic and observed p-values)
#

# sort by ascending P-value so 'best' are at start of list
pvslrtab <- pvslrtab[sort.list(pvslrtab$pvalue),]

tptotal <- length(subset(pvslrtab, label == 1)$label)
tpcount <- 0
fpcount <- 0

coverage_vec <- c()
obs_pv_vec <- c()
analytic_pv_vec <- c()

for (i in 1:length(pvslrtab$label))
{
 if (pvslrtab$label[i] == 0)
 {
 fpcount <- fpcount + 1
 }
 else
 {
 tpcount <- tpcount + 1
 }
 observed_pvalue <- fpcount / (length(pvslrtab$label) - tptotal)
 coverage <- tpcount / tptotal

 coverage_vec <- c(coverage_vec, coverage)
 obs_pv_vec <- c(obs_pv_vec, observed_pvalue)
 analytic_pv_vec <- c(analytic_pv_vec, pvslrtab$pvalue[i])

 #cat (sprintf("%d\t%f\t%f\t%f\n", i, pvslrtab$pvalue[i], observed_pvalue, coverage) )

 if (observed_pvalue > 0.05)
   {
    break
  }
}

# EPS suitable for inserting into LaTeX
postscript(sub('[.]slrtab$','_epq_gumbel.eps',filename),
           onefile=FALSE,paper="special",horizontal=FALSE,
           width = 9, height = 6)

plot(analytic_pv_vec*100, coverage_vec*100, type='n', xlab='Errors per query (%)',
     ylab='Coverage (%)')

lines(analytic_pv_vec*100, coverage_vec*100, col=colorvec[1], lty=ltyvec[1])
lines(obs_pv_vec*100, coverage_vec*100, col=colorvec[2], lty=ltyvec[2])

legend('topleft', col=colorvec, lty=ltyvec, legend=c('Analytic','Observed'),
       bty='n')

dev.off()


model_snowdepth <- function (Snowmelt = 0.0,
         Sdepth_t1 = 0.0,
         Snowaccu = 0.0,
         E = 0.0,
         rho = 100.0){
    #'- Name: SnowDepth -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: snow cover depth Calculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: snow cover depth Calculation
    #'- inputs:
    #'            * name: Snowmelt
    #'                          ** description : snow melt
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : m
    #'                          ** uri :
    #'            * name: Sdepth_t1
    #'                          ** description : snow cover depth Calculation in previous day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : m
    #'                          ** uri :
    #'            * name: Snowaccu
    #'                          ** description : snowfall accumulation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'            * name: E
    #'                          ** description : snow compaction parameter
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mm/mm/d
    #'                          ** uri :
    #'            * name: rho
    #'                          ** description : The density of the new snow fixed by the user
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 100
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : kg/m**3
    #'                          ** uri :
    #'- outputs:
    #'            * name: Sdepth
    #'                          ** description : snow cover depth Calculation
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : m
    #'                          ** uri :
    Sdepth <- 0.0
    if (Snowmelt <= Sdepth_t1 + (Snowaccu / rho))
    {
        Sdepth <- Snowaccu / rho + Sdepth_t1 - Snowmelt - (Sdepth_t1 * E)
    }
    return (list('Sdepth' = Sdepth))
}


get_expected = function(beta, N0, tau1, tau2) {
  "
  Returns
  -------
  expected_NN : numeric vector
    Daily expected number of new infectious cases
  expected_N : numeric vector
    Daily expected number of infectious cases.
  "
  daysUntilFirstSintoms=0
  daysUntilFirstSintoms=ceiling(1/tau1)-1
  beta=c(rep(beta[1],daysUntilFirstSintoms),beta)
  moments = length(beta)
  expected_NN = rep(0, moments)
  expected_N = rep(0, moments)
  expected_XN = rep(0, moments)
  expected_X = rep(0, moments)
  X_previous = N0
  N_previous = 0

  for(t in 1:moments){
    expected_N[t] = N_previous * pexp(1, rate=tau2, lower.tail=FALSE) + X_previous * pexp(1, rate=tau1, lower.tail=TRUE)
    expected_X[t] = N_previous * beta[t] + X_previous * pexp(1, rate=tau1, lower.tail=FALSE)
    expected_NN[t] = + X_previous * pexp(1, rate=tau1, lower.tail=TRUE)
    expected_XN[t] = N_previous * beta[t]
    N_previous = expected_N[t]
    X_previous = expected_X[t]
  }
  expected = list("NN"=expected_NN[(daysUntilFirstSintoms+1):moments], "N"=expected_N[(daysUntilFirstSintoms+1):moments],"XN"=expected_XN[(daysUntilFirstSintoms+1):moments], "X"=expected_X[(daysUntilFirstSintoms+1):moments])
  return(expected)
}


#' Compute pressure (in hPa) from elevation
#' @param elev Vector of elevations
#' @return Pressure for given elevations in hPa
#' @export
pressureFromElevation <- function(elev) {
	# barometric eqn
	g <- 9.80665 # acceleration of gravity
	M <- 0.0289644 # molar mass of air
	Lb <- -0.0065 # temperature lapse rate
	Pb <- 101325 # static pressure
	Tb <- 288.15 # standard temperature
	Rs <- 8.31432 # gas constant
	presPascals <- Pb * (Tb / (Tb + Lb * elev))^(g * M / (Rs * Lb))
	presPascals / 100
}

#' Convert hPa to atmospheres
#' @param P Vector of pressures (in hPa)
#' @return Pressure in atm
#' @export
hPaToAtm <- function(P) {
	P * 9.86923266e-4
}


#' @title
#' Reduced-rank regression with a given rank
#'
#' @description
#' This function provides the reduced-rank regression estimator with a given rank.
#'
#' @usage
#' RRR(Y, X, nrank = 1, weight = FALSE, Gamma = diag(ncol(Y)),
#'     ypy.svd = TRUE, c.svd = FALSE)
#'
#' @param Y response matrix.
#' @param X design matrix.
#' @param nrank a user-specified rank. Default is 1.
#' @param weight a logical value. If TRUE, then the weighted criterion is employed.
#'               Default is FALSE.
#' @param Gamma a weight matrix. Default is an identity matrix.
#' @param ypy.svd a logical value. If TRUE (default), then the singular value decomposition
#'                method is used. If FALSE, then the eigenvalue decomposition method is used.
#' @param c.svd a logical value. If TRUE, then output the singular value
#'              decomposition of the estimated coefficient
#'              matrix. Default is FALSE.
#'
#' @return The function returns a list:
#'   \item{C}{the reduced-rank estimator.}
#'   \item{C_ls}{the least square estimator.}
#'   \item{rank}{the rank value.}
#'
#' @references
#' Velu, R., & Reinsel, G. C. (2013). Multivariate reduced-rank regression:
#' theory and applications (Vol. 136). Springer Science & Business Media.
#' @importFrom MASS ginv
#' @export
RRR <- function(Y, X, nrank = 1, weight = FALSE, Gamma = diag(ncol(Y)),
                 ypy.svd = TRUE, c.svd = FALSE){
  q <- ncol(Y)
  n <- nrow(Y)
  p <- ncol(X)
  S_yx <- t(Y) %*% X
  S_xx <- t(X) %*% X
  S_xx_inv <- tryCatch(MASS::ginv(S_xx), error = function(e) solve(S_xx +
                                                               0.1 * diag(p)))
  if (sum(is.na(S_xx_inv)) > 0) {
    S_xx_inv <- solve(S_xx + 0.1 * diag(p))
  }
  C_ls <- S_xx_inv %*% t(S_yx)
  if (weight == TRUE) {
    eigenGm <- eigen(Gamma)
    sqrtGm <- eigenGm$vectors %*% diag(sqrt(eigenGm$values)) %*%
      t(eigenGm$vectors)
    sqrtinvGm <- eigenGm$vectors %*% diag(sqrt(eigenGm$values^(-1))) %*%
      t(eigenGm$vectors)
    if (ypy.svd) {
      XC <- X %*% C_ls %*% sqrtGm
      svdXC <- tryCatch(svd(XC, nu = nrank, nv = nrank),
                        error = function(e) 2)
      if (tryCatch(svdXC == 2, error = function(e) 3) ==
          3) {
        A <- svdXC$v[, 1:nrank]
        Ad <- (svdXC$d[1:nrank])^2
      }
      else {
        ypy.svd <- FALSE
      }
    }
    if (!ypy.svd) {
      SS <- sqrtGm %*% S_yx %*% C_ls %*% sqrtGm
      SS <- (SS + t(SS))/2
      eigenSS <- eigen(SS, symmetric = TRUE)
      A <- as.matrix(eigenSS$vectors[, 1:nrank])
      Ad <- eigenSS$values[1:nrank]
    }
    AA <- A %*% t(A)
    C_rr <- C_ls %*% sqrtGm %*% AA %*% sqrtinvGm
  }
  else {
    if (ypy.svd) {
      XC <- X %*% C_ls
      svdXC <- tryCatch(svd(XC, nu = nrank, nv = nrank),
                        error = function(e) 2)
      if (tryCatch(svdXC == 2, error = function(e) 3) ==
          3) {
        A <- svdXC$v[, 1:nrank]
        Ad <- (svdXC$d[1:nrank])^2
      }
      else {
        ypy.svd <- FALSE
      }
    }
    if (!ypy.svd) {
      SS <- S_yx %*% C_ls
      SS <- (SS + t(SS))/2
      eigenSS <- eigen(SS, symmetric = TRUE)
      A <- as.matrix(eigenSS$vectors[, 1:nrank])
      Ad <- eigenSS$values[1:nrank]
    }
    AA <- A %*% t(A)
    C_rr <- C_ls %*% AA
  }
  if (c.svd) {
    svd_C <- svd(C_rr, nv = nrank, nu = nrank)
    U <- as.matrix(svd_C$u[, 1:nrank])
    V <- as.matrix(svd_C$v[, 1:nrank])
    D <- diag(svd_C$d[1:nrank], nrow = nrank)
    list(A = A, Ad = Ad, C_ls = C_ls, C_rr = C_rr, U = U,
         V = V, D = D, C = C_rr, rank = nrank)
  }
  else {
    list(A = A, Ad = Ad, C_ls = C_ls, C_rr = C_rr, C = C_rr,
         rank = nrank)
  }
}


#Author: Leyton Taylor

##alphaN(t) = planar curve s.t. alphaN(t)=[x(t),y(t),-1]
##Notation: calcIterate(alphaN(t))=[curvatureIAlphaN(t), torsionIAlphaN(t)] where IAlpha(t) = Image of alpha(t) when stereographically projected to
##the unit sphere
##betaMap(alpha(t))=projection map of alpha to unit sphere i.e. alphaI(t)
##gammaMap(alpha(t))=osculating circle of alphaI(t)
##dataSet=matrix(alphaN(t)=(x(t),y(t),z=-1), nrow=N, ncol=3)
#dataSet= matrix(c(expression(1+.5*cos(t)),expression(1+.1*sin(t)),expression(-1)), nrow=1,ncol=3,byrow=TRUE)
#dataSet= matrix(c(expression(-.5 + sin(t)*cos(t)),expression(-1 + sin(t)),expression(-1)), nrow=1,ncol=3,byrow=TRUE)
#alphaN=dataSet[1,]
#alphaNP= c(expression(D(alphaN[1],'t')), expression(D(alphaN[2],'t')),expression(0))
#alphaNDP = c(expression(D(alphaNP[1],'t')), expression(D(alphaNP[2],'t')),expression(0))
#alphaNPrimeVec = matrix(
#+     c(),
#+     nrow=3,
#+     ncol=3
#+ )
# alphaNPrimeVec = matrix(
#   +     c(alphaN,alphaNP,alphaNDP),
#   +     nrow=3,
#   +     ncol=3
#   + )

# main <- function(dataSet){
#     tRange <- data.frame(t=seq(0,2*pi,.1))
#     nIterates=10
#     for(i in 0:nrow(dataSet)){
#         ##Output matrix of nIterate rows and 2 columns = corresponding to [curvature(Ialpha(t)),torsion(Ialpha(t))]
#         output=calcOrbit(c(dataSet[i,1],dataSet[i,2],dataSet[i,3]),nIterates,tRange)
#         print(output)
#     }
# }

##Output matrix of corresponding iterates of alphaN
# calcOrbit <- function(alphaN,nIterates,tRange){
#     tRange<-seq_along(tRange)
#     orbitMatrix = matrix(c(),nrow = nIterates, ncol=3,dimnames = list(, c("x(t)","y(t)","z=-1")))
#     outputOrbit = matrix(c(),nrow = length(tRange), ncol=3,dimnames = list(, c("x(t)","y(t)","z=-1")))
#     rbind(orbitMatrix, calcIterate(alphaN))
#     orbitPlot <- matrix(c(),nrow=nI)
#     #k=order of orbit
#     for (k in 1:nIterates){
#         ktVectorFunction=calcIterate(orbitMatrix[c(k-1)])
#         #Binds each consecutive iterate to orbitMartix
#         rbind(orbitMatrix,ktVectorFunction)
#         for(t in tRange){
#           rbind(outputOrbit,c(ktVectorFunction[1](t),ktVectorFunction[2](t),-1))
#         }
#
#     }
# }

options(digits = 15)

#parameter t and returns a parametric function that corresponds
#to the projection of Curvature and Torsion for each t
calcIterate <- function(alphaN){
  return(projectionKT(alphaN, pi/8))
}

#Returns corresponding curvature(t) and torsion(t)
#of the projected Parametric function passed to it
projectionKT <- function(alphaN,t){
  t=t
  #First deriveative of curve [k(t),T(t)]
  alphaNP <- c(D(alphaN[1],'t'), D(alphaN[2],'t'),0)
  #Second derivative of curve [k(t),T(t)]
  alphaNDP <- c(D(D(alphaN[1],'t'),'t'),D(D(alphaN[2],'t'),'t'),0)
  alphaNTP <- c(D(D(D(alphaN[1],'t'),'t'),'t'),D(D(D(alphaN[2],'t'),'t'),'t'),0)

  #vector containing ktVec,ktVecP, ktVecDP
  alphaNPrimeVec <-matrix(
    c(alphaN,alphaNP,alphaNDP,alphaNTP),
    nrow=4,
    ncol=3,
    byrow=TRUE
    )

  dimnames(alphaNPrimeVec)=list(c("alphaN","alphaNP","alphaNDP","alphaNTP"),c("X","Y","Z"))
  print("alphaN")
  print(alphaNPrimeVec["alphaN",])
  print("AlphaNp")
  print(alphaNPrimeVec["alphaNP",])
  print("alphaNDP")
  print(alphaNPrimeVec["alphaNDP",])
  print("alphaNTP")
  print(alphaNPrimeVec["alphaNTP",])
  print("done")
  return(c(ktCalculation(alphaNPrimeVec,t)))

}

ktCalculation <- function(alphaNPrimeVec, t){

  A <- curvatureI(alphaNPrimeVec,t)
  curvature <- A$curvature
  torsion <- A$torsion

  return(c(curvature,torsion))

}

arcLengthGamma <- function(gammaMatrix, Xo, Yo, kAlpha, t){
  gammaEnv <- new.env(hash=TRUE,size=4)
  assign("Xo",value=Xo,envir=gammaEnv)
  assign("Yo",value=Yo,envir=gammaEnv)
  assign("kAlpha",value=kAlpha,envir=gammaEnv)
  t <- t
  Xo <- Xo
  Yo <- Yo
  kAlpha <- kAlpha
  xfunc <- function(u){eval(gammaMatrix[1,1], gammaEnv)}
  yfunc <- function(u){eval(gammaMatrix[1,2], gammaEnv)}
  zfunc <- function(u){eval(gammaMatrix[1,3], gammaEnv)}
  f <- function(u) c(xfunc(u),yfunc(u),zfunc(u))

  return(arclength(f, t, (t)+2*pi))

}

arcLengthBeta <- function(betaMatrix, a, alphaNPrimeVec){
  betaEnv <- new.env(hash=TRUE,size=2)
  assign("X",value<-deparse(alphaNPrimeVec[1,1]),envir=betaEnv)
  assign("Y",value<-deparse(alphaNPrimeVec[1,2]),envir=betaEnv)
  b <- deparse(betaMatrix[1])
  print("tt")
  print(alphaNPrimeVec)
  b1 <- substitute(b, list(X = deparse(alphaNPrimeVec[1,1])))
  print(eval(b1))
  t<-t
  xfunc <- function(t){substitute(betaMatrix[1], betaEnv)}
  yfunc <- function(t){substitute(betaMatrix[2], betaEnv)}
  zfunc <- function(t){substitute(betaMatrix[3], betaEnv)}
  f <- function(t) c(xfunc(t),yfunc(t),zfunc(t))

  return(arclength(f, 0, a))

}

#parameter ktVecDeriv=[alpha(t),alpha'(t),alpha''(t)]
#Returns curvature of projected image of alpha on the unit sphere
#at point t
curvatureI <- function(alphaNPrimeVec, t){
  print(alphaNPrimeVec)
  print(alphaNPrimeVec[1,1])
  print(alphaNPrimeVec[1,2])
  print(alphaNPrimeVec[2,1])
  print(alphaNPrimeVec[2,2])
  print(alphaNPrimeVec[3,1])
  print(alphaNPrimeVec[3,2])
  print(alphaNPrimeVec)
  betaEnv <- new.env(hash=TRUE,size=2)
  print("blah")
  print(deparse(alphaNPrimeVec[1,1]))
  assign("X",value<-deparse(alphaNPrimeVec[1,1]),envir=betaEnv)
  assign("Y",value<-deparse(alphaNPrimeVec[1,2]),envir=betaEnv)

  alpha <-c(eval(alphaNPrimeVec[1,1]),eval(alphaNPrimeVec[1,2],-1))
  alphaP <- c(eval(alphaNPrimeVec[2,1]),eval(alphaNPrimeVec[2,2]),0)
  alphaDP <- c(eval(alphaNPrimeVec[3,1]),eval(alphaNPrimeVec[3,2]),0)
  betaMatrix <- betaAlpha()
  print(substitute(deparse(betaMatrix[2,1]), list(X=10)))
  print("beta")

  substitute_q <- function(x, env) {
    call <- substitute(substitute(y, env), list(y = x))
    eval(call)
  }

  print(substitute_q(betaMatrix[2,1], betaEnv))
  arcLengthBet <- arcLengthBeta(betaMatrix[2,], 2*pi, alphaNPrimeVec)
  print("Arc Length Beta")
  print(arcLengthBet)
  #X value corresponding to alpha(t)
  xAlpha= alpha[1]
  #Y value corresponding to alpha(t)
  yAlpha= alpha[2]

  #X value corresponding to alpha(t)
  xpAlpha= alphaP[1]
  #Y value corresponding to alpha(t)
  ypAlpha= alphaP[2]

  normX<-norm(as.matrix(alphaDP[1]),"F")
  normY<-norm(as.matrix(alphaDP[2]),"F")
  #Curvature of planar curve alpha(t)
  kAlpha<-curvaturePlaneCurve(alphaP,alphaDP,t)
  #Tprime x direction
  Tprime = c(-alphaP[2], alphaP[1])
  magTprime <- norm(as.matrix(Tprime),"F")
  TprimeUnit <- c(Tprime / magTprime)
  xyNot = c(TprimeUnit / kAlpha)
  Xo = xyNot[1]+xAlpha
  Yo = xyNot[2]+yAlpha

  #Returns matrix containing the projected osculating circle of alpha
  #at some t

  gammaMatrix <-gammaAlphaF()
  betaAlphaTP <- betaAlpha()
  print("Gamma Matrix")
  print(gammaMatrix)

  print(kAlpha)

  print("XoYo")
  print(alphaP[1])
  print(alphaP[2])
  print(Tprime)
  print(TprimeUnit)
  print(Xo)
  print(Yo)
  print(magTprime)

  print("t")
  print(t)
  print("Arc Length")
  arcLengthA = arcLengthGamma(gammaMatrix, Xo, Yo, kAlpha, t)
  arcLength = arcLengthA$length
  print(arcLength)

  #Environment
  gammaEnv1 <- new.env(hash=TRUE,size=4)
  assign("Xo",value=Xo,envir=gammaEnv1)
  assign("Yo",value=Yo,envir=gammaEnv1)
  assign("kAlpha",value=kAlpha,envir=gammaEnv1)
  assign("u",value=t,envir=gammaEnv1)

  gammaEnv2 <- new.env(hash=TRUE,size=4)
  assign("Xo",value=Xo,envir=gammaEnv2)
  assign("Yo",value=Yo,envir=gammaEnv2)
  assign("kAlpha",value=kAlpha,envir=gammaEnv2)
  assign("u",value=t+.01,envir=gammaEnv2)

  gammaEnv3 <- new.env(hash=TRUE,size=4)
  assign("Xo",value=Xo,envir=gammaEnv3)
  assign("Yo",value=Yo,envir=gammaEnv3)
  assign("kAlpha",value=kAlpha,envir=gammaEnv3)
  assign("u",value=t+.02,envir=gammaEnv3)

  #Environment
  betaEnv <- new.env(hash=TRUE,size=4)
  assign("X",value=xAlpha,envir=betaEnv)
  assign("Y",value=yAlpha,envir=betaEnv)
  assign("Xp",value=xpAlpha,envir=betaEnv)
  assign("Yp",value=ypAlpha,envir=betaEnv)

  #Projection point P on Alpha
  Pprime<- c(eval(gammaMatrix[1,1],gammaEnv1),eval(gammaMatrix[1,2],gammaEnv1),eval(gammaMatrix[1,3],gammaEnv1))
  #Arbitrary point on Gamma curve
  Aprime<- c(eval(gammaMatrix[1,1],gammaEnv2),eval(gammaMatrix[1,2],gammaEnv2),eval(gammaMatrix[1,3],gammaEnv2))
  #Arbitrary point on Gamma curve
  Bprime<- c(eval(gammaMatrix[1,1],gammaEnv3),eval(gammaMatrix[1,2],gammaEnv3),eval(gammaMatrix[1,3],gammaEnv3))

  betaPrimeN <-c(eval(betaAlphaTP[1,1],betaEnv),eval(betaAlphaTP[1,2],betaEnv),eval(betaAlphaTP[1,3],betaEnv))
  GammaPrimeA <-c(eval(gammaMatrix[2,1],gammaEnv2),eval(gammaMatrix[2,2],gammaEnv2),eval(gammaMatrix[2,3],gammaEnv2))
  GammaPrimeB <-c(eval(gammaMatrix[2,1],gammaEnv3),eval(gammaMatrix[2,2],gammaEnv1),eval(gammaMatrix[2,3],gammaEnv3))

  gammaPAlphaA <- c(GammaPrimeA * alphaP)
  gammaPAlphaB <- c(GammaPrimeB * alphaP)

  print(betaPrimeN)

  betaPrimeAlpha <- c(betaPrimeN * alphaP)

  ##P'-A'
  v1 <-c(Aprime-Pprime)
  ##P'-B'
  v2 <-c(Bprime-Pprime)

  v1Prime <-c(betaPrimeAlpha - gammaPAlphaA)
  v2Prime <- c(betaPrimeAlpha - gammaPAlphaB)

  normVec <- xprod(v1, v2)
  magNorm <- norm(as.matrix(normVec),"F")

  v1PCrossv2 <- xprod(v1Prime,v2)
  v2PCrossv1 <- xprod(v2Prime,v1)

  Nprime <- c(v1PCrossv2 + v2PCrossv1)

  pPrimeDn <- c(-Pprime * Nprime)
  #-P'*N'
  pPrimedotDn <- sum(pPrimeDn)

  nbetaPrime <- c(normVec * betaPrimeAlpha)
  #N*-P''
  ndotbetaPrime <- sum(nbetaPrime)
  #N*-P''+ -P'*N'
  const1 <- -pPrimedotDn + ndotbetaPrime
  #mag(N)*(N*-P''+ -P'*N')
  magNdotConst<- magNorm * const1
  #mag(N)*(N*-P''+ -P'*N')/mag(N)^2
  finalCons <- magNdotConst / (magNorm^2)

  #-P'*N/(magNorm)= p == signed distance from center of sphere to c
  p4 <- c(-Pprime*normVec)
  p4dotn <- sum(p4)
  p <- p4dotn / magNorm

  #sqrt(R^2-p^2)
  p7 <- p^2
  r1 = 1 - p7

  #r== 1/k(BetaAlpha(t))

  #Curvature of Image of Alpha at t
  kIAlpha= (2*pi)/arcLength
  r = 1/kIAlpha

  cI <- c(p * normVec)
  c <- c(cI/ magNorm)

  N <- c(c-Pprime)

  nNorm <- norm(as.matrix(N),"F")
  #.5/(sqrt(1-p^2))
  Rprimecons1 <- .5 / sqrt(1-p7)
  rPrime <- Rprimecons1 *(-2*p*(finalCons))

  #1-r(t)
  torsionI1 = 1-r
  torsionI2 =torsionI1/(rPrime^2)
  torsion <- -1*(1 / sqrt(torsionI2))

  print("R")
  print(r)

  uN <- c(N / nNorm)
  B<- normVec / magNorm

  Tv <- xprod(uN,B)
  uT <- Tv
  print("BTN")
  print(B)
  print(uT)
  print(uN)

  Tv<- Tv*-kIAlpha
  Ntp <- c(Nprime-Tv)

  return(list("curvature"=kIAlpha,"normVec"=normVec,"center"= c,"torsion"=torsion))
}

# curvatureI <- function(alphaNPrimeVec, t){
#   print(alphaNPrimeVec)
#   print(alphaNPrimeVec[1,1])
#   print(alphaNPrimeVec[1,2])
#   print(alphaNPrimeVec[2,1])
#   print(alphaNPrimeVec[2,2])
#   print(alphaNPrimeVec[3,1])
#   print(alphaNPrimeVec[3,2])
#   print(alphaNPrimeVec)
#   alpha <-c(eval(alphaNPrimeVec[1,1]),eval(alphaNPrimeVec[1,2],-1))
#   alphaP <- c(eval(alphaNPrimeVec[2,1]),eval(alphaNPrimeVec[2,2]),0)
#   alphaDP <- c(eval(alphaNPrimeVec[3,1]),eval(alphaNPrimeVec[3,2]),0)
#
#   #X value corresponding to alpha(t)
#   xAlpha= alpha[1]
#   #Y value corresponding to alpha(t)
#   yAlpha= alpha[2]
#
#   #X value corresponding to alpha(t)
#   xpAlpha= alphaP[1]
#   #Y value corresponding to alpha(t)
#   ypAlpha= alphaP[2]
#   normX<-norm(as.matrix(alphaDP[1]),"F")
#   normY<-norm(as.matrix(alphaDP[2]),"F")
#   #Tprime x direction
#   Tprimex=alphaDP[1]
#   #Tprime y direction
#   Tprimey=alphaDP[2]/normY
#
#   print(Tprimex)
#   print(Tprimey)
#   #Returns matrix containing the projected osculating circle of alpha
#   #at some t
#
#
#   gammaMatrix <-gammaAlphaF()
#   betaAlphaTP <- betaAlpha()
#
#   print(gammaMatrix)
#
#   #Curvature of planar curve alpha(t)
#   kAlpha<-curvaturePlaneCurve(alphaP,alphaDP,t)
#   print(kAlpha)
#   #(Xo,Yo)= center of osculating circle of alpha(t) at t
#   Xo<-xAlpha+(Tprimex/kAlpha)
#   Yo<-yAlpha+(Tprimey/kAlpha)
#   print(Xo)
#   print(Yo)
#
#   arcLengthGamma <- function(gammaMatrix){
#     Xo <- Xo
#     Yo <- Yo
#     kAlpha <- kAlpha
#     xfunc <- function(u){eval(gammaMatrix[1,1])}
#     yfunc <- function(u){eval(gammaMatrix[1,2])}
#     zfunc <- function(u){eval(gammaMatrix[1,3])}
#     f <- function(u) c(xfunc(u),yfunc(u),zfunc(u))
#
#     return(arclength(f, t, (t)+2*pi))
#
#
#   }
#   print("Arc Length")
#   arcLengthA = arcLengthGamma(gammaMatrix)
#   arcLength = arcLengthA$length
#
#   #Environment
#   gammaEnv1 <- new.env(hash=TRUE,size=4)
#   assign("Xo",value=Xo,envir=gammaEnv1)
#   assign("Yo",value=Yo,envir=gammaEnv1)
#   assign("kAlpha",value=kAlpha,envir=gammaEnv1)
#   assign("u",value=t,envir=gammaEnv1)
#
#   gammaEnv2 <- new.env(hash=TRUE,size=4)
#   assign("Xo",value=Xo,envir=gammaEnv2)
#   assign("Yo",value=Yo,envir=gammaEnv2)
#   assign("kAlpha",value=kAlpha,envir=gammaEnv2)
#   assign("u",value=t+.01,envir=gammaEnv2)
#
#   gammaEnv3 <- new.env(hash=TRUE,size=4)
#   assign("Xo",value=Xo,envir=gammaEnv3)
#   assign("Yo",value=Yo,envir=gammaEnv3)
#   assign("kAlpha",value=kAlpha,envir=gammaEnv3)
#   assign("u",value=t+.02,envir=gammaEnv3)
#
#   #Environment
#   betaEnv <- new.env(hash=TRUE,size=4)
#   assign("X",value=xAlpha,envir=betaEnv)
#   assign("Y",value=yAlpha,envir=betaEnv)
#   assign("Xp",value=xpAlpha,envir=betaEnv)
#   assign("Yp",value=ypAlpha,envir=betaEnv)
#
#
#   Pprime<- c(eval(gammaMatrix[1,1],gammaEnv1),eval(gammaMatrix[1,2],gammaEnv1),eval(gammaMatrix[1,3],gammaEnv1))
#   Aprime<- c(eval(gammaMatrix[1,1],gammaEnv2),eval(gammaMatrix[1,2],gammaEnv2),eval(gammaMatrix[1,3],gammaEnv2))
#   Bprime<- c(eval(gammaMatrix[1,1],gammaEnv3),eval(gammaMatrix[1,2],gammaEnv3),eval(gammaMatrix[1,3],gammaEnv3))
#
#
#   betaPrimeN <-c(eval(betaAlphaTP[1,1],betaEnv),eval(betaAlphaTP[1,2],betaEnv),eval(betaAlphaTP[1,3],betaEnv))
#   GammaPrimeA <-c(eval(gammaMatrix[2,1],gammaEnv2),eval(gammaMatrix[2,2],gammaEnv2),eval(gammaMatrix[2,3],gammaEnv2))
#   GammaPrimeB <-c(eval(gammaMatrix[2,1],gammaEnv3),eval(gammaMatrix[2,2],gammaEnv1),eval(gammaMatrix[2,3],gammaEnv3))
#
#
#
#   gammaPAlphaA <- c(GammaPrimeA * alphaP)
#   gammaPAlphaB <- c(GammaPrimeB * alphaP)
#
#
#
#   print(betaPrimeN)
#   betaPrimeAlpha <- c(betaPrimeN * alphaP)
#
#   ##n
#
#
#
#   ##P'-A'
#   v1 <-c(Aprime-Pprime)
#   ##P'-B'
#   v2 <-c(Bprime-Pprime)
#
#   v1Prime <-c(betaPrimeAlpha - gammaPAlphaA)
#   v2Prime <- c(betaPrimeAlpha - gammaPAlphaB)
#
#   normVec <- xprod(v1,v2)
#
#   magNorm <- norm(as.matrix(normVec),"F")
#
#   v1PCrossv2 <- xprod(v1Prime,v2)
#   v2PCrossv1 <- xprod(v2Prime,v1)
#
#   Nprime <- c(v1PCrossv2 + v2PCrossv1)
#
#   pPrimeDn <- c(-Pprime * Nprime)
#   pPrimedotDn <- sum(pPrimeDn)
#
#   nbetaPrime <- c(normVec * betaPrimeAlpha)
#   ndotbetaPrime <- sum(nbetaPrime)
#
#   const1 <- -pPrimedotDn + ndotbetaPrime
#   magNdotConst<- magNorm * const1
#   finalCons <- magNdotConst / (magNorm^2)
#
#
#   p4 <- c(-Pprime*normVec)
#   p4dotn <- sum(p4)
#   p <- p4dotn / magNorm
#
#   cI <- c(p * normVec)
#   c <- c(cI/ magNorm)
#
#   p7 <- p^2
#
#   Rprimecons1 <- .5 * sqrt(1-p7)
#   Rprimecons2 <- Rprimecons1 *(-2*p*(finalCons))
#
#   rPrime = Rprimecons1*Rprimecons2
#   #Curvature of Image of Alpha at t
#   kIAlpha= (2*pi)/arcLength
#   r = 1/kIAlpha
#   print("R")
#   print(r)
#   print(kIAlpha)
#   N <- c(-Pprime-c)
#   uN <- c(N / r)
#   B<- normVec / magNorm
#
#   Tv <- xprod(uN,B)
#   uT <- Tv
#   print("BTN")
#   print(B)
#   print(uT)
#   print(uN)
#
#
#
#
#   Tv<- Tv*-kIAlpha
#   Ntp <- c(Nprime-Tv)
#
#   torsionI1 = 1-r
#   torsionI2 =torsionI1/(rPrime^2)
#   torsion <- -1*(1 / sqrt(torsionI2))
#
#   return(list("curvature"=kIAlpha,"normVec"=normVec,"center"= c,"torsion"=torsion))
# }

funins <- function(f, expr = expression(x<-2*x), after=1) {
  body(f)<-as.call(append(as.list(body(f)), expr, after=after))
  f
}

##Beta mapping represents the stereographic projection of alpha onto the
##Unit sphere
betaAlpha <- function(){
  betaAlpha <- c(expression((4*X)/(X^2+Y^2+4)),
                 expression((4*Y)/(X^2+Y^2+4)),
                 expression((X^2+Y^2-4)/(X^2+Y^2+4)))

  betaAlphaP<- c(expression((((X^2+Y^2+4)*(Xp))-((4*X)*((2*X)*Xp+(2*Y)*Yp)))/(X^2+Y^2+4)^2),
                 expression((((X^2+Y^2+4)*(Yp))-((4*Y)*((2*X)*Xp+(2*Y)*Yp)))/(X^2+Y^2+4)^2),
                 expression(((X^2+Y^2+4)*((2*X)*Xp +(2*Y)*Yp)-((X^2+Y^2+4)*((2*X)*Xp +(2*Y)*Yp)))/(X^2+Y^2+4)^2))

  betaAlphMat = matrix(
    c(betaAlphaP,betaAlpha),
    nrow=2,
    ncol=3,
    byrow = TRUE
  )

  print("sup")
  print(betaAlphMat)
  return(betaAlphMat)

}

##Parametric function defining osculating circle of a curve alpha(t)
##at some t. ==> radius of osculatingAlpha= (1/kAlpha)
##further we know [x_0,y_0]=[x(t),y(t)]+[T'_alpha(t)/kAlpha)]
##0<=u<=2pi with will be the parameter of the osculating circle
##uRange=data.frame(u=seq(0,2*pi,.1))

#(x,y) represent values of osculating circle of some curve alphaN(t) at
#some value t. gammaAlpha(t) gives the corresponding (x,y,z)
#values of the osculating circle of the image of alphaN(t) or alphaNI(t)
#at the same value t. Note x,y are depent on alphaN(t)
#that is
# if alphaN(t) = x(t),y(t)==> x=x(t)+((T'alpha(t)_x)/k(t))+(1/k(t))cos(u))
## essentially x and y are functions of 0<=u<=2pi at each t on the curve ##alphaN

##For simplicity sake know that ##(x,y)=gamma(u,v=1)=[(1)*(x_0+rcos(u)),(1)*(y_0+rsin(u)),1-2*(1)]
##This mapping creates a surface of a cone. The projection mapping
##gammAlpha gives us the intersection of the cone and the unit sphere.
##this intersection happens at v=4/(x)^2+(y)^2+4

gammaAlphaF <- function(){

  #Vector of expressions corresponding to the gamma mapping applied to alpha
  gammaAlpha <- c(expression((4*(Xo+(1/kAlpha)*cos(u)))/((Xo+(1/kAlpha)*cos(u))^2+(Yo+(1/kAlpha)*sin(u))^2+4)),
                expression((4*(Yo+(1/kAlpha)*sin(u)))/((Xo+(1/kAlpha)*cos(u))^2+(Yo+(1/kAlpha)*sin(u))^2+4)),
                expression(1+(-8/((Xo+(1/kAlpha)*cos(u))^2+(Yo+(1/kAlpha)*sin(u))^2+4))))

  gammaAlphaP <- c(DD(gammaAlpha[1], 'u',1),DD(gammaAlpha[2], 'u',1),DD(gammaAlpha[3], 'u',1))

  #gammaMatrix of expressions by row
  gammaMatrix = matrix(
    c(gammaAlpha,gammaAlphaP),
    nrow=2,
    ncol=3,
    byrow=TRUE,
    )

  dimnames(gammaMatrix)=list(c("GammaAlpha: ","GammaAlphaDP"),c("X_gamma","Y_gamma","Z_gamma"))

  return(gammaMatrix)

}

#parameter ktVecDeriv=[alpha(t),alpha'(t),alpha''(t)]
#returns ||alpha'(t) x alpha''(t) ||/ ||(alpha'(t))^3||==K_alpha(t)
curvaturePlaneCurve <- function(alphaP,alphaDP,t){
  normCross <-xprod(alphaP,alphaDP)
  normAD <-norm(as.matrix(normCross),"F")
  normAP <-norm(as.matrix(alphaP),"F")
  kAlpha = normAD /(normAP^3)
  print(kAlpha)
  return(kAlpha)

}

# torsionI <- function(alphaNPrimeVec,t,normVec){
#
#   alpha <-c(eval(alphaNPrimeVec[1,1]),eval(alphaNPrimeVec[1,2],-1))
#   alphaP <- c(eval(alphaNPrimeVec[2,1]),eval(alphaNPrimeVec[2,2]),0)
#   alphaDP <- c(eval(alphaNPrimeVec[3,1]),eval(alphaNPrimeVec[3,2]),0)
#   betaAlphMat = betaAlpha(alphaNPrimeVec,t)
#
#   print(betaAlphaTP)
#
#   print(normVec)
#   print("norm")
#   num <-c(normVec)
#
#   dotNum <- sum(num)
#   denom <- norm(as.matrix(normVec),"F")
#   torsionI <- dotNum/(denom^2)
#   print(denom^2)
#   print(dotNum)
#
#
#   return(torsionI)
#
# }

##DD for calculation of high order derivatives
DD <- function(expr, name, order=1) {
  if(order < 1) stop("'order' must be >= 1")
  if(order == 1)
    return(D(expr, name))
  else DD(D(expr, name), name, order - 1)}

xprod <- function(...) {
  args <- list(...)

  # Check for valid arguments

  if (length(args) == 0) {
    stop("No data supplied")
  }
  len <- unique(sapply(args, FUN=length))
  if (length(len) > 1) {
    stop("All vectors must be the same length")
  }
  if (len != length(args) + 1) {
    stop("Must supply N-1 vectors of length N")
  }

  # Compute generalized cross product by taking the determinant of sub-matricies

  m <- do.call(rbind, args)
  sapply(seq(len),
         FUN=function(i) {
           det(m[,-i,drop=FALSE]) * (-1)^(i+1)
         })
}


huen <- function(steps,final)
{
	# RungeKutta Approximation and Heun's Method
	r     <- -5;
	a     <- 1/2;
	b     <- 1/2;
	alpha <- 1;
	beta  <- 1;

	#final <- 25;
	#steps <- 1000;
	dt    <- final/steps;

	n    <- 0;
	y    <- 1;
	#i    <- double(steps);
	#j    <- double(steps);

	while(n < steps) {
	    k1     <- dt*r*y;
	    k2     <- dt*r*(y + beta*k1);
	    y      <- y + a*k1 + b*k2;
	    #i[n+1] <- dt*(n+1);
	    #j[n+1] <- abs(y - exp(r*dt*(n + 1)));
	    n      <- n + 1;
	}

	#plot(
    #  i,
    #  j,
    #  type = 'l',
    #  xlim = c(0,25),
    #  ylim = c(0,5),
    #  # log = 'xy',
    #  ylab = 'Error',
    #  xlab = 'Time',
    #  main = 'r = -5 and dt = ')

	return(y)
}

x <- data.frame(,i,j);

file.create("/Users/kylemcgrath/Documents/SDE-REU-2015/SUNY-SDE-2015/REU15/Runge-Kutta/R/error-dat.csv");
data <- file("/Users/kylemcgrath/Documents/SDE-REU-2015/SUNY-SDE-2015/REU15/Runge-Kutta/R/error-dat.csv");
write.table(c("dt", "step", "error"), file = data, row.names=FALSE, col.names=FALSE);
write.table(x, file = data, row.names=FALSE, col.names=FALSE);


#keep track of all movements
mov<-c()

#VACCINATION STRATEGY
strategy<-c('mobility','mortality')

#INITIAL AMOUNT OF PEOPLE IN EACH SUBGROUP

#age group 0-20
I_1<- 26
S_1<- 44403 - I_1
#age group 21-40
I_2<- 179
S_2<- 40992 - I_2
#age group 41-60
I_3<- 148
S_3<- 29839 - I_3
#age group 60+
I_4<- 56
S_4<- 15029 - I_4

#Put them in vectors for easier access
S<-c(S_1, S_2, S_3, S_4)
I<-c(I_1, I_2, I_3, I_4)

#total dead
D<- 0
#total recuperated
R<- 4018

#average daily vaccination capacity (consider efficacy)
V<- 10

#SUBGROUP parameters

#death rate
k<-c(0.01,0.02,0.09,0.13)
#recuperation rate
b<-(1-k)
#mobility
a<-c(2.25,3,2.75,2)

#vaccines per group per day, set to 0 initially
lambda<-c(0,0,0,0)

#population in a vector
pop<-as.vector(c(rbind(S,I),D,R))
names(pop)<-c('S1','I1','S2','I2','S3','I3','S4','I4','D','R')

#this way we can simply add the vector of the event to our pop counter
poss<-data.frame(inf1=c(-1,1,rep(0,8)),
                 inf2=c(0,0,-1,1,rep(0,6)),
                 inf3=c(rep(0,4),-1,1,rep(0,4)),
                 inf4=c(rep(0,6),-1,1,0,0),
                 die1=c(0,-1,rep(0,6),1,0),
                 die2=c(rep(0,3),-1,rep(0,4),1,0),
                 die3=c(rep(0,5),-1,0,0,1,0),
                 die4=c(rep(0,7),-1,1,0),
                 rec1=c(0,-1,rep(0,7),1),
                 rec2=c(rep(0,3),-1,rep(0,5),1),
                 rec3=c(rep(0,5),-1,rep(0,3),1),
                 rec4=c(rep(0,7),-1,0,1),
                 vac1=c(-1,rep(0,8),1),
                 vac2=c(0,0,-1,rep(0,6),1),
                 vac3=c(rep(0,4),-1,rep(0,4),1),
                 vac4=c(rep(0,6),-1,0,0,1))

#put subgroup parameters into a data frame too, for easier handling
params<-data.frame(a, b, k, lambda)

#we will call this function every time we iterate inside the simulation
get_times<-function(pop,params){
  times<-c(rep(0,16))
  #population
  N<-sum(pop)
  #all infected
  infected<-sum(pop[c(2,4,6,8)])
  #iterate over each group
  for (i in 1:4){
    #infection
    times[i]<-rexp(n=1,rate=(0.06)*params$a[i]*pop[(2*i-1)]*infected/N)
    #death
    times[i+4]<-rexp(n=1,rate=params$k[i]*pop[(2*i)]*(1/17))
    #vaccination
    times[i+12]<-rexp(n=1,rate=params$lambda[i]*pop[2*i-1]/pop[2*i-1])
    #recuperation
    times[i+8]<-rexp(n=1,rate=params$b[i]*pop[(2*i)]*(1/14))
  }
  return(times)
}

get_lambda <- function(V, N, P){
  #distribute and normalize
  lambda<-c(0,0,0,0)
  lambda [ which(P*N==max(P*N))] <- V
  return(lambda)
}

set_lambda<-function(S, params, strategy, V){
  #id parameter of interest from strategy
  if (strategy=='mobility'){
    interest<-params$a
  }else if(strategy=='mortality'){
    interest<-params$k
  }
  #get lambda values according to priority parameter
  lambda<-get_lambda(P=interest,V=V,N=S)
  #return new lambda vector
  return(lambda)
}

#MAIN SIMULATION ITERATORS
#We will fluctuate between strategies with different probability values (limit)
#Each probability combination will be run e simulations
#each simulation will run until herd immunity is achieved or no active cases remain
#At the end of each simulation, a report will be printed

#report titles
print(c('mobility','pandemic_time','death_toll','vaccines','total_cases'))

#number of iterations on strategy probability
limit<-5
#number of repetitions on with each strategy parameters
reps<-10
#amount of rec people needed for pandemic to end
herd_immunity<-sum(pop[c(1:8,10)])*0.7

#we will run the simulations with a range of probabilities
for (j in 0:limit){
  #new probability parameters for iteration
  strategyR<-c(j/limit,1-j/limit)

  #repetitions per value
  for (e in 1:reps){

    #time accumulator
    t<-0

    #run simulation
    while( sum(pop[c(2,4,6,8,10)]) < herd_immunity ){

      #select strategy according to probabilities
      strat<-sample(strategy, size=1, prob=strategyR)
      #update lambda values according to strategy
      params$lambda<-set_lambda(S=pop[c(1,3,5,7)],params=params,strategy=strat, V=V)
      #obtain times
      times<-get_times(pop,params)
      #identify next event
      chosen<-which(times==min(times[which(times>0)]))[1]
      #execute next event
      pop<-pop+(poss[,chosen])
      #accumulate time
      t<-t+times[chosen]
      #update amount of susceptible people needed for pandemic to end
      herd_immunity<-sum(pop[c(1:8,10)])*0.7
      #register event
      mov<-append(mov,chosen)

    }#end of simulation

    #save important output info for analysis
    tot_vacc<-sum(mov>=13)
    tot_cases<-sum(mov<=4)
    output<-c(strategyR[1],t,pop[[9]],tot_vacc,tot_cases)

    #print and save output
    print(output)

    #reset population values for new simulation repetitions
    pop<-as.vector(c(rbind(S,I),D,R))
    mov<-c()

  }#end of value repetitions

}#end of whole enchilada

print('DONE')


## this is an ugly script -- not meant to be "source'd"
gDat <- read.delim("data/gapminderDataFiveYear.txt")
str(gDat)

## function that returns estimated intercept and slope from linear regression of
## lifeExp on year
## anticipated input: Gapminder data for one country
## see block03 script for development of this
jFun <- function(z) {
  jCoef <- coef(lm(lifeExp ~ I(year - yearMin), z))
  names(jCoef) <- c("intercept", "slope")
  return(jCoef)
}

## get intercept and slope for each country
library(plyr)
yearMin <- min(gDat$year)
gCoef <- ddply(gDat, .(country, continent), jFun)
str(gCoef)
tail(gCoef)

## reordering the continent factor rationally (vs. alphabetically)
library(lattice)
bwplot(slope ~ continent, gCoef)
## alphabetical order is rarely justified

gCoef$continent <- reorder(gCoef$continent, gCoef$slope)
str(gCoef)
bwplot(slope ~ continent, gCoef)
levels(gCoef$continent)
## much more logical
## tables and plots sorted this way will give more insight!

## drop Oceania ... too few countries
gCoef <- subset(gCoef, continent != "Oceania")
levels(gCoef$continent)
## Oceania is still there as factor level?!?
subset(gCoef, continent == "Oceania")
## but no observation have continent Oceania!
gCoef <- droplevels(gCoef)
## gets rid of unused factor levels
levels(gCoef$continent)

## how to store data.frames for posterity

## plain text is always good!
## we slowly built up the arguments below
## you may not want all of these?
write.table(gCoef, "results/gCoef.txt", quote = FALSE, row.names = FALSE, sep = "\t")

## bad news about plain text storage:
## upon re-import via read.table, factors levels revert to alphabetical order
levels(gCoef$continent) # rational level order
rm(gCoef)
gCoef <- read.delim("results/gCoef.txt")
levels(gCoef$continent) # back to alphabetical!!

## let's re-reorder the continent factor levels
gCoef$continent <- reorder(gCoef$continent, gCoef$slope)
bwplot(slope ~ continent, gCoef)
levels(gCoef$continent)

## how to store a data.frame in a plain text file WITH factor level order being
## preserved?
dput(gCoef, "results/gCoef_DPUT.txt")
rm(gCoef)
gCoef <- dget("results/gCoef_DPUT.txt")
levels(gCoef$continent)
## success!
## but the file written by dput() is not easy to browse or open
## in Excel or anywhere outside of R, for that matter

## if we abandon plain text, there is an R-specific binary format
saveRDS(gCoef, "results/gCoef.rds")
rm(gCoef)
gCoef <- readRDS("results/gCoef.rds")
levels(gCoef$continent)
## success!

## bottom line:
## I usually save as plain text AND via (dput|saveRDS|save)
## plain text is for long-term, language-agnostic storage
## *.rds is for my short-/medium-term reuse with R


##
## Calculate Jaccard similarities between the advice, help, sharing and gift networks
##
source("init if necessary.r")

library(igraph)
library(proxy)

flog.info("Started social network analysis - similarities")

# make adjacency matrices from graphs of each type of net-map
adj.advice  = get.adjacency( graph.data.frame( net.maps.advice,  vertices=herders, directed=T), sparse=F )
adj.help    = get.adjacency( graph.data.frame( net.maps.help,    vertices=herders, directed=T), sparse=F )
adj.sharing = get.adjacency( graph.data.frame( net.maps.sharing, vertices=herders, directed=T), sparse=F )
adj.gifts   = get.adjacency( graph.data.frame( gifts,            vertices=herders, directed=T), sparse=F )

# shorthand function to calculate Jaccard similarity between adjacency matrices a and b
jaccard = function(a, b) proxy::simil(list(as.vector(a), as.vector(b)), method="jaccard")

jacs = matrix(NA, nrow=4, ncol=4, dimnames=list(c("Advice", "Help", "Sharing", "Gifts"), c("Advice", "Help", "Sharing", "Gifts")))

# calculate similarities
jacs["Advice", "Help"]    = jaccard(adj.advice, adj.help)
jacs["Advice", "Sharing"] = jaccard(adj.advice, adj.sharing)
jacs["Advice", "Gifts"]   = jaccard(adj.advice, adj.gifts)

jacs["Help", "Sharing"] = jaccard(adj.help, adj.sharing)
jacs["Help", "Gifts"]   = jaccard(adj.help, adj.gifts)

jacs["Sharing", "Gifts"] = jaccard(adj.sharing, adj.gifts)

# save table
write.csv(round(jacs, 3), file.path(results.dir, "Network similarities.csv"), row.names=T)

flog.info("Finished society network analysis - similarities")


# Example : 1   Chapter : 5.2     Page No: 255
# Determinant of matrices by multiplying pivots
A<-matrix(c(0,0,4,0,2,5,1,3,6),ncol=3)
P<-matrix(c(0,0,1,0,1,0,1,0,0),ncol=3)
PA<-P%*%A
print(PA)
detA<--1*PA[1,1]*PA[2,2]*PA[3,3]
print(detA)
det(A)
print("detA is the determinant of the given matrix")