beta_calibration <- function(p, y, parameters="abm"){
  p <- pmax(1e-16, pmin(p, 1-1e-16))
  if (parameters == "abm"){
    d <- data.frame(y)
    d$lp <- log(p)
    d$l1p <- -log(1-p)

    fit <- glm(y~lp+l1p,family=binomial(link='logit'),data=d)

    a <- as.numeric(fit$coefficients['lp'])
    b <- as.numeric(fit$coefficients['l1p'])
    if (a < 0){
      fit <- glm(y~l1p,family=binomial(link='logit'),data=d)
      a <- 0
      b <- as.numeric(fit$coefficients['l1p'])
    }else if (b < 0){
      fit <- glm(y~lp,family=binomial(link='logit'),data=d)
      a <- as.numeric(fit$coefficients['lp'])
      b <- 0
    }
    inter <- as.numeric(fit$coefficients['(Intercept)'])
    m <- uniroot(function(mh) b*log(1-mh)-a*log(mh)-inter,c(1e-16,1-1e-16))$root

    calibration <- list("map" = c(a,b,m), "model" = fit, "parameters" = parameters)
    return(calibration)

  }else if (parameters == "am"){
    d <- data.frame(y)
    d$lp <- log(p / (1 - p))

    fit <- glm(y~lp,family=binomial(link='logit'), data=d)

    inter = as.numeric(fit$coefficients['(Intercept)'])
    a <- as.numeric(fit$coefficients['lp'])
    b <- a
    m <- 1.0 / (1.0 + exp(inter / a))

    calibration <- list("map" = c(a,b,m), "model" = fit, "parameters" = parameters)
    return(calibration)

  }else if (parameters == "ab"){
    d <- data.frame(y)
    d$lp <- log(2 * p)
    d$l1p <- log(2*(1-p))

    fit = glm(y~lp+l1p-1,family=binomial(link='logit'), data=d)

    a <- as.numeric(fit$coefficients['lp'])
    b <- -as.numeric(fit$coefficients['l1p'])
    m = 0.5

    calibration <- list("map" = c(a,b,m), "model" = fit, "parameters" = parameters)
    return(calibration)
  }else{
    stop("Unknown parameters. Expected abm, am or ab.")
  }
}


large_tensor <- function(X, Y, edges) {
  # X, Y three-dim arrays, edges a list of edges in the network
  # output is a vector res
  # in position e, corresponding to edge (z,p) via the edges-list, it is:
  # the sum over j, k of the product X_pjk * Y_zjk

  J <- dim(X)[2]
  K <- dim(X)[3]
  E <- nrow(edges)

  res <- rep(0,E)
  for (j in 1:J) {
    for (k in 1:K) {
      res <- res + X[edges[,3], j, k] * Y[edges[,2], j, k]
    }
  }
  res
}


=begin
[((<README-ja|URL:README-ja.html>))]  [((<English|URL:../doc/index.html>))]
= 代数パッケージ

  Version: 0.72  (2006.09.16)
  Author: 原 信一郎 (sinara@blade.nagaokaut.ac.jp)

  これは１変数あるいは多変数の多項式を計算するためのライブラリです。

== 0. 最初の一歩

最も簡単な利用法は require "algebra" として、計算を始めることです。

  require "algebra"
  x = Polynomial(Integer, "x").var
  puts( (x+1)**7 )
    #=> x^7 + 7x^6 + 21x^5 + 35x^4 + 35x^3 + 21x^2 + 7x + 1
  puts( (x**7 + 7*x**6 + 21*x**5 + 35*x**4 + 35*x**3 + 21*x**2 + 7*x + 1).factorize )
    #=> (x + 1)^7

== 1. 例題

 * ((<Samples|URL:samples-ja.html>))

== 2. 主なクラス・モジュール

 * ((<Algebra|URL:algebra-ja.html>)) (代数モジュール)
   * ((<Algebra::Polynomial|URL:polynomial-ja.html>)) (1変数多項式環クラス)
   * ((<Algebra::EuclidianRing|URL:euclidian-ring-ja.html>)) (ユークリッド環モジュール)
   * ((<Algebra::MPolynomial|URL:m-polynomial-ja.html>)) (多変数多項式環クラス)
   * ((<Algebra::ResidueClassRing|URL:residue-class-ring-ja.html>)) (剰余環クラス)
   * ((<Algebra::AlgebraicExtensionField|URL:algebraic-extension-field-ja.html>)) (代数拡大体クラス)
   * ((<Algebra::LocalizedRing|URL:localized-ring-ja.html>)) (局所化環クラス)
   * ((<Algebra::MatrixAlgebra|URL:matrix-algebra-ja.html>)) (行列代数クラス)
   * ((<Algebra::AlgebraicParser|URL:algebraic-parser-ja.html>)) (代数式を表す文字列の評価クラス)
   * ((<Algebra::Set|URL:finite-set-ja.html>)) (集合のクラス)
   * ((<Algebra::Map|URL:finite-map-ja.html>)) (写像のクラス)
   * ((<Algebra::Group|URL:finite-group-ja.html>)) (群のクラス)
   * ((<Algebra::PermutationGroup|URL:permutation-group-ja.html>)) (置換群のクラス)
== 3. その他

 * ((<Algebra::ElementaryDivisor|URL:elementary-divisor-ja.html>)) (単因子モジュール)
 * ((<Algebra::JordanForm|URL:jordan-form-ja.html>)) (ジョルダン行列クラス)
 * ((<Algebra::MatrixAlgebraTriplet|URL:matrix-algebra-triplet-ja.html>)) (3つ組行列のクラス)
 * ((<代数方程式ハンドルユーティリティー|URL:algebraic-equation-ja.html>))
 * ((<多項式環相互変換ユーティリティー|URL:polynomial-converter-ja.html>))

== 4. パッケージ内容

=== 総合
  algebra.rb             Algebra ライブラリ一般利用ファイル

=== 一変数関係
  polynomial.rb          １変数多項式環のクラス
  euclidian-ring.rb      ユークリッド整域ユティリティー(G.C.D.の計算)
  polynomial-factor.rb   １変数多項式因数分解ライブラリ
    polynomial-factor-int.rb   整数係数版
    polynomial-factor-zp.rb    Zp係数版
    polynomial-factor-alg.rb   代数的数係数版

=== 多変数関係
  m-polynomial.rb         多変数多項式環のクラス
    m-index.rb            m-polynomial.rb の下請け
  m-polynomial-factor.rb   １変数多項式因数分解ライブラリ
    m-polynomial-factor-int.rb   整数係数版
    m-polynomial-factor-zp.rb    Zp係数版
  groebner-basis.rb       グレブナ基底の計算モジュール
  groebner-basis-coeff.rb 除算の計算モジュール

=== 代数全般
  localized-ring.rb       商体作成ライブラリ
  matrix-algebra.rb       行列代数のクラス
    elementary-divisor.rb 単因子操作モジュール
    matrix-algebra.triplete.rb  3つ組行列クラス
    jordan-form.rb        ジョルダン行列クラス
  residue-class-ring.rb   多項式環の剰余環
  algebraic-extention-field.rb 代数拡大体
  splitting-field.rb      多項式の最小分解体
  galois-group.rb         Galois 群
  linear-algebra.rb       線形代数ライブラリ
  algebraic-equation.rb   代数方程式ライブラリ

=== 基礎部分

  finite-set.rb           集合のクラス
    finite-map.rb         写像のクラス
    finite-group.rb       群のクラス
      permutation-group.rb  置換群のクラス

=== 共通部分
  prime-gen.rb            素数生成クラス
  numeric-supplement.rb   Numeric の補完
  polynomial-converter.rb 多項式環相互変換ユーティリティー
  algebra-system.rb       代数系の共通仕様
  algebraic-parser.rb     多元環の式の文字列表現を評価するモジュール

=== その他
  array-supplement.rb     Array の補完
  doc-ja/                 マニュアル日本語版(RD, HTML, TXT)
  doc/                    マニュアル英語版(RD, HTML, TXT)
  sample/                 サンプルコード
  work/                   （開発作業場所）

== 5. ToDo
#<<< todo.rd
* ((<todo.html|URL:todo.html>))

== 6. Changes
#<<< changes.rd
* ((<changes.html|URL:changes.html>))

=end


f <- function(levels) {
  l0_net <- 367.6820687999996
  l0_load <- 2725.8433333333405

  l1_net <- 13.506289920000007
  l1_load <- 9.873333333333331

  l2_net <- 0.4347581039999998
  l2_load <- 0.495

  l3_net <- 0.0
  l3_load <- 0.0

  time <- l0_load / levels[1] + l1_load / levels[2] + l1_net / (50.0 * levels[2]) + l2_load / levels[3] + l2_net / (50.0 * levels[3]) + l3_load / levels[4] + l3_net / (50.0 * levels[4])

  sla0 <- 0.0 * 20.0 * exp(-time/1000.0)
  sla1 <- 0.0 * 200.0 * exp(-time/20.0)
  sla2 <- 0.0 * 100.0 * exp(-time/40.0)
  sla3 <- 587.0 * 50.0 * exp(-time/80.0)

  sla0 + sla1 + sla2 + sla3 - (levels[1] + levels[2] + levels[3] + levels[4]) * 0.2
}


  error.propagate = function(x=NULL, error.x=NULL, y=NULL, error.y=NULL, type="") {
    if (type=="product") { # expects y to be the transition matrix
      error.x.sq = (error.x/x)^2
      error.x.sq[ !is.finite(error.x.sq) ] = 0
      error.y.sq =  (error.y/y)^2
      error.y.sq[ !is.finite(error.y.sq) ] = 0

      if (is.array(y) | is.matrix(y) ) {
        error.z = sqrt( as.vector(error.y.sq %*% error.x.sq) )
      } else {
        error.z = sqrt( error.x.sq + error.y.sq )
      }

    } else if (type=="sum") {
      error.x.sq = error.x^2
      error.x.sq[ !is.finite(error.x.sq) ] = 0
      error.y.sq = error.y^2
      error.y.sq[ !is.finite(error.y.sq) ] = 0

      if (is.array(y) | is.matrix(y) ) {
        error.z = sqrt( as.vector( error.x.sq %*% t(error.y.sq) ))
      } else {
        error.z = sqrt( error.x.sq + error.y.sq )
      }

    } else if ( type=="power" ) {
      error.z = abs(y) * error.x/x
      error.z[ !is.finite(error.z) ] = 0
    }
    return(error.z)
  }


#############################
# Spatial Netrate
#'
#' @param tmat timeseries matrix
#' @param dmat distance matrix
#' @param DataType distance data type - euclidian, friction, binary
#' @param SpatialKernel
#' @param fixed vector of fixed parameters
#' @param alpha prior mean and variance for serial interval parameter alpha, if fixed the fixed value
#' @param delta prior mean and variance for distance function parameter delta, if fixed the fixed value
#' @param epsilon prior mean and variance for epsilon edge, if fixed the fixed value
#'
#' @return
#' @export
#'
#' @examples

spatialnetrate <-
  function(tp = tmat,
           dp = dmat,
           DataType = euclidian,
           SpatialKernel = "nil",
           fixed = "epsilon",
           alpha = c(0.003, 0.01),
           delta = c(0.01, 0.01),
           epsilon = 1e-3) {

    library(tensorflow)
    library(reticulate)
    tfp <- reticulate::import("tensorflow_probability",convert=FALSE)

    ###############################
    #key small functions to define
    ##############################

    f1<-function(t,d,a,r) {
      likelihood = a*t*exp(-0.5*a*t*t) * (1/d)^r

      # survival (exp(-0.5*a*t*t) * (1/d)^(r-1) )/(r-1)
      # hazard (a*(r-1)*t)/(d)

      return(likelihood)
    }
    f2<-function(t,d,a,r) {
      likelihood = a*t*exp(-0.5*a*t*t) * exp(-d^2*r)

      # survival (exp(-0.5*a*t*t) * (1/d)^(r-1) )/(r-1)
      # hazard (a*(r-1)*t)/(d)

      return(likelihood)
    }
    f3<-function(t,d,a,r) {
      likelihood = a*t*exp(-0.5*a*t*t) * exp(-abs(d)*r)

      # survival -exp(-0.5*a*t*t - r*d)
      # hazard

      return(likelihood)
    }
    match.cols<-function(val,n){
      colfunc <- colorRampPalette(c("blue","cyan","yellow","orange","red"))
      col<-data.frame(val=seq(min(val),max(val),length.out=n),col=colfunc(n))
      out<-rep(NA,length(col))
      for(i in 1:length(val)){
        out[i]<-as.character(col[which.min(abs(col$val-val[i])),'col'])
      }
      return(out)
    }

    ###################################################
    ## Data defining section
    ###################################################

    #set.seed(1234)
    tf$reset_default_graph()
    N = ncol(tmat) # number of infectors
    Q = nrow(tmat) # number of infectees

    tp = tf$placeholder(shape = shape(Q, N), dtype = tf$float32)
    dp = tf$placeholder(shape = shape(Q, N), dtype = tf$float32)

    ## A defining section
    if (fixed == "alpha") {
      A <- alpha
      #this may need more coding, maybe just A=alpha is okay too?
      A <- tf$constant(alpha, shape = shape(Q, N), dtype = tf$float32)
    } else{
      A <-
        tf$nn$relu(tf$Variable(
          tf$constant(alpha[1], shape = shape(Q, N), dtype = tf$float32),
          name = 'alpha'
        )) # length scale for space
      A <-
        tf$minimum(A, tf$constant(0.01, shape = shape(Q, N), dtype = tf$float32))
      A <- A * tf$sign(tp)
      Ad <-
        tfp$distributions$TruncatedNormal(
          loc = alpha[1],
          scale = alpha[2],
          high = 0.01,
          low = 0.0
        ) #0.005,0.001

    }

    ## D defining section
    if (fixed == "delta") {
      D <- delta

    } else{
      D <-
        tf$nn$relu(tf$Variable(
          tf$constant(delta[1], shape = shape(1L), dtype = tf$float32),
          name = 'distance_scale'
        )) # length scale for space
      #Dd<-tfp$distributions$Exponential(0.001)
      Dd <-
        tfp$distributions$TruncatedNormal(
          loc = delta[1],
          scale = delta[2],
          low = 0.0,
          high = 0.5
        ) #0.005,0.001

    }

    #E defining setcion
    if (fixed == "epsilon") {
      E<-tf$nn$relu(tf$Variable(tf$constant(epsilon,shape=shape(Q),dtype=tf$float32),name='epsilon_edge'))
      #E<-epsilon
    } else{
      E <-
        tf$nn$relu(tf$Variable(
          tf$constant(epsilon[1], shape = shape(Q), dtype = tf$float32),
          name = 'epsilon_edge'
        )) # length scale for space
      Ed <-
        tfp$distributions$TruncatedNormal(epsilon[1],
                                          scale = epsilon[2],
                                          high = 0.9,
                                          low = 0.0)
    }
    if(fixed == "nil"){
      print("no fixed parameters - identifiability could be an issue")
    }
    ###################################################
    ## Spatial kernel section
    ###################################################

    if (SpatialKernel == "exponential") {
      H <- A * tp * tf$exp(-dp * D)

    }else if(SpatialKernel == "Power Law"){
      H <- A * tp * ((1/dp)^D)

    } else if (SpatialKernel == "linear") {
      H <- A * tp * D * dp

    } else if (SpatialKernel == "gaussian"){
      H <- A * tp * (1/(2*3.14*(D*D)))*exp(-dp)/(2*D*D)

    } else {
      H <- A * tp
    }

    #######################################################
    ##tensorflow code
    #######################################################
    nll1 <-
      tf$reduce_sum(log(tf$reduce_sum(H, 1L) + E)) #first loop and second loop
    S <- tf$negative(0.5 * A * tp * tp)

    nll2 <-
      tf$reduce_sum(tf$reduce_sum(S, 1L) - E) #first loop and second loop
    log_prior <-
      tf$negative(tf$reduce_sum(Ad$log_prob(A)) + tf$reduce_sum(Dd$log_prob(D)))
    if(fixed != "epsilon"){
      log_prior <-
        tf$negative(tf$reduce_sum(Ad$log_prob(A)) + tf$reduce_sum(Dd$log_prob(D))+tf$reduce_sum(Ed$log_prob(E)))
    }else{
      log_prior <-
        tf$negative(tf$reduce_sum(Ad$log_prob(A)) + tf$reduce_sum(Dd$log_prob(D)))}
    #log_prior<- tf$negative(tf$reduce_sum(Ad$log_prob(A)))

    nll <- tf$negative(nll1 + nll2)
    log_posterior <- tf$add(nll, log_prior)

    F <-
      H * tf$exp(S) # transmission likelihood is hazard times survival

    train_step = tf$train$AdamOptimizer(1e-3)$minimize(log_posterior) # gradient step size !! IMPORTANT FREE PARAMETER !!
    init = tf$global_variables_initializer()
    myconfig = tf$ConfigProto(log_device_placement = FALSE)
    sess = tf$Session(config = myconfig)
    steps = 10000
    sess$run(init) # initialise session
    nll_store <- 1:steps

    #############################################################
    #BFGS optimising
    #############################################################
    #
    # optimizer = tf$contrib$opt$ScipyOptimizerInterface(
    #   log_posterior,
    #   method = 'L-BFGS-B',
    #   options = dict('maxiter' = 2000000L,
    #                  'disp' = TRUE)
    # )
    # sess = tf$Session()
    # init = tf$global_variables_initializer()
    # sess$run(init) # initialise session
    #
    # optimizer$minimize(session = sess,
    #                    feed_dict = dict(tp = tmat,
    #                                     dp = dmat))
    #
    #
    # #sess$run(E)
    # Ds<-sess$run(D)
    # value <- sess$run(list(nll, log_prior, log_posterior),
    #                   feed_dict = dict(tp = tmat,
    #                                    dp = dmat))
    # print(paste(value[[1]], value[[2]], value[[3]]))
    #

    #manual opt
    for (i in 1:steps) {
      value<-sess$run(list(train_step,nll,log_prior,log_posterior),
                      feed_dict=dict(
                        tp=tmat,
                        dp=dmat
                      ))
      nll_store[i]=value[[2]]
      if(i %% 1000 == 0){
        print(paste(value[[2]],value[[3]],value[[4]]))
        #			print(paste(sess$run(E)))

      }
    }
    # plot(nll_store)

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

    As <- sess$run(list(A), feed_dict = dict(tp = tmat,
                                             dp = dmat))[[1]]
    meanA<-mean(As[As != 0])
    par(mfrow = c(1, 4))
    Fs <- sess$run(list(F), feed_dict = dict(tp = tmat,
                                             dp = dmat))[[1]]
    Ds<-sess$run(D)
    eps_edge<-sess$run(E)
    #eps_edge <- rep(E, nrow(Fs))

    Fs <- cbind(Fs, eps_edge)

    Fs = sweep(Fs, 1, rowSums(Fs), FUN = '/')
    Rt <- colSums(Fs, na.rm=TRUE)[1:(ncol(Fs) - 1)]

    #plotting space-time likelihood and kernels
    x=seq(15,165,length.out=100)
    d=seq(1,200,length.out=100)
    z=expand.grid(x,d)
    r= as.numeric(Ds)
    # par(mfrow=c(1,3))
    #
    # if (SpatialKernel == "exponential") {
    #
    #   y=f3(z[,1]-15,z[,2],meanA,r)
    #
    #   plot(z,col=match.cols(y,1000),pch=15)
    #   plot(d,exp(-d*r),type='b')
    #
    # }else if(SpatialKernel == "Power Law"){
    #
    #   y=f1(z[,1]-15,z[,2],meanA,r)
    #   plot(z,col=match.cols(y,1000),pch=15)
    #   plot(d,(1/d)^r,type='b')
    #
    # } else if (SpatialKernel == "linear") {
    #   H <- A * tp * D * dp
    #
    #
    # } else if (SpatialKernel == "gaussian"){
    #   y=f2(z[,1]-15,z[,2],meanA,r)
    #   plot(z,col=match.cols(y,1000),pch=15)
    #   plot(d,exp(-d^2*r),type='b')
    #
    #
    #
    # } else {
    #
    # }
    #
    #
    # plot(dd$t,Rt)
    # abline(h=mean(Rt))
    #

    return(list(Rt,Ds,As,eps_edge))

  }


subroutine dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,eps,nerror)

# Output the description of the Dirichlet tile centred at point
# i for i = 1, ..., npd.  Do this in the original order of the
# points, not in the order into which they have been bin-sorted.
# Called by master.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
dimension dirsum(npd,3), rw(4)
logical collin, intfnd, bptab, bptcd, rwu

# Note that at this point some Delaunay neighbours may be
# `spurious'; they are the corners of a `large' rectangle in which
# the rectangular window of interest has been suspended.  This
# large window was brought in simply to facilitate output concerning
# the Dirichlet tesselation.  They were added to the triangulation
# in the routine `dirseg' which ***must*** therefore be called before
# this routine (`dirout') is called.  (Likewise `dirseg' must be called
# ***after*** `delseg' and `delout' have been called.)

# Dig out the corners of the rectangular window.
xmin = rw(1)
xmax = rw(2)
ymin = rw(3)
ymax = rw(4)

do i = 1,npd {
        area = 0. # Initialize the area of the ith tile to zero.
	nbpt = 0  # Initialize the number of boundary points of
                  # the ith tile to zero.
        npt = 0   # Initialize the number of tile boundaries to zero.

        np = nadj(i,0)

        # Output the point number, its coordinates, and the number of
        # its Delaunay neighbours == the number of boundary segments in
        # its Dirichlet tile.

        # For each Delaunay neighbour, find the circumcentres of the
        # triangles on each side of the segment joining point i to that
        # neighbour.
        do j1 = 1,np {
                j = nadj(i,j1)
                call pred(k,i,j,nadj,madj,ntot,nerror)
		if(nerror > 0) return
                call succ(l,i,j,nadj,madj,ntot,nerror)
		if(nerror > 0) return
                call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror)
		if(nerror>0) return
                if(collin) {
			nerror = 13
			return
		}
                call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror)
		if(nerror>0) return
                if(collin) {
			nerror = 13
			return
		}

                # Increment the area of the current Dirichlet
                # tile (intersected with the rectangular window) by applying
                # Stokes' Theorem to the segment of tile boundary joining
                # (a,b) to (c,d).  (Note that the direction is anti-clockwise.)
                call stoke(a,b,c,d,rw,tmp,sn,eps,nerror)
		if(nerror > 0) return
                area = area+sn*tmp

                # If a circumcentre is outside the rectangular window, replace
                # it with the intersection of the rectangle boundary with the
                # line joining the two circumcentres.  Then output
                # the number of the current Delaunay neighbour and
                # the two circumcentres (or the points with which
                # they have been replaced).
                # Note: rwu = "right way up".
                xi = x(i)
                xj = x(j)
                yi = y(i)
                yj = y(j)
                if(yi!=yj) {
                    slope = (xi - xj)/(yj - yi)
                    rwu = .true.
                } else {
                    slope = 0.d0
                    rwu = .false.
                }
                call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab,nedge)
                if(intfnd) {
                        call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd,nedge)
                	if(!intfnd) {
				nerror = 17
				return
			}
			if(bptab & bptcd) {
				xm = 0.5*(ai+ci)
				ym = 0.5*(bi+di)
				if(xmin<xm&xm<xmax&ymin<ym&ym<ymax) {
					nbpt = nbpt+2
					npt  = npt+1
				}
			}
			else {
				npt = npt + 1
				if(bptab | bptcd) nbpt = nbpt+1
			}
		}
	}
        dirsum(i,1) = npt
        dirsum(i,2) = nbpt
        dirsum(i,3) = area
}

return
end


# 4. faza: Analiza podatkov

library(ggplot2)
library(GGally)
library(mgcv)

#NAPOVEDI Z KVADRATNO REGRESIJSKO FUNKCIJO - za LITVO

##NAPOVED TEDENSKIH DELOVNIH UR ZA LITVO
tedenske_delovne_ure <- URE %>% filter(drzava == "Litva") %>% select(leto, vrednost)
prilagajanje <- lm(data = tedenske_delovne_ure, vrednost~I(leto^2) +leto)
graf <- data.frame(leto = seq(2019, 2021, 1))
napoved <- mutate(graf, napovedano.st.tedenskih.ur=predict(prilagajanje, graf))

graf_regresije <- ggplot(tedenske_delovne_ure, aes(x=leto, y=vrednost))+
  geom_point() + geom_smooth(method = lm, formula =y~ x + I(x^2), fullrange = TRUE, color = 'blue')+
  geom_point(data = napoved, aes(x= leto, y=napovedano.st.tedenskih.ur), color='red', size = 2) +
  scale_x_continuous(breaks=seq(2008, 2021, 1)) +
  ggtitle('Napoved tedenskih delovnih ur za Litvo')

##NAPOVED DOLGOV ZA LITVO
dolgovi1 <- DOLGOVI %>% filter(drzava == "Litva") %>% select(leto, vrednost)
prilagajanje1 <- lm(data = dolgovi1, vrednost~I(leto^2) +leto)
graf1 <- data.frame(leto = seq(2019, 2021, 1))
napoved1 <- mutate(graf1, napovedano.dolgov=predict(prilagajanje1, graf1))

graf_regresije1 <- ggplot(dolgovi1, aes(x=leto, y=vrednost))+
  geom_point() + geom_smooth(method = lm, formula =y~ x + I(x^2), fullrange = TRUE, color = 'green')+
  geom_point(data = napoved1, aes(x= leto, y=napovedano.dolgov), color='red', size = 2) +
  scale_x_continuous(breaks=seq(2008, 2021, 1)) +
  ggtitle('Napoved dolžnikov za Litvo')

##NAPOVED LOČITEV ZA LITVO

locitve_litva <- LOCITVE %>% filter(država == "Litva") %>% select(leto, locitve)
prilagajanje2 <- lm(data = locitve_litva, locitve~I(leto^2) +leto)
graf2 <- data.frame(leto = seq(2019, 2021, 1))
napoved2 <- mutate(graf2, napovedane.locitve=predict(prilagajanje2, graf2))

graf_regresije2 <- ggplot(locitve_litva, aes(x=leto, y=locitve))+
  geom_point() + geom_smooth(method = lm, formula =y~ x + I(x^2), fullrange = TRUE, color = 'orange')+
  geom_point(data = napoved2, aes(x= leto, y=napovedane.locitve), color='red', size = 2) +
  scale_x_continuous(breaks=seq(2008, 2021, 1)) +
  ggtitle('Napoved ločitev za Litvo')


## caculate thigmotaxis/centrophobisms indices
message ("starting thigmotaxis")
c.thigm<- function(traj,env) {

	if (!inherits(env,"bur.env"))
		stop("env should be of class \"bur.env\".")

	if (!inherits(traj, "ltraj"))
        stop("ltraj should be of class \"ltraj\"")

	thigmotaxis <- c()
	thigmotaxis_dist <- c()
	dates <- c()
  realdistancelist = c()
	for (oo in c(1:length(traj))) {
		date =c()
		thigmo <-c()
		thigmo_ori <- c()
    realdistancelist_oo = c()

		data <- traj[[oo]]
		dist <- data$dist
		if (length (dist)>1) {

		date <- data$date
		xx <- data$x
		yy <- data$y
		distcarree <- xx*xx +yy*yy
		Arenaradiuscarre <- env$r*env$r

		# take only when there is more than one point in the burst

			thigmoplus = ifelse (distcarree> Arenaradiuscarre/2,(dist+500),-(dist+500))
			thigmo_ori_plus = ifelse (distcarree> Arenaradiuscarre/2,dist,-dist)

			thigmo = c(thigmo,thigmoplus)
			thigmo_ori = c(thigmo_ori, thigmo_ori_plus)
      #return distance to the center, positive value if fly moving, negative value otherwise
      D1=ifelse(sqrt(distcarree)/env$r >1, NA, sqrt(distcarree)/env$r)
      D = ifelse( dist>0,D1,-D1)
      realdistancelist_oo = c(realdistancelist_oo, D)
			}

		thigmotaxis <- c(thigmotaxis,thigmo)
		thigmotaxis_dist <- c(thigmotaxis_dist,thigmo_ori )
    realdistancelist = c(realdistancelist, realdistancelist_oo)
		dates <- c(dates,date)

	}

	erg <- data.frame(date=dates, thigmotaxis,thigmotaxis_dist, distances =realdistancelist)

	return(erg)
}

#compute thigmotaxis total, and thigmotaxis when moving for each animal
thigm_table = data.frame()

#compute angle deviations for each individum
for (i in c(1:nrow(id_table))) {
	thigm = c.thigm(traj[id(traj)==id_table$id[i]],env[[i]])
	id = rep(id_table$id[i],nrow(thigm))
	group = rep(id_table$group[i],nrow(thigm))
	thigm_table = rbind(thigm_table,data.frame(thigm,id,group))
}

thigmotaxisratio_total <- c()
thigmotaxisratio_notmoving <- c()
thigmotaxisratio_moving <- c()
thigmotaxisratio_ditancetrav <- c()
for (i in c(1:nrow(id_table))) {
	thigm_table_i = thigm_table[thigm_table$id==id_table$id[i],]

	totPLUS = length(thigm_table_i[thigm_table_i$thigmotaxis>=500,]$thigmotaxis)
  nomovPLUS = length(thigm_table_i[thigm_table_i$thigmotaxis==500,]$thigmotaxis)
	movePLUS = length(thigm_table_i[thigm_table_i$thigmotaxis>500,]$thigmotaxis )
	totMIN = length(thigm_table_i[thigm_table_i$thigmotaxis<= (-500),]$thigmotaxis)
  nomovMIN = length(thigm_table_i[thigm_table_i$thigmotaxis==(-500),]$thigmotaxis)
	moveMIN = length(thigm_table_i[thigm_table_i$thigmotaxis<(-500),]$thigmotaxis)

	thigmotaxisratio_total_i = (totPLUS-totMIN)/(totPLUS+totMIN)
	thigmotaxisratio_moving_i = (movePLUS-moveMIN)/(movePLUS+moveMIN)
  thigmotaxisratio_notmoving_i = (nomovPLUS-nomovMIN)/(nomovPLUS+nomovMIN)
	thigmotaxisratio_ditancetrav_i= sum (thigm_table_i$thigmotaxis_dist, na.rm=TRUE)

	thigmotaxisratio_total = c(thigmotaxisratio_total,thigmotaxisratio_total_i)
	thigmotaxisratio_moving <- c(thigmotaxisratio_moving,thigmotaxisratio_moving_i)
  thigmotaxisratio_notmoving <- c(thigmotaxisratio_notmoving,thigmotaxisratio_notmoving_i)
	thigmotaxisratio_ditancetrav <- c(thigmotaxisratio_ditancetrav,thigmotaxisratio_ditancetrav_i)

}
thigm_table_2 = data.frame(thigmotaxisratio_total,thigmotaxisratio_moving,thigmotaxisratio_notmoving,thigmotaxisratio_ditancetrav ,id=id_table$id,group=id_table$group)

f_table_index = data.frame(f_table_index,centrophobism_moving=thigmotaxisratio_moving,centrophobism_sitting=thigmotaxisratio_notmoving)
f_table = data.frame(f_table,centrophobism_moving=thigmotaxisratio_moving,centrophobism_sitting=thigmotaxisratio_notmoving)

# message("starting plotting thigmotaxis")

# setwd(rgghome)

# mean_table = create.mean.table(thigm_table_2,group_ids,data_cols=1:4)

# ### create plots
# #mybarplot(mean_table$means$thigmotaxisratio_total,mean_table$ses$thigmotaxisratio_total,rownames(mean_table$means),
# #	main="Thigmotaxis index total paints",ylab="Index (mean+sem)", ylim= c(-1,1))

# mybarplot(mean_table$means$thigmotaxisratio_notmoving,mean_table$ses$thigmotaxisratio_notmoving,rownames(mean_table$means),
# main="centrophobism index not moving paints",ylab="Index (mean+sem)", ylim= c(-1,1))

# mybarplot(mean_table$means$thigmotaxisratio_moving,mean_table$ses$thigmotaxisratio_moving,rownames(mean_table$means),
	# main="centrophobism index moving paints",ylab="Index (mean+sem)", ylim= c(-1,1))
# M=	max(max(mean_table$means$thigmotaxisratio_ditancetrav)+max(mean_table$ses$thigmotaxisratio_ditancetrav)*1.3,0)
# M2=  min(min(mean_table$means$thigmotaxisratio_ditancetrav)-min(mean_table$ses$thigmotaxisratio_ditancetrav)*1.3,0)
# mybarplot(mean_table$means$thigmotaxisratio_ditancetrav,mean_table$ses$thigmotaxisratio_ditancetrav,rownames(mean_table$means),
	# main="distance traveled outside - inside",ylab="distance [mm]", ylim = c(M2,M))

for (i in c(1:length(levels(id_table[,2])))) {
    dist = thigm_table$distances[thigm_table$group == levels(id_table[,2])[i]]
    dist=na.omit(dist)
    #hist(dist^2, main=levels(id_table[,2])[i], freq=FALSE, breaks= 15)
    #abline (v=0.5, col=2)
    #abline( v= median(dist^2), col=3)
    hist(dist*abs(dist), main=levels(id_table[,2])[i], freq=FALSE, breaks=30)
    dist2= dist[dist>0]
    abline( v= median(dist2*abs(dist2)), col=3)
    dist2= dist[dist<0]
    abline( v= median(dist2*abs(dist2)), col=3)
}


##### Chapter 2: Managing and Understanding Data -------------------

##### R data structures --------------------

## Vectors -----

# create vectors of data for three medical patients
subject_name <- c("John Doe", "Jane Doe", "Steve Graves")
temperature <- c(98.1, 98.6, 101.4)
flu_status <- c(FALSE, FALSE, TRUE)

# access the second element in body temperature vector
temperature[2]

## examples of accessing items in vector
# include items in the range 2 to 3
temperature[2:3]

# exclude item 2 using the minus sign
temperature[-2]

# use a vector to indicate whether to include item
temperature[c(TRUE, TRUE, FALSE)]

## Factors -----

# add gender factor
gender <- factor(c("MALE", "FEMALE", "MALE"))
gender

# add blood type factor
blood <- factor(c("O", "AB", "A"),
                levels = c("A", "B", "AB", "O"))
blood

# add ordered factor
symptoms <- factor(c("SEVERE", "MILD", "MODERATE"),
                   levels = c("MILD", "MODERATE", "SEVERE"),
                   ordered = TRUE)
symptoms

# check for symptoms greater than moderate
symptoms > "MODERATE"

## Lists -----

# display information for a patient
subject_name[1]
temperature[1]
flu_status[1]
gender[1]
blood[1]
symptoms[1]

# create list for a patient
subject1 <- list(fullname = subject_name[1],
                 temperature = temperature[1],
                 flu_status = flu_status[1],
                 gender = gender[1],
                 blood = blood[1],
                 symptoms = symptoms[1])

# display the patient
subject1

## methods for accessing a list

# get a single list value by position (returns a sub-list)
subject1[2]

# get a single list value by position (returns a numeric vector)
subject1[[2]]

# get a single list value by name
subject1$temperature

# get several list items by specifying a vector of names
subject1[c("temperature", "flu_status")]

## access a list like a vector
# get values 2 and 3
subject1[2:3]

## Data frames -----

# create a data frame from medical patient data

pt_data <- data.frame(subject_name, temperature, flu_status, gender,
                      blood, symptoms, stringsAsFactors = FALSE)

# display the data frame
pt_data

## accessing a data frame

# get a single column
pt_data$subject_name

# get several columns by specifying a vector of names
pt_data[c("temperature", "flu_status")]

# this is the same as above, extracting temperature and flu_status
pt_data[2:3]

# accessing by row and column
pt_data[1, 2]

# accessing several rows and several columns using vectors
pt_data[c(1, 3), c(2, 4)]

## Leave a row or column blank to extract all rows or columns

# column 1, all rows
pt_data[, 1]
# row 1, all columns
pt_data[1, ]
# all rows and all columns
pt_data[ , ]

# the following are equivalent
pt_data[c(1, 3), c("temperature", "gender")]
pt_data[-2, c(-1, -3, -5, -6)]

# creating a Celsius temperature column
pt_data$temp_c <- (pt_data$temperature - 32) * (5 / 9)

# comparing before and after
pt_data[c("temperature", "temp_c")]

## Matrixes -----

# create a 2x2 matrix
m <- matrix(c(1, 2, 3, 4), nrow = 2)
m

# equivalent to the above
m <- matrix(c(1, 2, 3, 4), ncol = 2)
m

# create a 2x3 matrix
m <- matrix(c(1, 2, 3, 4, 5, 6), nrow = 2)
m

# create a 3x2 matrix
m <- matrix(c(1, 2, 3, 4, 5, 6), ncol = 2)
m

# extract values from matrixes
m[1, 1]
m[3, 2]

# extract rows
m[1, ]

# extract columns
m[, 1]

##### Managing data with R ------------

## saving, loading, and removing R data structures

# show all data structures in memory
ls()

# remove the m and subject1 objects
rm(m, subject1)
ls()

rm(list=ls())

##### Exploring and understanding data --------------------

## data exploration example using used car data
usedcars <- read.csv("usedcars.csv", stringsAsFactors = FALSE)

# get structure of used car data
str(usedcars)

## Exploring numeric variables -----

# summarize numeric variables
summary(usedcars$year)
summary(usedcars[c("price", "mileage")])

# calculate the mean income
(36000 + 44000 + 56000) / 3
mean(c(36000, 44000, 56000))

# the median income
median(c(36000, 44000, 56000))

# the min/max of used car prices
range(usedcars$price)

# the difference of the range
diff(range(usedcars$price))

# IQR for used car prices
IQR(usedcars$price)

# use quantile to calculate five-number summary
quantile(usedcars$price)

# the 99th percentile
quantile(usedcars$price, probs = c(0.01, 0.99))

# quintiles
quantile(usedcars$price, seq(from = 0, to = 1, by = 0.20))

# boxplot of used car prices and mileage
boxplot(usedcars$price, main="Boxplot of Used Car Prices",
      ylab="Price ($)")

boxplot(usedcars$mileage, main="Boxplot of Used Car Mileage",
      ylab="Odometer (mi.)")

# histograms of used car prices and mileage
hist(usedcars$price, main = "Histogram of Used Car Prices",
     xlab = "Price ($)")

hist(usedcars$mileage, main = "Histogram of Used Car Mileage",
     xlab = "Odometer (mi.)")

# variance and standard deviation of the used car data
var(usedcars$price)
sd(usedcars$price)
var(usedcars$mileage)
sd(usedcars$mileage)

## Exploring numeric variables -----

# one-way tables for the used car data
table(usedcars$year)
table(usedcars$model)
table(usedcars$color)

# compute table proportions
model_table <- table(usedcars$model)
prop.table(model_table)

# round the data
color_table <- table(usedcars$color)
color_pct <- prop.table(color_table) * 100
round(color_pct, digits = 1)

## Exploring relationships between variables -----

# scatterplot of price vs. mileage
plot(x = usedcars$mileage, y = usedcars$price,
     main = "Scatterplot of Price vs. Mileage",
     xlab = "Used Car Odometer (mi.)",
     ylab = "Used Car Price ($)")

# new variable indicating conservative colors
usedcars$conservative <-
  usedcars$color %in% c("Black", "Gray", "Silver", "White")

# checking our variable
table(usedcars$conservative)

# Crosstab of conservative by model
library(gmodels)
CrossTable(x = usedcars$model, y = usedcars$conservative)


# Expected relative proportion of breakthrough hospitalized dengue by serostatus in populations vaccinated with the CYD- tetravalent dengue vaccine in the Philippines
# written by Stefan Flasche using R version 3.5.3

# load packages
require(tidyverse)

# Data --------------------------------------------------------------------

# data: cumulative incidence over 5yrs observed in the trial and its stratification into
#       seropositive and seronegative using PRNT50 with multiple imputation (in per 100). from Shridar Table S10
df <- tibble(no=1:8,
             randomisation = c("vacc","vacc","control","control","vacc","vacc","control","control"),
             serostatus = c("pos","neg","pos","neg","pos","neg","pos","neg"),
             outcome = c(rep("hosp",4),rep("severe",4)),
             incidence.ph.mid = c(.375,1.571,1.883,1.093,0.075,0.404,0.48,0.174),
             incidence.ph.lo = c(.263,1.125,1.536,.526,0.034,0.218,0.335,0.036),
             incidence.ph.hi = c(.535,2.193,2.307,2.265,0.165,0.749,0.688,0.834))

#seroprevalence Phil
sp=.70

# Cumulative proportion of 9-16y olds hospitalised with Dengue over time (0m - 60m). Digitalised from Sridhar Figure 3
df.time <- tibble(time = rep(c(0,6,12,18,24,30,36,42,48,54,60),4),
                  randomisation = c(rep("vacc",11*2),rep("control",11*2)),
                  serostatus = rep(c(rep("pos",11),rep("neg",11)),2),
                  incidence = c(0,0.031,0.051,0.061,0.113,0.153,0.184,0.235,0.276,0.307,0.368,
                                0,0.061,0.143,0.205,0.348,0.512,0.757,0.982,1.289,1.432,1.535,
                                0,0.143,0.307,0.573,0.982,1.125,1.350,1.514,1.678,1.739,1.862,
                                0,0.082,0.164,0.399,0.471,0.522,0.583,0.696,0.757,0.757,1.033),
                  No.at.Risk =c(1503,1490,1462,1453,1447,1434,1422,1403,1351,1284,1226,
                                375,374,368,366,364,361,358,350,339,322,311,
                                730,725,705,699,695,689,688,686,658,615,592,
                                207,207,201,199,199,195,194,192,185,174,167))

# plot data
p.data <- df %>% ggplot(aes(x= serostatus, y = incidence.ph.mid, ymin = incidence.ph.lo, ymax = incidence.ph.hi,color=randomisation)) +
  geom_linerange(position=position_dodge(width = 0.5)) +
  geom_point(position=position_dodge(width = 0.5)) +
  facet_grid(.~outcome, scales = "free") +
  coord_flip() + ylab("incidence per 100") +
  labs(y = "Incidence per 100", x = "Serostatus", color = "Randomisation")
ggsave(filename = "Pics\\Fig_Data.tiff",p.data ,unit="cm", width = 14, height = 5, compression = "lzw", dpi = 300)

### analyses on cumulative 5y estimates
vph = subset(df, randomisation=="vacc" & serostatus == "pos" & outcome =="hosp")$incidence.ph.mid
vnh = subset(df, randomisation=="vacc" & serostatus == "neg" & outcome =="hosp")$incidence.ph.mid
cph = subset(df, randomisation=="control" & serostatus == "pos" & outcome =="hosp")$incidence.ph.mid
cnh = subset(df, randomisation=="control" & serostatus == "neg" & outcome =="hosp")$incidence.ph.mid
vps = subset(df, randomisation=="vacc" & serostatus == "pos" & outcome =="severe")$incidence.ph.mid
vns = subset(df, randomisation=="vacc" & serostatus == "neg" & outcome =="severe")$incidence.ph.mid
cps = subset(df, randomisation=="control" & serostatus == "pos" & outcome =="severe")$incidence.ph.mid
cns = subset(df, randomisation=="control" & serostatus == "neg" & outcome =="severe")$incidence.ph.mid

#increase in seroneg vaccinees
vnh/cnh
vns/cns #severe

#RR in seropo / seroneg controls
cph/cnh
cps/cns #severe

#reduction in seropos vaccinees
1-vph/cph
1-vps/cps#severe

#cases averted in seropos vacc per 1 seroneg vacc case
sp*(cph-vph) / ((1-sp)*(vnh-cnh))
sp*(cps-vps) / ((1-sp)*(vns-cns))#severe

# breakthrough among all hospitalised
sp*vph  / (sp*vph + (1-sp)*vnh)
sp*vps  / (sp*vps + (1-sp)*vns)#severe

#proportion of excess cases among the cases in seronegatives
1-cnh/vnh
1-cns/vns#severe

#proportion of excess cases among all cases
(1-(sp*vph  / (sp*vph + (1-sp)*vnh))) * (1-cnh/vnh)
(1-(sp*vps  / (sp*vps + (1-sp)*vns))) * (1-cns/vns)#severe

# proportion of cases averted through vacc
1 - (sp*vph+(1-sp)*vnh) / (sp*cph+(1-sp)*cnh)
1 - (sp*vps+(1-sp)*vns) / (sp*cps+(1-sp)*cns)

#calculate  time dependent proportion of cases attributeable to breakthrough in seropositive, and excess cases n seronegative vaccinees
  #proportion of excess cases among the cases in seronegatives by time
  excess.prop = 1 - subset(df.time, randomisation=="control" & serostatus=="neg")$incidence / subset(df.time, randomisation=="vacc" & serostatus=="neg")$incidence
  excess.prop = excess.prop * (excess.prop>0)

df.prop = tibble(serostatus = c("neg","pos"),
                 prop = c(1-sp,sp))
data.time = df.time %>% merge(df.prop) %>%
  mutate(cases = incidence*prop*830000/100) %>%
  select(serostatus:randomisation, cases) %>%
  spread(serostatus, cases) %>%
  mutate(propSeroNeg = neg/(pos+neg)) %>%
  filter(randomisation=="vacc") %>%
  mutate(propVaccINduced = propSeroNeg * excess.prop) %>%
  mutate(propSeroNeg = propSeroNeg - propVaccINduced) %>%
  mutate(propSeroPos = 1-propSeroNeg-propVaccINduced) %>%
  gather(key = "key", value="prop", -(time:pos))
data.time$key = factor(data.time$key, levels = c("propSeroPos","propSeroNeg","propVaccINduced"))
data.time %>%
  ggplot(aes(x=time, y=prop, fill=key))+
  geom_area(alpha=.7) +
  coord_cartesian(ylim=c(0,1)) +
  scale_y_continuous(labels = scales::percent) +
  scale_fill_manual(values = c("#009E73","#E69F00","#D55E00"), name = "", labels = c("breakthrough cases in\nseropositive vaccinees\n", "cases in\nseronegative vaccinees\n", "vaccine attributable cases in\nseronegative vaccinees\n"))+
  theme_bw() +
  xlab("month since first vaccine dose") + ylab("percentage of all\nhospitalised cases")
ggsave(filename = "Pics\\Fig_PropCases.tiff",unit="cm", width = 17, height = 7, compression = "lzw", dpi = 300)


library(shiny)
library(rsconnect)
library(ggplot2)

#############################################################
# Set the baseline parameters
#############################################################
base_sI <- .2
base_gL <- .01
base_gA <- .02
base_delta <- .05
base_alpha <- .3
base_A <- 10
base_kalstar <- (base_sI/(base_gL+base_gA+base_delta))^(1/(1-base_alpha))
base_K <- base_kalstar*base_A
base_kystar <- base_sI/(base_gL+base_gA+base_delta)

#############################################################
# Define UI ----
#############################################################
ui <- fluidPage(
  withMathJax(),
  titlePanel("Level of BGP"),

  mainPanel(

      #hr(),

      h4("Set parameters"),

      fixedRow(
        column(4,
        sliderInput("alt_sI", h6('New capital share of GDP \\(s_I\\)'),
                    min = 0, max = .5, value = base_sI, ticks = FALSE, step=.01),
        sliderInput("alt_gL", h6("Population growth rate \\(g_L\\)"),
                    min = -.05, max = .05, value = base_gL, ticks = FALSE, step=.01),
        sliderInput("alt_gA", h6("Productivity gorwth rate \\(g_A\\)"),
                    min = -.05, max = .1, value = base_gA, ticks = FALSE, step=.01),
        sliderInput("alt_delta", h6("Depreciation rate \\(\\delta\\)"),
                    min = 0, max = .1, value = base_delta, ticks = FALSE, step=.01),
        sliderInput("alt_alpha", h6("Capital elasticity \\(\\alpha\\)"),
                    min = 0, max = 1, value = base_alpha, ticks = FALSE, step=.01),
        sliderInput("alt_A", h6("Baseline productivity \\(A_0\\)"),
                    min = 0, max = 30, value = base_A, ticks = FALSE, step=.1),
        br(),
        actionButton("reset", "Reset all to baseline")
        ),
        column(8,
        plotOutput("lnygraph",width = "100%"),
        )
      ) # end FluidRow
      ) # end main panel
  ) # end ui
#############################################################
# Define server logic ----
#############################################################
server <- function(input, output, session) {

  # Reset parameters
  observeEvent(input$reset, {
    updateSliderInput(session,'alt_sI',value = base_sI)
    updateSliderInput(session,'alt_gL',value = base_gL)
    updateSliderInput(session,'alt_gA',value = base_gA)
    updateSliderInput(session,'alt_delta',value = base_delta)
    updateSliderInput(session,'alt_alpha',value = base_alpha)
    updateSliderInput(session,'alt_A',value = base_A)
  })

  output$lnygraph <- renderPlot(
    {
      t <- c(0:100)
      df <- data.frame(t)
      kystar = input$alt_sI/(input$alt_gL+input$alt_gA+input$alt_delta)
      df$lny <- (input$alt_alpha/(1-input$alt_alpha))*log(kystar) + log(input$alt_A) + input$alt_gA*df$t

      ggplot(df, aes(x=t)) +
        geom_line(aes(y = lny),size=1) +
        xlab("Time") +
        ylab("Log GDP per capita") +
        theme_light() +
        ylim(0,7.5)
    }
  ) # end gky graph

} # end server

# Run the app ----
shinyApp(ui = ui, server = server)


# earthquakic data set -------------------------
# Number of applicants -------------------------

library(data.table)
library(rMGLReg)
devtools::load_all()
dtnew <- fread("D:/Rpackages/rMGLReg/data-raw/dtnew_copula.csv")
dtnew$ynew <- NULL
dtnew <- dtnew[year %in% seq(1990, 2015)]
dtadjust <- fread("D:/Rpackages/rMGLReg/data-raw/dtcpi.csv", header = T)
dtadjust <- dtadjust[year %in% seq(1990, 2015)]
dtadjust
dtadjust[, CPI_factor := 1 / (CPI / 615.2)]

setkey(dtadjust, year)
setkey(dtnew, year)
dt <- merge(dtnew, dtadjust)
dt[is.na(y)]$y <- median(dt$y, na.rm = T)
dt[, ynew := y * CPI_factor]

dtnew <- dt[, .(year,
  yraw = y,
  y1 = ynew, magnitude, death, inj, intensity,
  y2 = death + inj
)]
dtnew

# marginal distribution for y1
y <- dtnew$y1
Xsigma <- model.matrix(~1, data = dtnew)
Xb <- model.matrix(~1, data = dtnew)
LLlogmoyalGA3 <- function(y, pars, Xsigma, Xb) {
  sigma <- exp(Xsigma %*% pars[1:dim(Xsigma)[2]])
  b <- exp(Xb %*% pars[(dim(Xsigma)[2] + 1):(dim(Xsigma)[2] + dim(Xb)[2])])
  a <- exp(pars[dim(Xsigma)[2] + dim(Xb)[2] + 1])
  ll <- -0.5 * log(2 * pi) - log(sigma) + a * log(b) + lgamma(a + 0.5) - lgamma(a) - (1 / (2 * sigma) + 1) * log(y) - (a + 0.5) * log(0.5 * (1 / y)^(1 / sigma) + b)

  loglike <- -sum(ll)
  return(loglike)
}
mlogmoyalGA3 <- optim(
  fn = LLlogmoyalGA3, Xsigma = Xsigma,
  Xb = Xb,
  y = y, hessian = T,
  control = list(maxit = 50000),
  # method = 'Nelder-Mead',
  # par = c(-1,-0.1,0.5,-2,-1))
  par = c(-1, -1, -1)
)
# modout(mlogmoyalGA3)
#
pars <- mlogmoyalGA3$par
sigma <- exp(Xsigma %*% pars[1:dim(Xsigma)[2]])
b <- exp(Xb %*% pars[(dim(Xsigma)[2] + 1):(dim(Xsigma)[2] + dim(Xb)[2])])
a <- exp(pars[dim(Xsigma)[2] + dim(Xb)[2] + 1])
ufit <- c()
for (i in 1:length(y)) {
  ufit[i] <- pGLMGA(y[i], sigma = sigma[i], a = a, b = b[i])
}
resLMGA3 <- qnorm(ufit)
u1 <- ufit
f1 <- c()
for (i in 1:length(y)) {
  f1[i] <- dGLMGA(y[i], sigma = sigma[i], a = a, b = b[i])
}

## ----message=TRUE, warning=FALSE------------------------
library(gamlss)
library(gamlss.tr)
library(evd)
library(extRemes)
library(ggplot2)
library(qqplotr)
library(patchwork)
umin <- 20
gen.trun(par = umin + 1, type = "right", name = "tr", family = "NBI")
gen.trun(par = umin + 1, type = "right", name = "tr", family = "PO")
gen.trun(par = umin + 1, type = "right", name = "tr", family = "ZINBI")
gen.trun(par = umin + 1, type = "right", name = "tr", family = "ZIP")
dt2 <- dtnew[y2 <= umin]
m.NB <- gamlss(y2 ~ 1, family = NBItr, data = dt2, method = mixed(2, 10000))
summary(m.NB)
pars <- c(coef(m.NB, what = "mu"), coef(m.NB, what = "sigma"))
summary1 <- summary(m.NB)
summary(m.NB)
logLik(m.NB)
mu.NB <- exp(coef(m.NB))
sigma.NB <- exp(coefficients(m.NB, what = "sigma"))

newtheme <- theme_bw() + theme(
  axis.line = element_line(colour = "black"),
  axis.text.x = element_text(margin = margin(t = 0.25, unit = "cm")),
  axis.text.y = element_text(
    margin = margin(r = 0.25, unit = "cm"),
    size = 10,
    vjust = 0.5,
    hjust = 0.5
  ),
  axis.ticks.length = unit(-0.1, "cm"),
  plot.title = element_text(hjust = 0.5),
  legend.direction = "vertical",
  legend.position = c(.95, .99),
  legend.justification = c("right", "top"),
  legend.box.just = "right",
  legend.text = element_text(size = 10)
)

# par(mfrow = c(1, 2), tcl = 0.3, mgp = c(1.5,0,0))
# qqnorm(res.death, ylim = c(-3,3), xlim = c(-3,3), main = '')
# abline(0,1, col = 'red')

res.death <- residuals(m.NB, what = "z-scores")
df <- data.table(y = res.death)
v1 <- ggplot(df, aes(sample = y)) +
  stat_qq_point() +
  # stat_qq_band(bandType = "ks", fill = "#8DA0CB", alpha = 0.4, conf = 0.95) +
  stat_qq_line(col = "red", identity = TRUE) +
  newtheme +
  labs(title = "Causalities below the threshold", x = "Standard Normal Quantiles", y = "Sample Quantiles") +
  scale_x_continuous(
    limits = c(-3, 3),
    breaks = seq(-3, 3, by = 1)
  ) +
  scale_y_continuous(
    limits = c(-3, 3),
    breaks = seq(-3, 3, by = 1)
  ) +
  geom_abline(slope = 1, col = "red", lwd = 1)

# v1
# =========================================================================
# death > umin
# ==========================================================================
X1 <- model.matrix(~1, data = dtnew[y2 > umin])
X2 <- model.matrix(~1, data = dtnew[y2 > umin])
y2new <- dtnew[y2 > umin]$y2
GPD.MLE <- fevd(
  x = y2,
  scale.fun = ~1,
  shape.fun = ~1,
  threshold = umin, method = "MLE", use.phi = F,
  type = "GP", data = dtnew
)
GPD.MLE
# plot(GPD.MLE)
GPD.par <- GPD.MLE$results$par
pars <- GPD.MLE$results$par
GPD.hessian <- GPD.MLE$results$hessian
GPD.se <- sqrt(diag(solve(GPD.hessian)))
GPD.Z <- GPD.par / GPD.se ##  Z缁熻???
GPD.p <- ifelse(GPD.Z >= 0, pnorm(GPD.Z, lower = F) * 2, pnorm(GPD.Z) * 2) ## p???
cbind(GPD.par, GPD.se, GPD.p)

scale <- (X1 %*% pars[1:dim(X1)[2]])
shape <- X2 %*% pars[c((dim(X1)[2] + 1):(dim(X1)[2] + dim(X2)[2]))]
ufit <- 0
for (i in 1:length(y2new)) {
  ufit[i] <- evd::pgpd(y2new[i], loc = umin, scale = scale[i], shape = shape[i])
}
resGPD.death <- qnorm(ufit)
# qqnorm(resGPD.death, ylim = c(-3, 3), xlim = c(-3, 3),
#        main = '')
# abline(0, 1, col = 'red')

df <- data.table(y = resGPD.death)
v2 <- ggplot(df, aes(sample = y)) +
  stat_qq_point() +
  # stat_qq_band(bandType = "ks", fill = "#8DA0CB", alpha = 0.4, conf = 0.95) +
  stat_qq_line(col = "red", identity = TRUE) +
  newtheme +
  labs(title = "Causalities above the threshold", x = "Standard Normal Quantiles", y = "Sample Quantiles") +
  scale_x_continuous(
    limits = c(-3, 3),
    breaks = seq(-3, 3, by = 1)
  ) +
  scale_y_continuous(
    limits = c(-3, 3),
    breaks = seq(-3, 3, by = 1)
  ) +
  geom_abline(slope = 1, col = "red", lwd = 1)
# v2

v0 <- v1 + v2 + plot_layout(ncol = 2)
v0

# ======================================================================================
# GPD and negative binom
y <- dtnew$y2
X0 <- model.matrix(~1, data = dtnew)
X1 <- model.matrix(~1, data = dtnew) # GP
X2 <- model.matrix(~1, data = dtnew) # GP
par1 <- GPD.MLE$results$par
par2 <- c(coef(m.NB, what = "mu"), coef(m.NB, what = "sigma"))
p1 <- nrow(dt2) / nrow(dtnew)
scale <- X1 %*% par1[1:dim(X1)[2]]
shape <- X2 %*% par1[c((dim(X1)[2] + 1):(dim(X1)[2] + dim(X2)[2]))]
dtu2 <- data.table(
  mu = as.vector(exp(X0 %*% par2[1:dim(X0)[2]])),
  sigma = exp(par2[length(par2)]),
  scale = as.vector(X1 %*% par1[1:dim(X1)[2]]),
  shape = as.vector(X2 %*% par1[c((dim(X1)[2] + 1):(dim(X1)[2] + dim(X2)[2]))]),
  y = y, y_ = y - 1,
  y__ = y - 2
)
dtu2[y_ < 0]$y_ <- 0
dtu2[y__ < 0]$y__ <- 0
dtu2
u <- with(dtu2, {
  u2 <- u2_ <- u2__ <- u0 <- 0
  for (i in 1:length(y)) {
    if (y[i] <= umin) {
      u2[i] <- p1 * as.vector(pNBItr(y[i], mu = mu[i], sigma = sigma[i]))
    } else {
      u2[i] <- p1 + (1 - p1) * evd::pgpd(y[i], loc = umin, scale = scale[i], shape = shape[i])
    }

    if (y_[i] <= umin) {
      u2_[i] <- p1 * as.vector(pNBItr(y_[i], mu = mu[i], sigma = sigma[i]))
    } else {
      u2_[i] <- p1 + (1 - p1) * evd::pgpd(y_[i], loc = umin, scale = scale[i], shape = shape[i])
    }

    if (y__[i] <= umin) {
      u2__[i] <- p1 * as.vector(pNBItr(y__[i], mu = mu[i], sigma = sigma[i]))
    } else {
      u2__[i] <- p1 + (1 - p1) * evd::pgpd(y__[i], loc = umin, scale = scale[i], shape = shape[i])
    }
    u0 <- pNBItr(umin, mu = mu[i], sigma = sigma[i])
  }
  u <- cbind(u2, u2_, u2__, u0)
  u
})
u2 <- u[, 1]
u2_ <- u[, 2]
u2__ <- u[, 3]
u2_[which(dtnew$y2 - 1 < 0)] <- 0
u2__[which(dtnew$y2 - 2 < 0)] <- 0
dtu2$u2 <- u2
dtu2$u2_ <- u2_
dtu2$u2__ <- u2__
dtu2

# =========================================================================================
# density of y2 --------------------------------------------------------------------------
dtu2$f2 <- with(dtu2, {
  f <- 0
  for (i in 1:length(y)) {
    if (y[i] <= umin) {
      f[i] <- p1 * as.vector(dNBItr(y[i], mu = mu[i], sigma = sigma[i]))
    } else {
      f[i] <- (1 - p1) * evd::dgpd(y[i], loc = umin, scale = scale[i], shape = shape[i])
    }
  }
  f
})
f2 <- dtu2$f2

dtnew$f1 <- f1
dtnew$f2 <- dtu2$f2
dtnew$u1 <- u1
dtnew$u2 <- dtu2$u2
dtnew$u2_ <- dtu2$u2_

# plot
dtnew[, magnitude.f := cut(magnitude, c(3.9, 5.2, 6, 9))]
dtnew[, .(corc = cor(u1, u2)), by = magnitude.f]
summary(dtnew$magnitude)
table(dtnew$magnitude.f)
library(latex2exp)
df <- dtnew
m1 <- ggplot(df, aes(
  x = u1, y = u2, group = magnitude.f,
  col = magnitude.f,
  shape = magnitude.f
)) +
  geom_point() +
  theme_bw() +
  theme(
    axis.line = element_line(colour = "black"),
    axis.text.x = element_text(margin = margin(t = 0.25, unit = "cm")),
    axis.text.y = element_text(
      margin = margin(r = 0.25, unit = "cm"),
      size = 10,
      vjust = 0.5,
      hjust = 0.5
    ),
    axis.ticks.length = unit(-0.1, "cm"),
    plot.title = element_text(hjust = 0.5),
    # legend.direction = 'vertical',
    # legend.position = c(.95, .99),
    # legend.justification = c("right", "top"),
    # legend.box.just = "right",
    legend.text = element_text(size = 10)
  ) +
  labs(
    title = "Scatterplot of Losses-Casualties",
    x = TeX("$u_1$"),
    y = TeX("$u_2$")
  ) +
  # scale_colour_discrete(breaks = c(1,2,3)) +
  scale_x_continuous(
    limits = c(0, 1),
    breaks = seq(0, 1, by = 0.2)
  ) +
  scale_y_continuous(
    limits = c(0, 1),
    breaks = seq(0, 1, by = 0.2)
  ) +
  labs(col = "magnitude", shape = "magnitude")

m1

# write.csv(dtnew, "data-raw/earth-model.csv")
earthqCHI <- dtnew
earthqCHI$magnitude.f <- NULL
usethis::use_data(earthqCHI, overwrite = TRUE)


###################################################################################
# R-script submitted as Supplementary Information to Seebens et al. (2016) No
# saturation in the accumulation of alien species worldwide. Nature Communications ....
#
# The script reproduces the modelling results shown in Fig. 5 of the article.
#
# The model implemented here describes the temporal development of the
# accumulation of alien species on an island, which were randomly depicted
# from an arbitrary mainland community. The probability of depicting a species
# increased exponentially during the simulation to account for increases in
# propagule and colonisation pressures due to e.g. increases of trade volumes.
# For further details, consult the article.
#
# The code is free of use as long as the article is properly cited.
#
# Author of code: Hanno Seebens, Frankfurt, Germany
# 25. August, 2016
###################################################################################

graphics.off() # close windows
rm(list=ls()) # clear R environment

options(scipen=5)

##### Defintion of objects/variables for simulation ##############################

t_max <- 50000 # max simulation time
res <- 1/100 # resolution of time steps
n_steps <- t_max*1/res # total simulation time steps

n_bins <- 100 # n_spec/bins = number of bins

n_spec <- 10^seq(2,5,0.5) # species number for different model scenarios

## define temporal variation of propagule pressure ###################
m <- rev(exp(-0.7*seq(0,10,length.out=n_steps))) # exponential increase
m <- m-min(m) # normalise
m <- m/max(m) # normalise

## define x-axis for plotting
timeaxis <- seq(1,t_max,length.out=n_steps) # for plotting

## define object to store temporal dynamics of species accumulation on island:
## an empty matrix (rows: time steps, columns: different scenarios)
island <- matrix(0,nr=n_steps,nc=length(n_spec)+1)
island[,1] <- 1:(n_steps)

## define object to store the shape of the communities
all_pop <- matrix(0,nr=n_bins,nc=length(n_spec))

###### SIMULATION #######################################################################

out_list <- list() # output file
x <- 0 # counter
for (i in 1:length(n_spec)){ # loop through all scenarios consisting of different community sizes
  x <- x + 1 # increase counter

  ## define mainland community from a log-normal distribution
  specabund <- dlnorm((seq(0.1,2,length.out=n_bins)),meanlog=-1,sdlog=1)*100000000
  axis1 <- seq(10,1000,length.out=n_bins) # for plotting
  specabund <- ceiling(specabund) # round values to avoid decimals
  specabund <- round(specabund/sum(specabund)*n_spec[i]) # rescale numbers

  ## extract species numbers and abundances
  tot_spec <- sum(specabund) # number of species
  abundances <- rep(axis1,round(specabund)) # set abundances
  tot_abund <- sum(abundances) # number of individuals
  all_pop[,x] <- specabund # store community
  print(tot_spec)
  print(tot_abund)

  #### simulation ############################################################################
  for (t in 1:n_steps){ # loop through time steps

    ## select individual from mainland community and transfer it on the island
    if (runif(1)<m[t]){ # determine if new individual arrives, depending on propagule pressure m at time t
      ind <- runif(1)*tot_abund # if individual arrives, determine new individual
      spec <- max(which(c(0,cumsum(abundances))<=ind)) # select species accordingly
      island[t,x+1] <- spec # store species entry at time t and scenario x
    }
  }

  ## consider an Allee effect ###############################################################
  ## A species is only considered to be able to establish a population on the island
  ## if certain number of individuals (defined in variable 'allee') exists simultaneously
  ## during a time window of size 'window'. That is, a species is considered as established on the
  ## island if the number of individuals of that species living simultaneously on the island
  ## within the time window 'window' exceeds the Allee threshold 'allee'.

  data <- as.integer(island[,x+1]) # time series of species accumulation without the consideration of an Allee effect
  window <- 100000 # time window for the calculation of total population size
  step <- 1 # time step for the assessments of Allee effects (each time)
  allee <- 10 # minimum population for an established population, Allee threshold

  total <- length(data) # length of data set
  spots <- seq(from=1, to=(total-window), by=step) # starting values of the time windows
  out <- matrix(NA,nc=1,nr=tot_spec) # results file

  isl_spec <- 0
  for(j in which(data[1:(length(data)-window)]!=0)){ # loop through time series and check moving time windows

    dat <- data[spots[j]:(spots[j]+window)] # extract individuals of all species during the respective time window
    tab <- tabulate(dat[dat!=0]) # calculate population sizes for all species
    abund_spec <- which(tab>allee) # check if population sizes exceed Allee threshold

    new_spec <- abund_spec[!abund_spec%in%isl_spec] # select species, which populations exceed the Allee threshold
    out[new_spec] <- j # store the date, when species was recognised to have an established population on the island
    isl_spec <- (c(isl_spec,new_spec)) # store all species on the island
    if (length(isl_spec)==tot_spec) break # break if all species reached the island
  }
  out_list[[x]] <- out # store result
  ######################################################################################

  ## process time series without Allee effect
  dupl <- duplicated(island[,x+1]) # identify duplicated entries of species in time series
  island[which(dupl),x+1] <- 0 # set all duplicated entries to zero (i.e., remove all entries after the first occurrence of that species)
  island[which(!dupl),x+1] <- 1 # set all species numbers to 1 (species identity is not required any more)
  island[,x+1] <- cumsum(island[,x+1]) # calculate accumulation of species numbers on the island
}
out_ls <- lapply(out_list,function(s) sort(s,na.last=T)) # sort time when species exceeded the Allee threshold (for plotting)

### PLOT results (Fig. 5 in the main text) ###############################################################################################

x11(width=3.5,height=6) # define size of plot window
layout(matrix(c(1:3),nr=3)) # define layout of plot
op <- par(oma=c(0,3.5,0,1),mar=c(3,2,0.5,0.5),las=1,cex=0.9,mgp=c(2.5,0.35,0),tck=-0.02,xaxs="i",yaxs="i") # some additional options

## panel a: plot communities on mainland, one for each model scenario ##################################
matplot(axis1,all_pop,type="p",log="yx",pch=1,cex=0.7,col=rainbow(length(n_spec),start=0,end=4/6),lty=1,ylab="Species",xlab="",xaxt="n",yaxt="n")
axis(1,at=10^seq(0,4,1))
axis(1,at=(1:10*rep(10^seq(0,4,1)/10,each=10)),labels=F,tcl=-0.3)
axis(2,at=10^seq(0,5,1),las=1)
axis(2,at=(1:10*rep(10^seq(0,5,1)/10,each=10)),labels=F,tcl=-0.3)
mtext("Individuals per species",side=1,line=1.5)
mtext("a",side=3,adj=-0.45,line=-0.5,font=2)
mtext("Species",side=2,line=2.5,cex=0.9,las=0)
mtext("Mainland",side=2,las=0,cex=1,font=2,line=4)

## panel b: plot temporal development of propagule pressure (exponential increase) #####################
plot(timeaxis[seq(1,n_steps,length.out=200)],m[seq(1,n_steps,length.out=200)],xlim=c(0,t_max),ylim=c(0,1),xlab="",ylab="Rate of introduction",type="l")
mtext("Simulation time",side=1,line=2)
mtext("b",side=3,adj=-0.45,line=-0.5,font=2)
mtext("Probability",side=2,line=2.5,cex=0.9,las=0)
mtext("Translocation",side=2,las=0,cex=1,font=2,line=4)

## panel c: plot temporal development of species accumulation on island ################################
## without Allee effect
matplot(seq(1,t_max,length.out=200),island[seq(1,n_steps,length.out=200),(1:length(n_spec))+1],yaxt="n",type="l",xlim=c(0,t_max),ylim=c(1,100000),log="y",col=rainbow(length(n_spec),start=0,end=4/6),lty=1,xlab="",ylab="Species")
mtext("Simulation time",side=1,line=2)
axis(2,at=10^seq(0,5,1),las=1)
axis(2,at=(1:10*rep(10^seq(0,5,1)/10,each=10)),labels=F,tcl=-0.3)

## with Allee effect
for (i in 1:length(out_ls)){
  lines(out_ls[[i]]*res,1:length(out_ls[[i]]),lty=2,col=rainbow(length(n_spec),start=0,end=4/6)[i])
}
mtext("c",side=3,adj=-0.45,line=-0.5,font=2)
mtext("Species",side=2,line=2.5,cex=0.9,las=0)
mtext("Island",side=2,las=0,cex=1,font=2,line=4)

par(op)

information/Seebens - 2017 - No saturation in the accumulation of alien species/Rcode_Seebens-etal_InvasionModel_Saturation_MAIN.r


#---------------------------------------------------------------------
# cep  --  Cepstrally Smoothed Spectrum
#
# Calculates a cepstrally smoothed spectrum for the input signal 's'
# with at most 'b' real cepstrum coefficients retained and all others
# set to zero.
#
# This function assumes that the input is even length and returns
# N/2 + 1 points.
#--------------------------------------------------------------------
#
cep <- function(s, b=32)
{
  t <- fft(10*log10(abs(fft(s)) + 1 ))
  t[b:(length(s)-b)] = 0
  return(abs(fft(t,inverse=T))[1:(length(s)/2)]/length(s))
}


[[[[[
   Occam's razor---Concentration process.
   From computer C construct C' such that
   if P_C(x) >= 1/2^k, then
   then C' has a k+1 bit program for x.
   Hence H(x) <= -log_2 P_C(x) + c
   where c depends only on C, not on x.
]]]]]

define all-together

[this is used to avoid duplicate requirements for C']
let previous-requirements nil

[test case special-purpose computer C:]
[ignores odd bits, multiplies by ten until hits a 1]
[this C has many programs that do the same job!]
[[to put U here instead, let C be 'eval read-exp]]
let C '
   let (loop n)
      let ignore-it [be] read-bit [skip bit]
      if = 1 read-bit [then return] n
         [else] (loop * 10 n)
   (loop 10)

[stage n = 0, 1, 2, ... of overall concentration process]
[look at all n-bit programs for C, run them for time n]
[merge (output,multiplicity) pairs, emit requirements for C']
let (stage n)
   let previous-requirements
      (make-requirements debug (how-many? nil debug n))
   (stage + n 1)

[produce (output,multiplicity) pairs]
[by running all n-bit programs on C for time n]
let (how-many? p n)
   if = n length p

      [run program p for time n]
      let v try n [U => 'eval read-exp] C p
      if = success car v

          [program ran to completion]
          [indicate that it produces]
          [its output with multiplicity one]
          cons cons cadr v cons 1 nil
               nil

          [otherwise program failed]
          nil
          [empty list of (output,multiplicity) pairs]

      [otherwise use recursion to combine multiplicities]
      (merge (how-many? cons 0 p n)
             (how-many? cons 1 p n)
      )

[add one (output,multiplicity) pair to a list of such pairs]
let (merge1 pair list)
   if  atom list     cons pair nil
   let first-in-list car  list
   let rest-of-list  cdr  list
   let output        car  pair
   let multiplicity  cadr pair
   let output2       car  first-in-list
   let multiplicity2 cadr first-in-list
   if = output output2
      [= -> combine multiplicities]
      cons cons output cons + multiplicity multiplicity2 nil
           rest-of-list
      [!= -> don't combine multiplicities]
      cons first-in-list
           (merge1 pair rest-of-list)

[combine two lists of (output,multiplicity) pairs]
let (merge list list2)
   if atom list list2
   (merge1 car list (merge cdr list list2))

[exponent in highest power of 2 <= n, n != 0]
let (log2 n)
   let (loop power exponent)
      let new-power    + power power [double it]
      let new-exponent + 1 exponent  [add 1 to it]
      if > new-power n [then return] exponent
         [else] (loop new-power new-exponent)
   (loop [initial power of two] 1 [initial exponent of 2] 0)

let (make-requirements list-of-pairs)
   if  atom list-of-pairs  previous-requirements
   let first-pair     car  list-of-pairs
   let list-of-pairs  cdr  list-of-pairs
   let output         car  first-pair
   let multiplicity   cadr first-pair
   let kraft-requirement
       cons output cons - + n 1 (log2 multiplicity) nil
   let previous-requirements (make-requirements list-of-pairs)
   [keep only first appearance of requirement]
   if (is-in? kraft-requirement previous-requirements)
      previous-requirements
   cons debug display kraft-requirement previous-requirements

let (is-in? x list) [is x in list?]
   if atom list     false
   if = x car list  true
   (is-in? x cdr list)

[HERE GOES!]
(stage 0)

define      all-together
value       ((' (lambda (previous-requirements) ((' (lambda (C
            ) ((' (lambda (stage) ((' (lambda (how-many?) (('
            (lambda (merge1) ((' (lambda (merge) ((' (lambda (
            log2) ((' (lambda (make-requirements) ((' (lambda
            (is-in?) (stage 0))) (' (lambda (x list) (if (atom
             list) false (if (= x (car list)) true (is-in? x (
            cdr list))))))))) (' (lambda (list-of-pairs) (if (
            atom list-of-pairs) previous-requirements ((' (lam
            bda (first-pair) ((' (lambda (list-of-pairs) ((' (
            lambda (output) ((' (lambda (multiplicity) ((' (la
            mbda (kraft-requirement) ((' (lambda (previous-req
            uirements) (if (is-in? kraft-requirement previous-
            requirements) previous-requirements (cons (debug (
            display kraft-requirement)) previous-requirements)
            ))) (make-requirements list-of-pairs)))) (cons out
            put (cons (- (+ n 1) (log2 multiplicity)) nil)))))
             (car (cdr first-pair))))) (car first-pair)))) (cd
            r list-of-pairs)))) (car list-of-pairs)))))))) ('
            (lambda (n) ((' (lambda (loop) (loop 1 0))) (' (la
            mbda (power exponent) ((' (lambda (new-power) (('
            (lambda (new-exponent) (if (> new-power n) exponen
            t (loop new-power new-exponent)))) (+ 1 exponent))
            )) (+ power power)))))))))) (' (lambda (list list2
            ) (if (atom list) list2 (merge1 (car list) (merge
            (cdr list) list2)))))))) (' (lambda (pair list) (i
            f (atom list) (cons pair nil) ((' (lambda (first-i
            n-list) ((' (lambda (rest-of-list) ((' (lambda (ou
            tput) ((' (lambda (multiplicity) ((' (lambda (outp
            ut2) ((' (lambda (multiplicity2) (if (= output out
            put2) (cons (cons output (cons (+ multiplicity mul
            tiplicity2) nil)) rest-of-list) (cons first-in-lis
            t (merge1 pair rest-of-list))))) (car (cdr first-i
            n-list))))) (car first-in-list)))) (car (cdr pair)
            )))) (car pair)))) (cdr list)))) (car list))))))))
             (' (lambda (p n) (if (= n (length p)) ((' (lambda
             (v) (if (= success (car v)) (cons (cons (car (cdr
             v)) (cons 1 nil)) nil) nil))) (try n C p)) (merge
             (how-many? (cons 0 p) n) (how-many? (cons 1 p) n)
            ))))))) (' (lambda (n) ((' (lambda (previous-requi
            rements) (stage (+ n 1)))) (make-requirements (deb
            ug (how-many? nil (debug n)))))))))) (' ((' (lambd
            a (loop) (loop 10))) (' (lambda (n) ((' (lambda (i
            gnore-it) (if (= 1 (read-bit)) n (loop (* 10 n))))
            ) (read-bit))))))))) nil)

try 60 all-together nil

expression  (try 60 all-together nil)
debug       0
debug       ()
debug       1
debug       ()
debug       2
debug       ()
debug       3
debug       ((10 4))
debug       (10 2)
debug       4
debug       ((10 8))
debug       5
debug       ((10 16) (100 8))
debug       (100 3)
debug       6
debug       ((10 32) (100 16))
debug       7
debug       ((10 64) (100 32) (1000 16))
debug       (1000 4)
debug       8
debug       ((10 128) (100 64) (1000 32))
value       (failure out-of-time ((10 2) (100 3) (1000 4)))


#' Function for posterior sampling of DP mixture of logistic regressions for binary data.
#'
#' This function takes in a training data.frame and optional testing data.frame and performs posterior sampling. It returns posterior predictions and posterior clustering for training and test sets.
#' The function is built for binary outcomes.
#'
#' Please see \url{https://stablemarkets.github.io/ChiRPsite/index.html} for examples and detailed model and parameter descriptions.
#'
#' @import stats
#'
#' @param d_train A \code{data.frame} object with outcomes and model covariates/features. The outcome must be \code{numeric} coded with \code{1}s and \code{0}s. All features must be \code{as.numeric} - either continuous or binary with binary variables coded using \code{1} and \code{0}. Categorical features are not supported. We recommend standardizing all continuous features. NA values are not allowed and each row should represent a single subject, longitudinal data is not supported.
#' @param d_test Optional \code{data.frame} object containing a test set of subjects containing all variables specifed in \code{formula}. The same rules that apply to \code{d_train} apply to \code{d_test}.
#' @param formula Specified in the usual way, e.g. for \code{p=2} covariates, \code{y ~ x1 + x1}. All covariates - continuous and binary - must be \code{as.numeric} , with binary variables coded as \code{1} or \code{0}. We recommend standardizing all continuous features. NA values are not allowed and each row should represent a single subject, longitudinal data is not supported.
#' @param burnin integer specifying number of burn-in MCMC draws.
#' @param iter integer greater than \code{burnin} specifying how many total MCMC draws to take.
#' @param init_k Optional. integer specifying the initial number of clusters to kick off the MCMC sampler.
#' @param prop_sigma_b Optional. If you specified \code{p} covariates in \code{formula}, \code{p+1} regression parameters are sampled for the probability of the outcome being one using a Metropolis step.  \code{prop_sigma_b} is a \code{p+1} by \code{p+1} covariance matrix for the Metropolis proposal distribution.
#' @param beta_prior_mean Optional. If there are \code{p} covariates as length \code{p+1} \code{as.numeric} vector specifying mean of the Gaussian prior on the outcome model's conditional mean parameter vector. Default is regression coefficients from running logistic regression on the outcome.
#' @param beta_prior_var Optional. If there are \code{p} covariates as length \code{p+1} \code{as.numeric} vector specifying variance of the Gaussian prior on the outcome model's conditional mean parameter vector. The full covarince of the prior is set to be diagonal. This vector specifies the diagonal enteries of this prior covariance. Default is estimated variances from running logistic regression on the outcomes..
#' @param beta_var_scale Optional. A multiplicative constant that scales \code{beta_prior_var}. If you leave \code{beta_prior_mean} and \code{beta_prior_var} at their defaults, This constant toggles how wide new cluster parameters are dispersed around the observed data parameters.
#' @param mu_scale Optional. An numeric, scalar constant that controls how widely distributed new cluster continuous covariate means are distributed around the empirical covariate mean. Specifically, all continuous covariates are assumed to have Gaussian likelihood with Gaussian prior on their means. \code{mu_scale=2} specifies that the variance of the Gaussian prior is twice as large as the empirical variance.
#' @param tau_scale Optional. An numeric, scalar constant that controls how widely distributed new cluster continuous covariate variances are distributed around the empirical variance. Specifically, all continuous covariates are assumed to have Gaussian likelihood with Inverse Gamma prior on their variance. \code{tau_scale=2} specifies that the rate of the InvGamma prior is twice as large as the empirical variance.
#' @return Returns \code{predictions$train} and \code{cluster_inds$train}. \code{predictions$train} returns an \code{nrow(d_train)} by \code{iter - burnin} matrix of posterior predictions. \code{cluster_inds$train} returns an \code{nrow(d_train)} by \code{iter - burnin} matrix of cluster assignment indicators, which can be input into the function \code{cluster_assign_mode()} to compute posterior mode assignment. \code{predictions$test} and \code{cluster_inds$test} are returned if \code{d_test} is specified.
#' @keywords Dirichlet Process binary outcomes logistic
#' @examples
#' set.seed(1)
#' n<-1000 # simulate 1000 subjects
#'
#' # Cluster 1: 5 continuous covariates with mean 5, variance 5
#' x1 <- replicate(2,  rnorm(n/2, 10, 5) )
#'
#' # Cluster 2: 5 continuous covariates with mean 5, variance 5
#' x2 <- replicate(2,  rnorm(n/2, -10, 5))
#'
#' # outcome for both clusters
#' y <- numeric(length = n)
#' y[1:500] <- rbinom(500, 1, pnorm(-5 + x1 %*% matrix(c(-2,2), ncol=1) )  )
#' y[501:1000] <- rbinom(500, 1, pnorm(5 + x2 %*% matrix(c(2,-2), ncol=1)  ) )
#'
#' # combine into data.frame
#' d <- data.frame(rbind(x1,x2), y)
#'
#' # normalize covariates...helps for numerical stability.
#' d$X1 <- scale(d$X1)
#' d$X2 <- scale(d$X2)
#'
#' set.seed(100)
#'
#' # split data into training (800 obs) and testing (200 obs)
#' test_ids <- sample(1:1000, 200, replace = FALSE )
#' d_test <- d[test_ids, ]
#' d_train <- d[-test_ids, ]
#'
#' logit_res <- PDPMix(d_train = d_train, d_test = d_test,
#'                     formula = y ~ X1 + X2,
#'                     burnin = 100, iter = 200,
#'                     beta_prior_var = rep(3, 3), # fairly flat priors
#'                     beta_prior_mean = rep(0,3), # null centered priors
#'                     prop_sigma_b = diag(rep(.001, 3)) , # proposal covariance
#'                     init_k = 5, tau_scale = 3, mu_scale = 3)
#' @export
PDPMix<-function(d_train, formula, d_test=NULL, burnin=100, iter=1000,
                 beta_prior_mean=NULL, beta_prior_var=NULL,
                 init_k=10, beta_var_scale=1000, mu_scale=1, tau_scale=1,
                 prop_sigma_b = diag(rep(.025, nparams))){

  ###------------------------------------------------------------------------###
  #### 0 - Parse User Inputs                                                ####
  ###------------------------------------------------------------------------###
  # error checking user inputs
  if( missing(d_train) ){ stop("ERROR: must specify a training data.frame.") }

  x <- all.vars(formula[[3]]) # covariate names
  y <- all.vars(formula[[2]]) # outcome name

  nparams <- length(x) + 1

  func_args<-mget(names(formals()),sys.frame(sys.nframe()))
  error_check(func_args, 'PDP')

  if(!is.null(d_test)){
    xt <- model.matrix(data=d_test,
                       object= as.formula(paste0('~ ',paste0(x, collapse = '+'))))
    nt <- nrow(xt)
  }

  x_type <- vector(length = length(x))
  for(v in 1:length(x)){
    if( length(unique(d_train[, x[v] ]))==2 ){
      x_type[v] <- 'binary'
    }else if(length(unique(d_train[,x[v]]))>2){
      x_type[v] <- 'numeric'
    }
  }

  store_l <- iter - burnin
  y <- d_train[,y]
  x_names <- x
  x <- model.matrix(data=d_train, object = formula )

  n<-nrow(x)

  xall_names <- x_names
  nparams_all <- length(xall_names)
  xall <- d_train[,xall_names]

  all_type_map <- c(x_type)
  names(all_type_map) <- c(x_names)
  xall_type <- all_type_map[as.character(xall_names)]

  xall_names_bin <- xall_names[xall_type == 'binary']
  xall_names_num <- xall_names[xall_type == 'numeric']

  # parse numeric versus binary variables for outcome model
  n_bin_p <- sum(x_type=='binary')
  n_num_p <- sum(x_type=='numeric')

  ## calibrate priors
  if(is.null(beta_prior_mean)){
    reg <- glm(data=d_train, formula = formula, family = binomial('probit'))
    beta_prior_mean <- reg$coefficients
  }

  if(is.null(beta_prior_var)){
    reg <- glm(data=d_train, formula = formula, family = binomial('probit'))
    beta_prior_var <- beta_var_scale*diag(vcov(reg))
  }

  prior_means <- apply(x[,xall_names_num, drop=F], 2, mean)
  names(prior_means) <- xall_names_num

  prior_var <- mu_scale*apply(x[,xall_names_num, drop=F], 2, var)
  names(prior_var) <- xall_names_num

  g2 <- rep(2, n_num_p)
  names(g2) <- xall_names_num

  b2 <- tau_scale*apply(x[,xall_names_num, drop=F], 2, var)
  names(b2) <- xall_names_num

  K <- init_k
  a <- 1

  ###------------------------------------------------------------------------###
  #### 1 - Create Shells for storing Gibbs Results                          ####
  ###------------------------------------------------------------------------###

  alpha <- numeric(length = store_l)

  curr_class_list <- 1:K
  class_names <- paste0('c',curr_class_list)

  c_shell<-matrix(NA, nrow=n, ncol=1) # shell for indicators

  class_shell <- matrix(NA, nrow=n, ncol=store_l)

  beta_shell <- matrix(NA, nrow = nparams, ncol = K)
  colnames(beta_shell) <- class_names
  rownames(beta_shell) <- colnames(x)

  c_b_shell <- vector(mode = 'list', length = n_bin_p) # -1 for trt
  names(c_b_shell) <- xall_names_bin

  c_n_shell <- vector(mode = 'list', length = n_num_p)
  names(c_n_shell) <- xall_names_num

  for( p in xall_names_bin ){
    c_b_shell[[p]] <- matrix(NA, nrow = 1, ncol = K)

    c_b_shell[[p]][1,] <- rep(.5, K)

    colnames(c_b_shell[[p]]) <- class_names
  }

  for( p in xall_names_num ){
    c_n_shell[[p]] <- list(matrix(NA, nrow=1, ncol=K),
                           matrix(NA, nrow=1, ncol=K))

    c_n_shell[[p]][[2]][1, ] <- rep(0, K)
    c_n_shell[[p]][[2]][1, ] <- rep(20^2, K)

    colnames(c_n_shell[[p]][[1]]) <- class_names
    colnames(c_n_shell[[p]][[2]]) <- class_names
  }

  c_b_new <- numeric(length = n_bin_p)
  names(c_b_new) <- xall_names_bin

  c_n_new <- matrix(NA, nrow = 2, ncol = n_num_p)
  colnames(c_n_new) <- xall_names_num

  if(!is.null(d_test)){
    c_b_new_test <- numeric(length = n_bin_p)
    names(c_b_new_test) <- xall_names_bin

    c_n_new_test <- matrix(NA, nrow = 2, ncol = n_num_p)
    colnames(c_n_new_test) <- xall_names_num

    predictions <- vector(mode = 'list', length = 2)
    predictions[[1]] <- matrix(nrow = n, ncol = store_l)
    predictions[[2]] <- matrix(nrow = nt, ncol = store_l)
    names(predictions) <- c('train','test')

    cluster_inds <- vector(mode = 'list', length = 2)
    cluster_inds[[1]] <- matrix(nrow = n, ncol = store_l)
    cluster_inds[[2]] <- matrix(nrow = nt, ncol = store_l)
    names(cluster_inds) <- c('train','test')
  }else{
    predictions <- vector(mode = 'list', length = 1)
    predictions[[1]] <- matrix(nrow = n, ncol = store_l)
    names(predictions) <- c('train')

    cluster_inds <- vector(mode = 'list', length = 1)
    cluster_inds[[1]] <- matrix(nrow = n, ncol = store_l)
    names(cluster_inds) <- c('train')
  }

  ###------------------------------------------------------------------------###
  #### 2 - Set Initial Values                                               ####
  ###------------------------------------------------------------------------###

  # initially assign everyone to one of K clusters randomly with uniform prob
  c_shell[,1] <- sample(x = class_names, size = n,
                        prob = rep(1/K,K), replace = T)

  beta_start <- matrix(0, nrow=nparams, ncol=K)
  colnames(beta_start) <- class_names

  for(k in class_names){
    beta_shell[,k] <- beta_prior_mean
  }

  for(p in xall_names_bin ){
    c_b_shell[[p]][1,] <- rep(1, K)
  }

  for(p in xall_names_num ){
    c_n_shell[[p]][[2]][ 1 , ] <- rep(0, K)
    c_n_shell[[p]][[2]][ 1 , ] <- rep(20^2, K)
  }

  ###------------------------------------------------------------------------###
  #### 3 - Gibbs Sampler                                                    ####
  ###------------------------------------------------------------------------###
  message_seq <- seq(2, iter, round(iter/20) )
  cat(paste0('Iteration ',2,' of ', iter,' (burn-in) \n'))
  message_step <- (iter)/10
  for(i in 2:iter){

    ## print message to user
    if( i %% message_step == 1 ) cat(paste0('Iteration ',i,' of ',
                                            iter,
                                            ifelse(i>burnin,' (sampling) ',
                                                   ' (burn-in)') ,
                                            '\n'))

    # compute size of each existing cluster
    class_ind<-c_shell[,1]
    nvec<-table(factor(class_ind,levels = class_names) )

    ###----------------------------------------------------------------------###
    #### 3.1 - update Concentration Parameter                               ####
    ###----------------------------------------------------------------------###

    a_star <- rnorm(n = 1, mean =  a, sd = 1)
    if(a_star>0){
      r_num <- cond_post_alpha(a_star, n, K, nvec)
      r_denom <- cond_post_alpha(a, n, K, nvec)
      r <- exp(r_num - r_denom)
      accept <- rbinom(1,1, min(r,1) )==1
      if(accept){ a <- a_star }
    }

    ###----------------------------------------------------------------------###
    #### 3.2 - update parameters conditional on classification              ####
    ###----------------------------------------------------------------------###
    K <- length(unique(class_names))
    for(k in class_names){ # cycle through existing clusters - update parameters

      ck_ind <- class_ind == k

      y_ck <- y[ck_ind]

      x_ck <- x[ck_ind,, drop=FALSE]

      beta_shell[ ,k] <- metrop_hastings(x_0 = beta_shell[ ,k], iter = 1,
                                         log_post_density = cond_post_beta_pdp,
                                         y= y, xm = x_ck,
                                         prop_sigma = prop_sigma_b,
                                         beta_prior_mean = beta_prior_mean,
                                         beta_prior_var = beta_prior_var)[[1]]

      for( p in xall_names_bin ){
        c_b_shell[[p]][1, k] <- rcond_post_mu_trt(x_ck = x_ck[, p])
      }

      for( p in xall_names_num ){
        c_n_shell[[p]][[1]][1,k] <- rcond_post_mu_x(x_ck = x_ck[, p],
                                                    phi_x = c_n_shell[[p]][[2]][1,k],
                                                    lambda = prior_means[p],
                                                    tau = prior_var[p])

        c_n_shell[[p]][[2]][1,k] <- rcond_post_phi(mu_x = c_n_shell[[p]][[1]][1, k],
                                                   x = x_ck[ , p],
                                                   g2 = g2[p], b2 = b2[p])
      }

    }

    ###----------------------------------------------------------------------###
    #### 3.3 - update classification conditional on parameters              ####
    ###----------------------------------------------------------------------###

    ## draw parameters for potentially new cluster from priors
    ### draw beta, gamma, phi, covariate parameters

    beta_new <- mvtnorm::rmvnorm(n = 1, mean = beta_prior_mean,
                                 sigma = diag(beta_prior_var) )

    for(p in xall_names_bin){
      c_b_new[p] <- rbeta(n = 1, shape1 = 1, shape2 = 1)
    }

    for(p in xall_names_num){
      c_n_new[1, p] <- rnorm(n = 1, prior_means[p], sqrt(prior_var[p]) )
      c_n_new[2, p] <- invgamma::rinvgamma(n = 1, shape = g2[p], rate = b2[p])
    }

    name_new <- paste0('c', max(as.numeric(substr(class_names, 2,10))) + 1)

    ## compute post prob of membership to existing and new cluster,
    ## then classify

    weights <- class_update_train_pdp(n = n, K = length(class_names), alpha = a,
                                      name_new =  name_new,
                                      uniq_clabs = colnames(beta_shell),
                                      clabs = class_ind,

                                      y = y, x = x,
                                      x_cat_shell = c_b_shell , x_num_shell = c_n_shell,

                                      ## col number of each covar...index with base 0
                                      cat_idx=xall_names_bin, num_idx=xall_names_num,

                                      beta_shell = beta_shell,

                                      beta_new=beta_new,
                                      cat_new = c_b_new, num_new=c_n_new)

    c_shell[,1] <- apply(weights, 1, FUN = sample,
                         x=c(colnames(beta_shell), name_new), size=1, replace=T)

    ###----------------------------------------------------------------------###
    #### 4.0 - update shell dimensions as clusters die/ are born            ####
    ###----------------------------------------------------------------------###

    new_class_names <- unique(c_shell[,1])
    K_new <- length(new_class_names)

    # Grow shells by adding labels/parameters of new clusters
    new_class_name <- setdiff(new_class_names, class_names)
    if(length(new_class_name)>0){ # new cluster was born

      beta_shell <- cbind(beta_shell, t(beta_new) )
      colnames(beta_shell)[K+1] <- new_class_name

      for(p in xall_names_bin ){
        c_b_shell[[p]] <- cbind( c_b_shell[[p]], c_b_new[p] )
        colnames(c_b_shell[[p]])[K+1] <- new_class_name
      }

      for(p in xall_names_num ){
        c_n_shell[[p]][[1]] <- cbind(c_n_shell[[p]][[1]], c_n_new[1, p])
        colnames(c_n_shell[[p]][[1]])[K+1] <- new_class_name

        c_n_shell[[p]][[2]] <- cbind(c_n_shell[[p]][[2]], c_n_new[2, p])
        colnames(c_n_shell[[p]][[2]])[K+1] <- new_class_name
      }
    }

    # shrink shells by deleting labels of clusters that have died.
    dead_classes <- setdiff(class_names, new_class_names)
    if(length(dead_classes) > 0){ # clusters have died
      beta_shell <- beta_shell[,! colnames(beta_shell) %in% dead_classes, drop=F]

      for(p in xall_names_bin){
        c_b_shell[[p]] <- c_b_shell[[p]][, ! colnames(c_b_shell[[p]]) %in% dead_classes, drop=F]
      }

      for(p in xall_names_num){
        c_n_shell[[p]][[1]] <- c_n_shell[[p]][[1]][, ! colnames(c_n_shell[[p]][[1]]) %in% dead_classes, drop=F]
        c_n_shell[[p]][[2]] <- c_n_shell[[p]][[2]][, ! colnames(c_n_shell[[p]][[2]]) %in% dead_classes, drop=F]
      }
    }

    K <- K_new
    class_names <- new_class_names

    if( i > burnin ){

      ###--------------------------------------------------------------------###
      #### 5.0 - Predictions on a Training and Test set & Store Results     ####
      ###--------------------------------------------------------------------###

      if(!is.null(d_test)){
        name_new_test<-paste0('c', max(as.numeric(substr(class_names,2,10)))+1)

        for(p in xall_names_bin){
          c_b_new_test[p] <- rbeta(n = 1, shape1 = 1, shape2 = 1)
        }

        for(p in xall_names_num){
          c_n_new_test[1, p] <- rnorm(n = 1, prior_means[p], sqrt(prior_var[p]) )
          c_n_new_test[2, p] <- invgamma::rinvgamma(n = 1,shape = g2[p], rate = b2[p])
        }

        beta_new <- mvtnorm::rmvnorm(n = 1, mean = beta_prior_mean,
                                     sigma = diag(beta_prior_var) )

        weights_test <- class_update_test_pdp(n = nt, K = length(class_names) ,
                                              alpha =a,
                                              name_new = name_new_test,
                                              uniq_clabs = colnames(beta_shell),
                                              clabs = c_shell[,1],
                                              x = xt,
                                              x_cat_shell = c_b_shell,
                                              x_num_shell = c_n_shell,
                                              cat_idx = xall_names_bin,
                                              num_idx = xall_names_num,
                                              cat_new = c_b_new_test,
                                              num_new = c_n_new_test)

        c_shell_test <- apply(weights_test, 1, FUN = sample,
                              x=c(colnames(beta_shell), name_new_test),
                              size=1, replace=T)

        test_pred <- post_pred_draw_test_pdp(n=nt, x=xt, pc=c_shell_test,
                                             beta_shell = beta_shell,
                                             name_new = name_new_test,
                                             beta_new = beta_new)

        train_pred<-post_pred_draw_train_pdp(n=n, x=x, pc=c_shell[,1],
                                             beta_shell = beta_shell)

        # cluster indicators
        cluster_inds[['train']][, i-burnin] <- c_shell[,1]
        cluster_inds[['test']][, i-burnin] <- c_shell_test

        # predictions
        predictions[['train']][, i-burnin ] <- train_pred
        predictions[['test']][, i-burnin  ] <- test_pred
      }else{
        train_pred<-post_pred_draw_train_pdp(n=n, x=x, pc=c_shell[,1],
                                             beta_shell = beta_shell)

        # cluster indicators
        cluster_inds[['train']][, i-burnin] <- c_shell[,1]

        # predictions
        predictions[['train']][, i-burnin ] <- train_pred

      }
    }

  }

  results <- list(cluster_inds=cluster_inds,
                  predictions = predictions)
  cat('Sampling Complete.')
  return(results)
}