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


find_N_least_corelated_features <- function(data, N) {
    corelation <- abs(cor(data))
    ind <- which( upper.tri(corelation,diag=F) , arr.ind = TRUE )
    corelation_vector <- data.frame(
            col = dimnames(corelation)[[2]][ind[,2]] ,
            row = dimnames(corelation)[[1]][ind[,1]] ,
            val = corelation[ ind ],
            stringsAsFactors=FALSE
    )
    corelation_sorted <- corelation_vector[ order(corelation_vector["val"]), ]
    return(head(corelation_sorted, n=N))
}

cluster <- function(data, centers) {
  scaled_data <- scale(data)
  least_corelated_features <- find_N_least_corelated_features(scaled_data, centers)
  features <- unique(c(least_corelated_features$col, least_corelated_features$row))
  least_corelated_data <- subset(scaled_data, select = features)
  pca <- prcomp(least_corelated_data)
  return(head(kmeans(pca$x, centers)))
}

cluster(mtcars, 3)


require(mvtnorm)

source('fmm_multivariate_generative.r')
source('fmm_utils.r')

# NOTE (jtobin): must load dplyr after plyr
require(dplyr)

conditional_mixing_model = function(y, k, z, a) {
  labelled      = cbind(y, L1 = z)
  counts        = summarise(group_by(labelled, L1), count = n())
  concentration = sapply(seq(k),
    function(cluster) {
      idx = which(counts$L1 == cluster)
      if (length(idx) != 0) {
        counts$count[idx] + a / k
      } else {
        a / k
      }
    })
  drop(rdirichlet(1, concentration))
}

conditional_label_model = function(y, p, m, s) {
  scorer = function(mix, mu, prec) {
    exp(log(mix) + dmvnorm(y, mu, solve(prec), log = T))
  }

  unweighted = mapply(scorer, p, m, s)
  weights    = 1 / apply(unweighted, MARGIN = 1, sum)
  probs      = weights * unweighted

  clusters = apply(
      probs
    , MARGIN = 1
    , function(row) { sample(seq_along(m), size = 1, prob = row) }
    )
  unname(clusters)
}

conditional_cluster_parameters_model = function(y, k, z, l, r, b, w) {
  labelled  = data.frame(y, L1 = z)
  clustered = lapply(seq(k),
    function(j) {
      vals = labelled[which(labelled$L1 == j), !(names(labelled) %in% 'L1')]
      as.matrix(vals)
    })

  ybar     = lapply(clustered, colMeans)
  n        = lapply(clustered, nrow)
  pl       = function(lj, nj, ybarj) {
    if (nj == 0) {
      lj
    } else {
      (lj + nj * ybarj) / (1 + nj)
    }
  }
  ln       = mapply(pl, list(l), n, ybar, SIMPLIFY = F)
  centered = mapply('-', clustered, ybar, SIMPLIFY = F)
  ss       = lapply(centered, function(x) t(x) %*% x)

  # NOTE (jtobin): the extra 'solve' calls here helped; came from
  # http://thaines.com/content/misc/gaussian_conjugate_prior_cheat_sheet.pdf
  # murphy's famous reference at
  # http://www.cs.ubc.ca/~murphyk/Papers/bayesGauss.pdf is incorrect.
  pt = function(wj, ssj, nj, ybarj) {
    if (nj == 0) { wj } else {
      solve(solve(wj) + ssj + nj / (1 + nj) * ((l - ybarj) %*% t(l - ybarj)))
    }
  }

  tn   = mapply(pt, list(w), ss, n, ybar, SIMPLIFY = F)
  bn   = lapply(n, function(x) x + b)
  prec = mapply(function(i, j) drop(rWishart(1, i, j)), bn, tn, SIMPLIFY = F)
  cov  = mapply(function(i, j) solve((i + 1) * j), n, tn, SIMPLIFY = F)
  loc  = mapply(rmvnorm, 1, ln, cov, SIMPLIFY = F)
  if (any(is.nan(unlist(loc)))) { browser() }
  list(m = loc, s = prec)
}

inverse_model = function(n, k, y, a, l, r, b, w) {
  gibbs = function(p0, m0, s0) {
    z  = conditional_label_model(y, p0, m0, s0)
    p1 = conditional_mixing_model(y, k, z, a)
    ps = conditional_cluster_parameters_model(y, k, z, l, r, b, w)
    m1 = ps$m
    s1 = ps$s
    ll = lmodel(y, p1, m1, s1)

    list(p = p1, m = m1, s = s1, z = z, l = ll)
  }

  params = list(
      p = mixing_model(k, a)
    , m = lapply(
              location_model(k, l, r)
            , function(j) { matrix(j, ncol = length(j)) })
    , s = precision_model(k, b, w)
    )

  acc   = params
  acc$s = list(acc$s)
  for (j in seq(n - 1)) {
      params = gibbs(params$p, params$m, params$s)

      acc$p  = rbind(acc$p, params$p)
      acc$m  = mapply(rbind, acc$m, params$m, SIMPLIFY = F)
      acc$s  = c(acc$s, list(params$s))
      acc$z  = rbind(acc$z, params$z)
      acc$l  = c(acc$l, params$l)
    }
  acc
}


#!/usr/bin/r

## this short example was provided in response to this StackOverflow questions:
## http://stackoverflow.com/questions/6807068/why-is-my-recursive-function-so-slow-in-r
## and illustrates that recursive function calls are a) really expensive in R and b) not
## all expensive in C++ (my machine sees a 700-fold speed increase) and c) the byte
## compiler in R does not help here.

## byte compiler
require(compiler)

## A C++ version compile with cppFunction
fibRcpp <- cppFunction( '
int fibonacci(const int x) {
   if (x == 0) return(0);
   if (x == 1) return(1);
   return (fibonacci(x - 1)) + fibonacci(x - 2);
}
' )

## for comparison, the original (but repaired with 0/1 offsets)
fibR <- function(seq) {
    if (seq == 0) return(0);
    if (seq == 1) return(1);
    return (fibR(seq - 1) + fibR(seq - 2));
}

## also use byte-compiled R function
fibRC <- cmpfun(fibR)

## load rbenchmark to compare
library(rbenchmark)

N <- 35     ## same parameter as original post
res <- benchmark(fibR(N),
                 fibRC(N),
                 fibRcpp(N),
                 columns=c("test", "replications", "elapsed",
                           "relative", "user.self", "sys.self"),
                 order="relative",
                 replications=1)
print(res)  ## show result


AutoData <- read.table(url("https://archive.ics.uci.edu/ml/machine-learning-databases/auto-mpg/auto-mpg.data"), sep = "")
names(AutoData)<- c("mpg","cylinders","displacement","horsepower","weight","acceleration",
                  "year","origin","name")
str(AutoData)

AutoData<-AutoData[!(AutoData$horsepower=="?"),]
AutoData$horsepower<-as.integer(AutoData$horsepower)
str(AutoData)

plot(AutoData$weight, AutoData$mpg, pch=AutoData$origin)

par(mfrow=c(2,2))
plot(AutoData$cylinders, AutoData$mpg, pch=AutoData$origin)
plot(AutoData$displacement, AutoData$mpg, pch=AutoData$origin)
plot(AutoData$horsepower, AutoData$mpg, pch=AutoData$origin)
plot(AutoData$acceleration, AutoData$mpg, pch=AutoData$origin)
dev.off()

library(neuralnet)

mean_data <- apply(AutoData[1:6], 2, mean)
sd_data <- apply(AutoData[1:6], 2, sd)

AutoDataScaled <- as.data.frame(scale(AutoData[,1:6],center =
                                        mean_data, scale = sd_data))
head(AutoDataScaled, n=20)

index = sample(1:nrow(AutoData),round(0.70*nrow(AutoData)))
train_data <- as.data.frame(AutoDataScaled[index,])
test_data <- as.data.frame(AutoDataScaled[-index,])

n = names(AutoDataScaled)
f = as.formula(paste("mpg ~", paste(n[!n %in% "mpg"],
                                    collapse = " + ")))

NNRModel<-neuralnet(f,data=train_data,hidden=3,linear.output=TRUE)
summary(NNRModel)

plot(NNRModel,cex=0.6,cex.axis=0.6,cex.lab=0.6)

NNRModel$result.matrix

PredNetTest <- compute(NNRModel,test_data[,2:6])

MSE.net <- sum((test_data$mpg - PredNetTest$net.result)^2)/nrow(test_data)

LModel <- lm(mpg~., data=train_data)
summary(LModel)

PredLModel <- predict(LModel,test_data)

MSE.lm <- sum((PredLModel - test_data$mpg)^2)/nrow(test_data)

par(mfrow=c(1,2))
plot(test_data$mpg,PredNetTest$net.result,col='black',main="Real vs predicted for neural network")
abline(0,1,lwd=1)
plot(test_data$mpg,PredLModel,col='black',main="Real vs predicted for linear regression")
abline(0,1,lwd=1)


selectionsort.rec <- function(x)
{
   if(length(x) > 1)
   {
      mini <- which.min(x)
      c(x[mini], selectionsort(x[-mini]))
   } else x
}


#Title: test_PCA
#Auther: Naoto Imamachi
#ver: 1.0.0
#Date: 2015-10-05

testid <- seq(1,10,1)
sample1 <- c(86,71,42,62,96,39,50,78,51,89)
sample2 <- c(79,75,43,58,97,33,53,66,44,92)
sample3 <- c(67,78,39,98,61,45,64,52,76,93)
sample4 <- c(68,84,44,95,63,50,72,47,72,91)
sort(sample1)
sort(sample2)
sort(sample3)
sort(sample4)

test_table <- data.frame(TestId = testid, Sample1 = sample1, Sample2 = sample2, Sample3 = sample3, Sample4 = sample4,row.names=1)
test_table.matrix <- as.matrix(test_table)

pairs(test_table.matrix, pch=16, col="blue")
R_test <- cor(test_table.matrix)
spec_dec_test <- eigen(R_test)

result_test <- prcomp(t(test_table.matrix), scale=TRUE)
biplot(result_test, var.axes=FALSE, ylabs=NULL)

library(rgl)
plot3d(result_test$x,xlab="PC1",ylab="PC2",zlab="PC3",type="h")
spheres3d(result_test$x, radius=0.2,col=rainbow(length(result_test$x[,1])))
grid3d(side="z", at=list(z=0))
text3d(result_test$x, text=rownames(result_test$x), adj=1.3)

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

test2_table <- read.table("C:/Users/Naoto/Documents/github/NGS_data_analysis_pipeline/PCA_analysis/test_dataset.txt", header=T)
test2_table <- test2_table[,2:13]
colnames(test2_table) <- c(
  'con_A549_empty','con_A549_wt','con_A549_GFP',
  'con_MALATKO671','con_MALATKO752','con_MALATKO772',
  'HS_A549_empty','HS_A549_wt','HS_A549_GFP',
  'HS_MALAT_KO671','HS_MALAT_KO752','HS_MALAT_KO772'
)
test2_table.matrix <- as.matrix(test2_table)
result_test2 <- prcomp(t(test2_table.matrix), scale=TRUE)
biplot(result_test2, var.axes=FALSE, ylabs=NULL)

library(rgl)
plot3d(result_test2$x,xlab="PC1",ylab="PC2",zlab="PC3",type="h")
spheres3d(result_test2$x, radius=7,col=rainbow(length(result_test2$x[,1])))
grid3d(side="z", at=list(z=0))
text3d(result_test2$x, text=rownames(result_test2$x), adj=1.3)


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


# Example : 5   Chapter : 5.2     Page No: 259
# Determinants of matrices
A4<-matrix(c(0,1,0,0,1,0,1,0,0,1,0,1,0,0,1,0),ncol=4)
P4<-matrix(c(0,1,0,0,1,0,0,0,0,0,0,1,0,0,1,0),ncol=4)
print(det(A4))
print(det(P4))


library(plyr)
library(ggplot2)

# First need to create new variables that capture the number of years
# a player has played, and for each year, how far through their career
# they are.

# This is straightforward using the techniques we just learned
b2 <- ddply(baseball, "id", transform,
  cyear = year - min(year) + 1)
b2 <- ddply(b2, "id", transform,
  career = (cyear - 1) / max(cyear))

head(b2)

# Now what sort of model should we use?
bruth <- subset(b2, id == "ruthba01")
qplot(career, g, data = bruth, geom = "line")
qplot(career, g, data = b2, geom="boxplot", group = round_any(career, 0.05))

# Could we model that as two straight lines?
bruth$p <- (bruth$career - 0.5) * 100
mod <- lm(g ~ p + p:I(p > 0), data = bruth)
bruth$ghat <- predict(mod)
qplot(career, g, data = bruth, geom = "line") +
  geom_line(aes(y = ghat), colour = "red")

# It doesn't look great, but it's a start
# Let's fit that model to every player
b2$p <- (b2$career - 0.5) * 100

models <- dlply(b2, "id", lm, formula = g ~ p + p:I(p > 0))
# Or a bit more explicitly
models <- dlply(b2, "id", function(df) lm(g ~ p + p:I(p > 0), data = df))

length(models)
onem <- models[[1]]
onem
summary(onem)

coefs <- coef(onem)
names(coefs) <- c("mid", "inc", "dec")
rsq <- summary(onem)$r.squared

get_coefs <- function(model) {
  coefs <- coef(model)
  names(coefs) <- c("mid", "inc", "dec")
  c(coefs, rsq = summary(model)$r.squared)
}

coefs <- ldply(models, get_coefs)

qplot(rsq, data = coefs, geom = "histogram", binwidth = 0.02)
qplot(mid, data = coefs, geom = "histogram", binwidth = 5)
qplot(inc, data = coefs, geom = "histogram", binwidth = 0.2)
qplot(dec, data = coefs, geom = "histogram", binwidth = 0.2)

qplot(rsq, inc, data=coefs)
qplot(dec, inc, data=coefs, colour=rsq)


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


set.seed(419124096)

# params have been chosen to fill a landscape going from -5 to 5 if 300 spp are used
# for covariance, best to use large params for rho; 100,100 makes for just a bit
# if the rho params are equal, mean correlation will be 0; the larger the numbers the
# smaller the variance
make_niche <- function(center_means = c(0,0), center_sig = 12*diag(2),
	width_shapes = c(4,7), width_rates = c(1.2, 1.2), rho_ab = c(0,0),
	scale_ab = c(15,5))
# for width parameters, first entry in each describes width for env1, second
# for env2
# for rho params, rho ~ 2 * Beta(rho_ab[1], rho_ab[2]) - 1
# for the special case of rho = 0,0, covariance will be zero
{
	require(mvtnorm)
	# vector of two, the niche in each dimension
	cntrs <- rmvnorm(1, center_means, center_sig)
	# niche widths
	widths <- rgamma(2, width_shapes, width_rates)
	# niche axis correlations
	if(all(rho_ab == 0)) {
		rho <- 0
	} else {
		rho <- 2 * rbeta(1, rho_ab[1], rho_ab[2]) - 1
	}
	# how high is the niche; controls abundance and detectability of the species
	scale <- rbeta(1, scale_ab[1], scale_ab[2])

	data.frame(center1 = cntrs[1], center2 = cntrs[2], width1 = widths[1],
		width2=widths[2], rho=rho, scale=scale)
}

simulate_landscape <- function(nsp, xrange=c(-5,5), yrange=c(-5,5), dims=c(50,50), ...)
{
	niches <- do.call(rbind, lapply(1:nsp, function(x) make_niche(...)))
	lscape <- expand.grid(env1=seq(xrange[1], xrange[2], length.out=dims[1]),
		env2=seq(yrange[1], yrange[2], length.out=dims[2]))
	sitenames <- paste0('site', 1:nrow(lscape))
	spnames <- paste0('species', 1:nsp)
	rownames(lscape) <- sitenames
	probs <- apply(niches, 1, function(ni) niche_height(lscape, ni))
	colnames(probs) <- spnames
	site_sp <- matrix(rbinom(length(probs), 1, probs), ncol=ncol(probs),
		dimnames = dimnames(probs))
	res <- list(site_sp = site_sp, niches=niches, landscape = lscape, probs = probs)
	class(res) <- c(class(res), "mbmSim")
	res
}

niche_height <- function(x, niche)
{
	require(mvtnorm)
	# computes the niche height as the multivariate normal density times the scale
	mu <- niche[1:2]
	sig <- matrix(NA, nrow=2, ncol=2)
	sig[1,1] <- niche[3]
	sig[2,2] <- niche[4]
	sig[1,2] <- sig[2,1] <- niche[3]*niche[4]*niche[5]
	sc <- niche[6]
	# scale height to one
	ht <- dmvnorm(x, mu, sig) / dmvnorm(mu, mu, sig)
	sc * ht
}

mbm_sims <- simulate_landscape(300, dims=c(100,100))
use_data(mbm_sims, overwrite=TRUE)


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


# loop version
long_version <- function(vec){
  for (i in 1:length(vec)){
    if(vec[i] < 0){
      vec[i] <- -vec[i]
    }
  }
  vec
}

# vectorized version
vec_version <- function(vec){
  vec[vec < 0] <- -vec[vec <= 0]
}

# make some data
long_data <- rep(c(-1, 1), 7000000)
long_data
sum(long_data)  # should sum to 0 (-1 + 1 = 0)

# time the functions
system.time(long_version(long_data))
system.time(vec_version(long_data))


#CREATING Filtered DATA FRAMES

murders <- mutate(murders, rate = total/population*100000, rank = rank(-rate))

# Create a table, call it my_states, that satisfies both the conditions: States in Northest or West and rate less than 1

my_states <- filter(murders, region %in% c("Northeast", "West") & rate < 1)

# Use select to show only the state name, the murder rate and the rank

my_states %>% select(state, rate, rank)

#................
#ONE LINE OF CODE
my_states <- murders %>% mutate(rate = total/population*100000, rank = rank(-rate)) %>% filter(region %in% c("Northeast","West") & rate < 1) %>% select(state, rate, rank)


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


# Load the tidyverse
library(tidyverse)

# Read in the bustabit gambling data
bustabit <- read_csv("datasets/bustabit.csv")

# Look at the first five rows of the data
head(bustabit, 5)

# Find the highest multiplier (BustedAt value) achieved in a game
bustabit %>%
    arrange(desc(BustedAt)) %>%
    slice(1)

# Create the new feature variables
bustabit_features <- bustabit %>%
  mutate(CashedOut = ifelse(is.na(CashedOut), BustedAt + .01, CashedOut),
         Profit = ifelse(is.na(Profit), 0, Profit),
         Losses = ifelse(Profit == 0, -Bet, 0),
         GameWon = ifelse(Profit == 0, 0, 1),
         GameLost = ifelse(Losses != 0, 1, 0))

# Look at the first five rows of the features data
head(bustabit_features, 5)

bustabit_features_soln <- bustabit %>%
  mutate(CashedOut = ifelse(is.na(CashedOut), BustedAt + .01, CashedOut),
         Profit = ifelse(is.na(Profit), 0, Profit),
         Losses = ifelse(Profit == 0, -1 * Bet, 0),
         GameWon = ifelse(Profit == 0, 0, 1),
         GameLost = ifelse(Profit == 0, 1, 0))

# Group by players to create per-player summary statistics
bustabit_clus <- bustabit_features %>%
  group_by(Username) %>%
  summarize(AverageCashedOut = mean(CashedOut),
            AverageBet = mean(Bet),
            TotalProfit = sum(Profit),
            TotalLosses = sum(Losses),
            GamesWon = sum(GameWon),
            GamesLost = sum(GameLost))

# View the first five rows of the data
head(bustabit_clus, n = 5)

bustabit_clus_soln <- bustabit_features_soln %>%
  group_by(Username) %>%
  summarize(AverageCashedOut = mean(CashedOut),
            AverageBet = mean(Bet),
            TotalProfit = sum(Profit),
            TotalLosses = sum(Losses),
            GamesWon = sum(GameWon),
            GamesLost = sum(GameLost))

# Create the mean-sd standardization function
mean_sd_standard <- function(x) {
    (x - mean(x)) / sd(x)
}

# Apply the function to each numeric variable in the clustering set
bustabit_standardized <- bustabit_clus %>%
    mutate_if(is.numeric, mean_sd_standard)

# Summarize our standardized data
summary(bustabit_standardized)

mean_sd_standard_soln <- function(x) {
    (x - mean(x)) / sd(x)
}

bustabit_standardized_soln <- bustabit_clus_soln %>%
    mutate_if(funs(is.numeric), mean_sd_standard_soln)

# Choose 20190101 as our random seed
set.seed(20190101)

# Cluster the players using kmeans with five clusters
cluster_solution <- kmeans(bustabit_standardized[-1], centers = 5 )

# Store the cluster assignments back into the clustering data frame object
bustabit_clus$cluster <- as.factor(cluster_solution$cluster)

# Look at the distribution of cluster assignments
table(bustabit_clus$cluster)

bustabit_clus_soln$cluster <- factor(cluster_solution$cluster)

# Group by the cluster assignment and calculate averages
bustabit_clus_avg <- bustabit_clus %>%
    group_by(cluster) %>%
    summarize_if(is.numeric, mean)

# View the resulting table
bustabit_clus_avg

cluster_mean_solution <- bustabit_clus_soln %>%
    group_by(cluster) %>%
    summarize_if(funs(is.numeric), mean)

# Create the min-max scaling function
min_max_standard <- function(x) {
   (x - min(x)) / (max(x) - min(x))
}

# Apply this function to each numeric variable in the bustabit_clus_avg object
bustabit_avg_minmax <- bustabit_clus_avg %>%
    mutate_if(is.numeric, min_max_standard)

head(bustabit_avg_minmax, 2)

# Load the GGally package
library(GGally)

# Create a parallel coordinate plot of the values
ggparcoord(bustabit_avg_minmax, columns = 2:ncol(bustabit_avg_minmax),
           groupColumn = 1, scale = "globalminmax", order = "skewness")

min_max_standard_soln <- function(x) {
    (x - min(x)) / (max(x) - min(x))
}

bustabit_avg_minmax_soln <- cluster_mean_solution %>%
    mutate_if(is.numeric, funs(min_max_standard_soln))

student_plot <- last_plot()
solution_plot <- ggparcoord(bustabit_avg_minmax, columns = 2:ncol(bustabit_avg_minmax),
           groupColumn = "cluster", scale = "globalminmax", order = "skewness")

# Calculate the principal components of the standardized data
my_pc <- as.data.frame(prcomp(bustabit_standardized[-1])$x)

# Store the cluster assignments in the new data frame
my_pc$cluster <- bustabit_clus$cluster

my_pc

# Use ggplot() to plot PC2 vs PC1, and color by the cluster assignment
p1 <- ggplot(my_pc, aes(x = PC1, y = PC2, color = cluster)) +
  geom_point()

# View the resulting plot
p1

my_pc_soln <- as.data.frame(prcomp(bustabit_standardized_soln[,-1])$x)
my_pc_soln$cluster <- bustabit_clus_soln$cluster

student_plot <- last_plot()
solution_plot <- ggplot(data = my_pc, aes(x = PC1, y = PC2, color = cluster)) +
    geom_point()

# Assign cluster names to clusters 1 through 5 in order
cluster_names <- c(
    "Risky Commoners",
    "High Rollers",
    "Risk Takers",
    "Cautious Commoners",
    "Strategic Addicts"
)

# Append the cluster names to the cluster means table
bustabit_clus_avg_named <- bustabit_clus_avg %>%
    cbind(Name = cluster_names)

# View the cluster means table with your appended cluster names
bustabit_clus_avg_named

cluster_names_soln <- c(
    "Risky Commoners",
    "High Rollers",
    "Risk Takers",
    "Cautious Commoners",
    "Strategic Addicts"
)

bustabit_clus_avg_named_soln <- cluster_mean_solution %>%
    cbind(Name = cluster_names_soln)

06. Clustering Bustabit Gambling Behavior.r


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


Logistic = read.table('C:\\Projects\\StatisticalLearning\\datasets\\Logistic.csv', header = TRUE, sep=",")
Logistic$X <- NULL
attach(Logistic)
model <- glm(canver~x1+x2,family=binomial(link='logit'),data=Logistic)

Binary = read.table('C:\\Projects\\StatisticalLearning\\datasets\\Binary.csv', header = TRUE, sep=",")
attach(Binary)
model <- glm(admit~gre+gpa,family=binomial(link='logit'),data=Binary)


# install.packages(c("dplyr", "tidyr"))
library(dplyr)
library(tidyr)
ad_click <- read.table(file = 'data/ad_click.csv', header = TRUE, sep=',')
head(ad_click)
summary(ad_click)

# maybe bug.
# tmp <- data.frame(a = factor(c('y', 'n')), b = factor(c('y', 'n')))
# makedummies::makedummies(tmp)

dummy <- makedummies::makedummies(ad_click)
head(dummy)
head(d)
df <- dplyr::tbl_df(dummy)
(ctr_df <- df %>% dplyr::group_by(
  sex_male
  , sex_other
  , agegroup_20s
  , agegroup_30s
  , agegroup_40s
  , agegroup_50s
  ) %>% dplyr::summarise(y=sum(res==1), n=sum(res==0)) %>% dplyr::mutate(ctr = y/(y+n)) %>% arrange(desc(ctr)))
# (ctr_df %>% tidyr::gather(key = sex, value = ctr, sex_male, sex_other) %>% tidyr::gather(key = agegroup, value = ctr, agegroup_20s, agegroup_30s, agegroup_40s, agegroup_50s) %>% select(-c('ctr')) %>% dplyr::mutate(ctr = y/(y+n)))
(temp <- ctr_df %>% tidyr::gather(key = sex, value = ctr, sex_male, sex_other) %>% tidyr::gather(key = agegroup, value = ctr, agegroup_20s, agegroup_30s, agegroup_40s, agegroup_50s) %>% select(-c('ctr', 'y', 'n')))
# https://oku.edu.mie-u.ac.jp/~okumura/stat/140921.html
# pred <- predict.glm(ad_click.glm, newdata = a, type="response") # get probabilty to be type="response".
test <- expand.grid(sex=levels(ad_click$sex), agegroup=levels(ad_click$agegroup)) # http://rishida.hatenablog.com/entry/2013/08/13/173849
# ad_click.glm <- glm(~~~~~~)
pred <- predict.glm(ad_click.glm, newdata = test, type="response") # get probabilty to be type="response".
ctr_pred <- cbind(makedummies::makedummies(test), pred_ctr=pred)
dplyr::inner_join(ctr_df , ctr_pred)


### Clustering routines in R (LGV'07)
library(cluster)

### cluster by rmsd
## read data and convert to a square matrix
data = scan('/home/luis/beuming/cluster/rmsd.mat')
rmsd = matrix(data, nrow=sqrt(length(data)), ncol=sqrt(length(data)))

## do the hierchical clustering with your favorite method (hclust, agnes, diana,...) to get a class twins object
cluster = agnes(rmsd, method='ward', diss=T)

## get a class hclust object for convience
cluster.h = as.hclust(cluster)

## summary and plots
summary(cluster)
plot(cluster)
pltree(cluster)

## Get the membership for different cuts: k (by number of clusters), h (by height)
levels.k1_3 = cutree(cluster, k=1:3)
write.table(levels.k1_3, file='levels.dat', quote=F)

levels.h6_5= cutree(cluster, h=6.5)

## identify clusters in the plot
plot(cluster.h)
foo1 = identify(cluster.h, N=3, MAXCLUSTER=10)
plot(cluster.h)
foo2 = rect.hclust(cluster.h, k=3)

### Using maptree
library(maptree)

## same as cutree
cluster.k3 = group.clust(cluster.h, k=3)
cluster.h6_5 = group.clust(cluster.h, h=6.5)

## table of energy for each structure. Use 2 cols: x (structure name or number) and y (energy)
energy = read.table(....)
energy = data.frame(x=seq(1,10), y=c(4,0,7,3,10,9,2,13,4,5))

## map clustering on the object vs energy plot
names(cluster.k3) = energy$x
map.groups(energy, cluster.k3)


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


# residual plots, Levene's test and Wilxocon test in R
#  using sparrow data as the example

sparrow <- read.table('sparrow.txt',as.is=T,header=T)

# create new variable lhumerus with the log of the humerus
sparrow$lhumerus <- log(sparrow$humerus)

# use lm() to fit t-test model to get residuals
#  fate must be a factor,
#  read.table automatically converts character info to factors
#   if OMIT as.is=T.  But, numeric values not converted
#  I prefer to do explicitly, so you get a factor whether or not
#   values are character.
#  Many different approaches here; once you know what's going on,
#   do what works best for you.

sparrow$fate.f <- as.factor(sparrow$fate)

sparrow.lm <- lm(humerus ~ fate.f, data=sparrow)

anova(sparrow.lm)
# print the F test, corresponds to t-test

# diagnostic plots based on residuals

qqnorm(resid(sparrow.lm))
#  qqplot for normal distribution

plot(predict(sparrow.lm),resid(sparrow.lm))
#  residual vs predicted value plot

plot(predict(sparrow.lm),abs(resid(sparrow.lm)))
#  abs(residual) vs predicted value plot

# Levene's test
sparrow$absresid <- abs(resid(sparrow.lm))
t.test(sparrow$absresid[sparrow$fate=='died'],
       sparrow$absresid[sparrow$fate=='alive'],
       var.equal=T)

# Wilcoxon rank sum test
wilcox.test(sparrow$humerus[sparrow$fate=='died'],
       sparrow$humerus[sparrow$fate=='alive'] )

# by default, uses "continuity correction", a detail
#  we haven't talked about
#  it improves fit of test statistic to normal distribution

# Wilcoxon rank sum test, with exact p-value
wilcox.test(sparrow$humerus[sparrow$fate=='died'],
       sparrow$humerus[sparrow$fate=='alive'],
       correct=F, exact=T )

# algorithm used by R does not work if there are ties
#  in the data (i.e. two or identical values)

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


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


pacman::p_load(foreign)

#https://www.rdocumentation.org/packages/datasets/versions/3.6.2/topics/mtcars
#opis pod powy?szym linkiem

# #sprawdzenie corelacji
# pacman::p_load(corrplot)
# cars.cor <- sapply(cars,function(x) as.numeric(x))
# cor_matrix=cor(cars.cor)
# corrplot(cor_matrix, method = number)

# wczytaj_mtcars <- function(){
#   cars = mtcars
#   # summary(cars)
#
#
#   cars$vs = factor(cars$vs ,labels = c("V", "S"))
#   cars$am = factor(cars$am , labels = c("automatic", "manual") )
#   cars$gear = as.factor(cars$gear)
#
#   cat("Wczytano mtcars i poprawiono dane")
#   return(cars)
# }

rmse <- function(actual, predicted){
  sqrt(mean((actual - predicted)^2))
}

wczytaj_mtcars <- function(){
  cars = mtcars
  cars = as.data.frame(sapply(cars, as.numeric))#zmiana na numeryczne i "ramke"
  set.seed(123)
  indexy <- sample(nrow(cars), size = trunc(0.25* nrow(cars)) )
  train <- cars[indexy, ]
  test <- cars[-indexy, ]

  #wybieranie kolumn "ważnych"
  tmp <- lm(qsec~1 , data = cars)
  forward <- step(tmp, direction = "forward", scope = list(upper=.~.+mpg+cyl+hp+drat+wt+vs+am+gear+carb), trace=0)
  summary(forward)$r.squared#0.8523863

  tmp <- lm(qsec~mpg+cyl+hp+drat+wt+vs+am+gear+carb , data = cars)
  backward <- step(tmp, direction = "backward", scope = list(upper=.~.+mpg+cyl+hp+drat+wt+vs+am+gear+carb), trace=0)
  summary(backward)$r.squared#0.8453189

  tmp <- lm(qsec~. , data = cars)
  both <- step(tmp, direction = "both", scope = list(upper=.~.+mpg+cyl+hp+drat+wt+vs+am+gear+carb), trace=0)
  summary(both)$r.squared #0.8642928

  # cat("forward r.squared = ", summary(forward)$r.squared)
  # cat("backward r.squared = ", summary(backward)$r.squared)
  # cat("both r.squared = ", summary(both)$r.squared)
  #

  nazwyKolumn <- variable.names(both) #najlepszy both
  nazwyKolumn[1] <- "qsec" #poprawka nazwy

  return (list("columns" = nazwyKolumn, "train" = train, "test"=test))
}

svm_mtcars <- function(kolumny, dane, kernel = "radial"){
  model = svm(qsec~., data=dane[,kolumny], kernel = kernel, type="nu-regression")
  return (model)
}


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
}


library("e1071")
source("../utils.r")
data = read.table('data.txt', header=FALSE)
# sink(file = 'results.txt')
samples = list()
samples$X = data[,1:ncol(data)-1]
samples$Y = data[,ncol(data)]
reduction = reducePCA(samples$X)
samples$X = reduction$x
classes = unique(samples$Y)
gbs <- c()
# one-against-one
for(i in 2:5)
	for(j in i+1:5) {
		if(i == j)
			next
		indI = which(samples$Y == classes[i])
		indJ = which(samples$Y == classes[j])
		ind = c(indI, indJ)
		pair = list()
		pair$X = samples$X[ind,]
		pair$Y = samples$Y[ind]
		print(nrow(pair$X))
		print(length(pair$Y))
		# polynomial
		logMessage('Polynomial')
		r = run.experiment(pair, c(1,2,3), c(0,1), c(10,100), 1, "polynomial")
		a = gb.analyze(r$n, r$nu, r$radius, r$rho)
		print(i)
		print(j)
		print(a$gb)
		gbs = rbind(gbs, c(i, j, a$gb, a$n, r$performance))
	}
# sink()


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


# Master Thesis Project - Extreme Value Theory
# Getting the experimental data above the 95 %
# and fitting a GEV distribution to it

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

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

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

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

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

# Computing the 95 % - quantiles for each of the stocks
quantiles <- c(quantile(df_plain[[1]],0.95), quantile(df_plain[[2]],0.95), quantile(df_plain[[3]],0.95),
					quantile(df_plain[[4]],0.95), quantile(df_plain[[5]],0.95))

# Getting the data above the threshold

data_bnp <- df_plain[[1]]
data_bnp <- data_bnp[data_bnp > quantiles[1]]

data_carrefour <- df_plain[[2]]
data_carrefour <- data_carrefour[data_carrefour > quantiles[2]]

data_lvmh <- df_plain[[3]]
data_lvmh <- data_lvmh[data_lvmh > quantiles[3]]

data_sanofi <- df_plain[[4]]
data_sanofi <- data_sanofi[data_sanofi > quantiles[4]]

data_total <- df_plain[[5]]
data_total <- data_total[data_total > quantiles[5]]

# Plotting the above-threshold data
x_label <- ""
y_label <- "Stock price"
title1 <- "BNP Paribas stock"
title2 <- "Carrefour stock"
title3 <- "LVMH stock"
title4 <- "Sanofi stock"
title5 <- "Total stock"
quartz()
png(file = "aboveThresholdData.png")
par(mfrow = c(3,2))
plot(data_bnp, pch = 1, col = "black", type = 'p', xlab = x_label, ylab = y_label, main = title1)
plot(data_carrefour, pch = 1, col = "blue", type = 'p', xlab = x_label, ylab = y_label, main = title2)
plot(data_lvmh, pch = 1, col = "green", type = 'p', xlab = x_label, ylab = y_label, main = title3)
plot(data_sanofi, pch = 1, col = "purple", type = 'p', xlab = x_label, ylab = y_label, main = title4)
plot(data_total, pch = 1, col = "red", type = 'p', xlab = x_label, ylab = y_label, main = title5)
dev.off()
graphics.off()

quartz()
png(file = "gev.diag BNP Paribas")
gev.diag(gev.fit(data_bnp))
dev.off()
graphics.off()

quartz()
png(file = "gev.diag Carrefour")
gev.diag(gev.fit(data_carrefour))
dev.off()
graphics.off()

quartz()
png(file = "gev.diag LVMH")
gev.diag(gev.fit(data_lvmh))
dev.off()
graphics.off()

quartz()
png(file = "gev.diag Sanofi")
gev.diag(gev.fit(data_sanofi))
dev.off()
graphics.off()

quartz()
png(file = "gev.diag Total")
gev.diag(gev.fit(data_total))
dev.off()
graphics.off()

data_lvmh <- df_plain[[3]]
data_lvmh <- data_lvmh[data_lvmh > quantile(df_plain[[3]],0.975)]

quartz()
png(file = "gev.diag LVMH2")
gev.diag(gev.fit(data_lvmh))
dev.off()
graphics.off()

data_lvmh <- as.numeric((read.csv("daily_LVMH_table.csv", header = FALSE))[[3]])
quartz()
png(file = "LVMH_daily.png")
plot(1:length(data_lvmh), data_lvmh)
dev.off()
graphics.off()

lvmh_quant <- quantile(data_lvmh, 0.99)
data_lvmh <- data_lvmh[data_lvmh > lvmh_quant]

quartz()
png(file = "LVMH_daily_99quant.png")
plot(1:length(data_lvmh), data_lvmh)
dev.off()
graphics.off()

quartz()
png(file = "gev.diag LVMH3")
gev.diag(gev.fit(data_lvmh))
dev.off()
graphics.off()