## Bayesian online change point detection and offline learning

## Inference in joint Gaussian distribution
## Get P(X1|X2=x2) where P(X1,X2) is jointly Gaussian
## returns the conditional mean and coviance matrix of P(x_1|x_2)
##
##
## x2; numeric, an sample of X2, satisfying length(x2)<D, D is the joint dimension.
## mu: numeric, length D mean vector. mu=c(mu_X1,mu_X2)
## Precision: DxD precision matrix, satisfying Precision = inverse(Sigma). At least one of Sigma and Precision should be non-NULL
## Sigma: DxD covariance matrix. At least one of Sigma and Precision should be non-NULL.
##    Sigma = | sigma1   sigma_12 |
##            | sigma_21 sigma2   |
##
## Examples:
## tmp <- matrix(runif(100),20,5)
## S <- crossprod(tmp)                 #some synthetic covariance matrix
## P <- solve(S)
## m <- runif(5)
## x2 <- runif(3)
## inferenceJointGaussian(x2 = x2,mu = m,Precision = P)
##
inferenceJointGaussian <- function(x2,mu,Precision=NULL,Sigma=NULL){
    if(is.null(Sigma) & is.null(Precision)) stop("Error in inferenceJointGaussian(): At least one of Sigma and Precision should be non-NULL")
    if(is.null(Precision)) Precision <- solve(Sigma)
    ## get the dimensions of x_1 and x_2
    D <- nrow(Precision)
    if(D!=length(mu)) stop("Error in inferenceJointGaussian(): Dimension doesn't mathc! nrow(Precision) != length(mu)")
    D1 <- D-length(x2)                  #dimension of X1
    if(D1<=0) stop("Error in inferenceJointGaussian(): length(mu2) should be strictly smaller than D")

    P11 <- Precision[1:D1,1:D1,drop=FALSE]
    P12 <- Precision[1:D1,(D1+1):D,drop=FALSE]

    Sigma12 <- solve(P11)
    mu12 <- as.vector(mu[1:D1] - Sigma12%*%P12%*%(x2-mu[(D1+1):D]))

    list(mu12=mu12,Sigma12=Sigma12)
}

## Gaussian posterior distribution (NIW prior)
## Get P(theta|X) where X is Gaussian observations and P(theta) is NIW (Normal-Inverse-Wishart) with prior parameter m0,k0,v0,S0
## returns the posterior parameter mN,kN,vN,SN
##
## x: observation matrix, or the ones that can be converted to matrix
## w: sample weights, default NULL
## m0,k0,v0,S0: prior Inverse-Whishart parameters
##
posteriorGaussian <- function(x,w=NULL,m0,k0,v0,S0){
    x <- as.matrix(x)
    if(is.null(w)) w <- rep(1,nrow(x))
    N <- sum(w)                         #effective number of samples

    ## sample sufficient statistics
    mu <- colSums(x*w)/N                #sample mean
    x <- sweep(x,2,mu,`-`)
    S <- t(w*x)%*%x                     #sample scatter matrix centered on sample mean

    ## posterior parameters
    kN <- k0+N
    mN <- (k0*m0+N*mu)/kN
    vN <- v0+N
    SN <- S0+S+k0*N/(kN)*(mu-m0)%*%t(mu-m0)

    list(mN=mN,kN=kN,vN=vN,SN=SN,N=N)
}

## Gaussian MAP esitmate (NIW prior)
## Get theta_MAP from NIW(theta),where theta_MAP = mod(NIW(theta))
## return the MAP estimates of mu and Sigma
##
##
## m,k,v,S: NIW parameters
mapGaussian <- function(m,k,v,S){
    D <- length(m)                      #dimension
    list(muMAP=m,
         sigmaMAP=S/(v+D+2))
}

## base::det() doesn't support scalar values, so write a wrapper around it
## this function is called in marginalLikelihoodGaussian_byPosterior()
det <- function(m){
    if(is.matrix(m)){
        base::det(m)
    }else if(is.vector(m)){
        base::prod(m)
    }
}

## Marginal likelihood of Gaussian observations (NIW prior)
## return the log marginal likelihood log P(x|model)
##
## x: observation matrix, or the ones that can be converted to matrix. each row of x is an observation
##
## Examples:
## m <- c(1,2,3)
## k <- 3
## v <- 3
## S <- matrix(c(2,0.1,0.2,0.1,2,0.3,0.2,0.3,2),3,3)
## x <- mvtnorm::rmvnorm(200,mean = c(2,3,2))
## marginalLikelihoodGaussian(x = x,m0=m,k0=k,v0=v,S0=S)
##
marginalLikelihoodGaussian <- function(x,m0,k0,v0,S0,LOG=TRUE){
    x <- as.matrix(x)
    ## get the posterior parameters and sample size
    post <- posteriorGaussian(x=x,m0=m0,k0=k0,v0=v0,S0=S0)
    ## put the posteriors into marginalLikelihoodGaussian_byPosterior()
    marginalLikelihoodGaussian_byPosterior(N=post$N,
                                           mN=post$mN,
                                           kN=post$kN,
                                           vN=post$vN,
                                           SN=post$SN,
                                           m0,k0,v0,S0,LOG=LOG)
}
## Marginal likelihood of Gaussian observations (NIW prior)
## same as marginalLikelihoodGaussian(), difference is the input x is replaced by it's posteriors
marginalLikelihoodGaussian_byPosterior <- function(N,mN,kN,vN,SN,m0,k0,v0,S0,LOG=TRUE){
    ## tested, stable
    p <- length(mN)                     #dimension

    ## method 1 use the equation
    logp <- -N*p/2*log(pi) + p/2*log(k0/kN) + v0/2*log(det(S0)) - vN/2*log(det(SN)) + lmvgamma(vN/2,p) - lmvgamma(v0/2,p)
    if(!LOG) logp <- exp(logp)

    ## method 2 use the t distribution
    ## ---to be completed---

    logp
}

## calculate the weighted scatter matrix
## copied from myTools.r
scatterMatrix <- function(x,w=1,mu=NULL){
    x <- as.matrix(x)
    if(length(w)==1L) w <- rep(w,nrow(x))
    if(!is.null(mu)){
        if(length(mu)!=ncol(x)) stop("Error in scatterMatrix(): mu must be the same length of observation dimensions")
        x <- sweep(x,2,mu,`-`)
    }
    t(w*x)%*%x
}

## function wrapper for setting a weakly informed (empirical) prior
## copied from myTools.r
priorNormal <- function(x){
    x <- as.matrix(x)
    D <- ncol(x)
    list(
        m0=colMeans(x),
        k0=0.001,                       #when k=0 the MAP of mu is the MLE of mu, but k=0 will result in a Inf in dNIW(), so use a small positive number instead of 0
        v0=ncol(x)+2,
        S0=diag(diag(scatterMatrix(x=x,w=1,mu=colMeans(x)))/nrow(x),nrow = D,ncol = D))
}

## log(sum(exp(l)))
## X: a logged matrix, nrow(X) = number of samples, ncol(X) = data dimension.
## return the log-sum-exp of each row of X
logsumexp <- function(X){
    X <- as.matrix(X)
    a <- apply(X,1,max)
    log(rowSums(exp(X-a)))+a
}

## log Multivariate Gamma Function
## Reference: https://en.wikipedia.org/wiki/Multivariate_gamma_function
##
## a: numeric vector
## p: integer, the dimension
##
lmvgamma <- function(a,p){
    sapply(a,function(ai){
        p*(p-1)/4*log(pi)+ sum(lgamma(ai+(1-(1:p))/2))
    },simplify = TRUE)
}

## log P(x_t | r_t, x^{(r_t)})
## return 1. the posterior parameters for
##     univariate normal: m and S
##     multivariate normal: m and S
##     ...
## and 2. the prediction probability
##     log P(x_t | r_t, x^{(r_t)})
##
## x: numeric matrix, or an object that can be coerced to a matrix. Observation sequence, each row of x is a TRANSPOSE of an observation
## prior: prior parameters, if model = "univariate-normal" or "multivariate-gaussian", prior should be a named list: list(m0,k0,v0,S0)
##                          if model = "poisson" or "exponential", prior should be a be a named list: list(scale)
##                          if model = "gamma" or "weibull", prior should be a named list:  list(shape,scale)
##                          if model = ...
##
## Example
## x <- rnorm(1000,mean = 10,sd = 5)
## out <- bcpPrediction(x=x,model = "univariate-normal",prior = list(m0=0,k0=1.2,v0=1.1,S0=2))
## names(out)
bcpPrediction <- function(x,model=c("univariate-gaussian","multivariate-gaussian"),prior=list(m0=NULL,k0=NULL,v0=NULL,S0=NULL)){
    model <- match.arg(model)
    ## generate the posterior parameters for all data
    x <- as.matrix(x)
    nPars <- 1L:nrow(x)             #number of cache parameters per time point
    D <- ncol(x)                    #dimension
    if(model=="univariate-gaussian"){
        m0 <- prior$m0
        k0 <- prior$k0
        v0 <- prior$v0
        S0 <- prior$S0
        out <- list(m=lapply(nPars,FUN = function(l){rep(0,l)}),
                    S=lapply(nPars,FUN = function(l){rep(0,l)}),
                    logS=lapply(nPars,FUN = function(l){rep(0,l)}),
                    p=lapply(nPars,FUN = function(l){rep(0,l)}))
        k <- 1:nrow(x)+k0             #place holder for k
        v <- 1:nrow(x)+v0             #place holder for v
        out$m[[1]] <- (m0*k0 + x[1])/k[1]
        out$S[[1]] <- S0+ x[1]^2+ k0*(m0^2) - k[1]*(out$m[[1]]^2)
        out$logS[[1]] <- log(out$S[[1]])                                  #temporary variable, log(S) is used in calculating the predicted probability
        logs0 <- log(S0)                                                  #constant number log(S0)
        d2logpi <- -D/2 * log(pi)                                         #constant number -D/2 * log(pi)
        logkii <- D/2 * log(c(k0,k[1L:(nrow(x)-1L)])/k)                   #constant vector D/2 * log(k_{i-1}/k_i)
        vi2 <- c(v0,v[1L:(nrow(x)-1L)])/2                                 #constant vector v_{i-1}/2
        v2 <- v/2                                                         #constant vector v_i/2
        loggammavii <- lgamma(v2) -lgamma(vi2)                            #constant vector lmvGamma(v_i/2) - lmvGamma(v_{i-1}/2)
        out$p[[1]] <- d2logpi + logkii[1] + vi2[1] * logs0 - v2[1]*out$logS[[1]] + loggammavii[1]
        if(nrow(x)>=2){
            for(i in nPars[-1L]){
                out$m[[i]] <- c((m0*k0 + x[i])/k[1],
                (out$m[[i-1]]*k[1L:(i-1L)] + x[i]) / k[2L:i])
                out$S[[i]] <- c(S0+ x[i]^2+ k0*(m0^2) - k[1]*(out$m[[i]][1]^2),
                                out$S[[i-1]]+ x[i]^2+ k[1L:(i-1L)]*(out$m[[i-1]]^2) - k[2L:i] * (out$m[[i]][-1]^2))
                out$logS[[i]] <- log(out$S[[i]])
                ## -D/2 log(pi) + D/2 log(k_{i-1}/k_i) + v_{i-1}/2 log(|S_{i-1}|) - v_i/2 log(|S_i|) + lmvGamma(v_i/2) - lmvGamma(v_{i-1}/2)
                out$p[[i]] <- d2logpi + logkii[1L:i] + vi2[1L:i] * c(logs0,out$logS[[i-1]]) - v2[1L:i]*out$logS[[i]] + loggammavii[1L:i]
            }
        }
    }else if(model=="multivariate-gaussian"){
        ## out <- list(m=lapply(nPars,FUN = function(l){matrix(0,l,D)}),
        ##             S=lapply(nPars,FUN = function(l){array(0,dim = c(l,D,D))}))
        stop("multivariate-gaussian observation not supported yet")
    }

    return(out)
}

## loglikelihood for Left Truncated and Right Censored data
## return:
##  log P(q+1|q) = log S(q+1) - log S(q)  and
##  log P(0|q) = log f(q+1) - log S(q)
##  as an nx2 matrix, n is the number of inputs, the first column is log P(q+1|q), second column is log P(0|q)
## q: numeric vector
## model.pars: parameters for the selected model
##             weibull: shape parameter and scale parameter()
##
## Example
## logLTRC(1:10,shape = 2,scale = 10)
logLTRC <- function(q,cpt_model=c("weibull","gamma","exponential"),shape=NULL,scale=NULL){
    cpt_model <- match.arg(cpt_model)
    if(cpt_model=="weibull"){
        ## lower.tail=FALSE is the survival function

        ## ## when assuming p(0|i) is dead at time t+1
        ## matrix(c(pweibull(q+1,shape=shape,scale=scale,lower.tail = FALSE,log.p = TRUE),dweibull(q+1,shape=shape,scale=scale,log = TRUE))-
        ##        pweibull(q,shape=shape,scale=scale,lower.tail = FALSE,log.p = TRUE),ncol = 2)

        ## ## when assuming p(0|i) is dead at time (t,t+1]
        out <- matrix(0,nrow = length(q),ncol = 2)
        out[,1] <- pweibull(q+1,shape=shape,scale=scale,lower.tail = FALSE,log.p = TRUE)-pweibull(q,shape=shape,scale=scale,lower.tail = FALSE,log.p = TRUE)
        out[,2] <- log(-expm1(out[,1])) #IMPORTANT if use log(1-exp(out[,1])) will result in log(0) in some of the parameter settings, to avoid underflow, use expm1(x) to replace exp(x)-1
        out
    }else if(cpt_model=="gamma"){
       stop("In LTRC(): ",cpt_model," not supported yet!")
    }else if(cpt_model=="exponential"){
        stop("In LTRC(): ",cpt_model," not supported yet!")
    }else{
        stop("In LTRC(): ",cpt_model," not supported yet!")
    }
}

## generate random shape and scale sample, for the change point distribution
## when cpt_model = "weibull"
##      gamma distribution with prior parameter shape and scale for inverse-scale parameter
##      uniform distribution with prior start and end for shape parameter
## other cpt_model are not yet supported
rcpt <- function(cpt_model=c("weibull","gamma","exponential"),cpt_prior=list()){
    cpt_model <- match.arg(cpt_model)
    if(cpt_model=="weibull"){
        shape=runif(1,cpt_prior$start,cpt_prior$end)
        scale = 1/rgamma(1,cpt_prior$shape,cpt_prior$scale) #since gamma is for inverse-scale, now I need to inverse it back
        c(shape,scale)
    }else{
        stop("In rcpt(): ",cpt_model," not supported yet!")
    }
}

## constructor of a "bcp" object, used in offline learning
## use S3 with environment to achieve "pass by reference"
##
## x: numeric matrix, or an object that can be coerced to a matrix. Observation sequence, each row of x is a TRANSPOSE of an observation
## breaks: the ending index of each segments. breaks = NULL is equivalent to breaks = nrow(x)
## cpt_model: name of the change point distribution
## obs_model: name of the observation distribution
## obs_prior: prior parameters for observation model
##                  if obs_model = "univariate-normal" or "multivariate-gaussian", prior should be a named list: list(m0,k0,v0,S0)
##                  if obs_model = "poisson" or "exponential", prior should be a be a named list: list(scale)
##                  if obs_model = "gamma" or "weibull", prior should be a named list:  list(shape,scale)
##                  if obs_model = ...
## shape: initial shape parameter for change point distribution, no need to specify
## scale: initial scale parameter for change point distribution, no need to specify
bcp <- function(x=NULL,breaks=NULL,cpt_model=c("weibull","gamma","exponential"),obs_model=c("univariate-gaussian","multivariate-gaussian","multinomial","poisson","exponential","gamma","linear"),obs_prior=list(),cpt_prior=list(),shape=NULL,scale=NULL){

    cpt_model <- match.arg(cpt_model)
    obs_model <- match.arg(obs_model)

    object <- new.env(parent=globalenv())

    x <- as.matrix(x)
    object$x <- x

    if(is.null(breaks)){
        object$breaks <- c(0,nrow(x))
        object$Nsegs <- 1               #number of segments
        object$segLengths <- nrow(x)    #length of each segment
    }else{
        if(any(breaks<=0 | breaks > nrow(x)) | is.unsorted(breaks)) stop("Error in bcp(): values in 'breaks' has to be ordered and range between [1,nrow(x))")
        object$breaks <- c(0,breaks)
        object$Nsegs <- length(object$breaks)-1
        object$segLengths <- diff(object$breaks)
    }

    object$nPars <- numeric(0)             #number of unique run-lengths per time point
    for(i in 1:object$Nsegs)
        object$nPars <- c(object$nPars,1:object$segLengths[i])
    object$D <- ncol(x)                    #dimension
    object$T <- nrow(x)

    object$maxRun <- max(diff(object$breaks)) #maximum run length

    if(is.null(shape) & is.null(scale)){
        ss <- rcpt(cpt_model = cpt_model,cpt_prior = cpt_prior)
        object$shape <- ss[1]
        object$scale <- ss[2]
    }else if(!is.null(shape) & !is.null(scale)){
        object$shape <- shape
        object$scale <- scale
    }else{
        stop("Error in bcp(): shape and scale should both be NULL of non-NULL")
    }
    object$cpt_model <- cpt_model
    object$obs_model <- obs_model
    object$obs_prior <- obs_prior
    object$cpt_prior <- cpt_prior

    ## generate lower/upper search bound for L-BFGS-B algorithm
    if(cpt_model=="weibull"){
        object$lower <- c(cpt_prior$start,1e-7)
        object$upper <- c(cpt_prior$end,qgamma(0.99999999,shape = cpt_prior$shape,scale=cpt_prior$scale))
        ## object$upper <- c(cpt_prior$end,500)
    }else{
        stop("In bcp(): ",cpt_model," not supported yet!")
    }

    class(object) <- 'bcp'

    return(object)

}

## offline forward filtering
## x: numeric matrix, or an object that can be coerced to a matrix. Observation sequence, each row of x is a TRANSPOSE of an observation
## cpt_model: name of the change point distribution
## shape: shape parameter for change point distribution
## scale: scale parameter for change point distribution
## obs_model: name of the observation distribution
## obs_prior: prior parameters for observation model
##                  if obs_model = "univariate-normal" or "multivariate-gaussian", prior should be a named list: list(m0,k0,v0,S0)
##                  if obs_model = "poisson" or "exponential", prior should be a be a named list: list(scale)
##                  if obs_model = "gamma" or "weibull", prior should be a named list:  list(shape,scale)
##                  if obs_model = ...
bcpFiltering <- function(bcpObj,...) UseMethod("bcpFiltering")
bcpFiltering.bcp <- function(bcpObj){
    ## if(nrow(bcpObj$x)<2) stop("Error in bcpFiltering(): there should be at least 2 observations")

    bcpObj$a <- lapply(bcpObj$nPars,FUN = function(l){rep(0,l)}) #place holder for filtered result
    ## generate the transition matrix
    ## first column: P(q+1|q), second column: P(0|q)
    bcpObj$transition <- logLTRC(0L:(bcpObj$maxRun-1L),cpt_model = bcpObj$cpt_model,shape = bcpObj$shape,scale=bcpObj$scale)
    bcpObj$transition <- exp(bcpObj$transition)

    ## generate the prediction probability: log P(x_t | r_t, x^{(r_t)})
    bcpObj$pxr <- list()
    for(s in 1:bcpObj$Nsegs){
        bcpObj$pxr <- c(bcpObj$pxr,bcpPrediction(x=bcpObj$x[(bcpObj$breaks[s]+1):bcpObj$breaks[s+1],,drop=FALSE],model = bcpObj$obs_model,prior = bcpObj$obs_prior)$p) #only log probability is needed, so append a "$p" at the end
    }
    bcpObj$pxr_exp <- lapply(bcpObj$pxr,exp) #not log version

    tmp <- 0                            #temporary variable
    LL <- 0
    start <- 0                          #starting location of each segment
    for(s in 1:bcpObj$Nsegs){
        start <- bcpObj$breaks[s]
        bcpObj$a[[start+1]] <- 1
        LL <- LL+ bcpObj$pxr[[start+1]]               #observed data log likelihood
        for(i in 2:bcpObj$segLengths[s]){
            bcpObj$a[[start+i]] <- log(c(sum(bcpObj$transition[1:(i-1),2]*bcpObj$a[[start+i-1]]),bcpObj$transition[1:(i-1),1]*bcpObj$a[[start+i-1]]))+
                bcpObj$pxr[[start+i]]
            tmp <- logsumexp(matrix(bcpObj$a[[start+i]],nrow = 1)) #normalizing constant of the filtering process, which happens to be log P(x_t|x_1:t-1)
            LL <- LL+tmp
            bcpObj$a[[start+i]] <- bcpObj$a[[start+i]]-tmp
            bcpObj$a[[start+i]] <- exp(bcpObj$a[[start+i]])
        }
    }

    ## add prior likelihood
    if(bcpObj$cpt_model=="weibull"){
        logprior <- dunif(bcpObj$shape,min = bcpObj$cpt_prior$start,max = bcpObj$cpt_prior$end,log = TRUE)+
            dgamma(bcpObj$scale,shape = bcpObj$cpt_prior$shape,scale = bcpObj$cpt_prior$scale,log = TRUE)
    }else{
        stop("In bcpEM.bcp().obj(): ",bcpObj$cpt_model," not supported yet!")
    }

    LL <- LL+logprior

    ## append resuts to bcp object
    bcpObj$LL <- LL
}

## offline forward filtering and backward smoothing
bcpSmoothing <- function(bcpObj,...) UseMethod("bcpSmoothing")
bcpSmoothing.bcp <- function(bcpObj){
    ## ----------------first part same as bcpFiltering----------------
    ## ---forward filtering---
    bcpFiltering(bcpObj)

    ## ---backward smoother---
    bcpObj$b <- lapply(bcpObj$nPars,FUN = function(l){rep(0,l)}) #place holder for backward result
    bcpObj$g <- lapply(bcpObj$nPars,FUN = function(l){rep(0,l)}) #place holder for smoothed result
    ## invisible(gc)
    start <- 0                          #starting location of each segment
    for(s in 1:bcpObj$Nsegs){
        start <- bcpObj$breaks[s]
        ## end <- bcpObj$breaks[s+1]
        bcpObj$b[[bcpObj$breaks[s+1]]] <- rep(1,bcpObj$segLengths[s])
        bcpObj$g[[bcpObj$breaks[s+1]]] <- bcpObj$a[[bcpObj$breaks[s+1]]]
        for(i in (bcpObj$segLengths[s]-1):1){
            ## transition: first column: P(q+1|q), second column: P(0|q)
            bcpObj$b[[start+i]] <- bcpObj$transition[1:i,1] * bcpObj$pxr_exp[[start+i+1]][-1] * bcpObj$b[[start+i+1]][-1]+
                bcpObj$transition[1:i,2] * bcpObj$pxr_exp[[start+i+1]][1]  * bcpObj$b[[start+i+1]][1]
            bcpObj$b[[start+i]] <- bcpObj$b[[start+i]]/sum(bcpObj$b[[start+i]])    #normalize to make sure it won't underflow
            bcpObj$g[[start+i]] <- bcpObj$b[[start+i]]*bcpObj$a[[start+i]]
            bcpObj$g[[start+i]] <- bcpObj$g[[start+i]]/sum(bcpObj$g[[start+i]])
        }
    }
}

## Two slice likelihoods, and filtered and smoothed
bcpTwoslice <- function(bcpObj,...) UseMethod("bcpTwoslice")
bcpTwoslice.bcp <- function(bcpObj){
    bcpSmoothing(bcpObj)

    ## can be see as a aparse version of the twoslice matrix
    ## because t in 1:T-1, so run length are in 0:T-2, i.e. T-1 unique different run lengths
    bcpObj$pii <- matrix(0,nrow = bcpObj$maxRun-1,ncol=2) #place holder for transition counts
    for(s in 1:bcpObj$Nsegs){
        start <- bcpObj$breaks[s]
        for(i in 1:(bcpObj$segLengths[s]-1)){
            ## tansition: first column: P(q+1|q), second column: P(0|q)
            tmp <- bcpObj$transition[1:i,,drop=FALSE] * bcpObj$a[[start+i]]
            tmp[,1] <- tmp[,1] * bcpObj$b[[start+i+1]][-1] * bcpObj$pxr_exp[[start+i+1]][-1]
            tmp[,2] <- tmp[,2] * bcpObj$b[[start+i+1]][1] * bcpObj$pxr_exp[[start+i+1]][1]
            tmp <- tmp/sum(tmp) #normalize
            bcpObj$pii[1:i,] <- bcpObj$pii[1:i,] + tmp     #the transition counts
        }
    }

}

## Offline learning with exact method
## use generalized EM algorithm
##
## nstart: number of random restarts
## maxit: maximum number of EM iterations for each (re)start
## deps: converge if LL-previousLL<deps
##
bcpEM <- function(bcpObj,maxit=100,deps=1e-4,nstart=10L) UseMethod("bcpEM")
bcpEM.bcp <- function(bcpObj,maxit=100,deps=1e-4,nstart=10L){
    obj <- function(ss){
        if(bcpObj$cpt_model=="weibull"){
            logprior <- dunif(ss[1],min = bcpObj$cpt_prior$start,max = bcpObj$cpt_prior$end,log = TRUE)+
                dgamma(ss[2],shape = bcpObj$cpt_prior$shape,scale = bcpObj$cpt_prior$scale,log = TRUE)
        }else{
            stop("In bcpEM.bcp().obj(): ",bcpObj$cpt_model," not supported yet!")
        }
        ## optim is to minimize, so add an minus sign
        -sum(bcpObj$pii*logLTRC(0L:(bcpObj$maxRun-2L),cpt_model = bcpObj$cpt_model,shape = ss[1],scale=ss[2]))-logprior
    }

    maxLL <- -Inf                       #overall maximum likelihood
    LLs <- rep(0,nstart)
    bcpObj$MAP <- rep(0,0)                     #place holder for MAP shape and scale
    for(start in 1L:nstart){
        ## reset starting values since the second round(first round aleady has a starting value)
        if(start>=2){
            ss <- rcpt(cpt_model = bcpObj$cpt_model,cpt_prior = bcpObj$cpt_prior)
            bcpObj$shape <- ss[1]
            bcpObj$scale <- ss[2]
        }

        ## main EM loop start --------------------------------
        it <- 0
        maxLLit <- -Inf                 #current maximum likelihood/postori
        while(it <= maxit){
            ## 1. E step-------------------------------
            ## filter, smoother and twoslice
            bcpTwoslice(bcpObj)
            ## if(bcpObj$LL-maxLLit< -deps){
            if(bcpObj$LL < maxLLit){
                cat("diff",bcpObj$LL-maxLLit,"\n")
                stop("decreasing likelihood, LL: ",bcpObj$LL) #some numerical error is irreducible
            }
            else if(bcpObj$LL-maxLLit<deps) break
            else maxLLit <- bcpObj$LL
            ## 2. M step------------------------------
            ## objective
            newSS <- optim(par = c(bcpObj$shape,bcpObj$scale),fn = obj,method = "L-BFGS-B",lower = bcpObj$lower,upper = bcpObj$upper)$par
            cat("iteration:",it,"  LL:",bcpObj$LL,"\n")
            cat("shape:",bcpObj$shape,"  scale:",bcpObj$scale,"\n")
            bcpObj$shape <- newSS[1]
            bcpObj$scale <- newSS[2]
            it <- it+1
        }
        ## main EM loop end --------------------------------

        if(maxLLit > maxLL){
            maxLL <- maxLLit
            bcpObj$MAP <- c(bcpObj$shape,bcpObj$scale) #get the best MAP estimate
        }
    }

}

bcpMCMC <- function(bcpObj,burnin=100,nSample=5000) UseMethod("bcpMCMC")
bcpMCMC.bcp <- function(bcpObj,burnin=100,nSample=5000){
}

## constructor of a "bcpo" object, used in online filtering
## use S3 with environment to achieve "pass by reference"
##
## cpt_model: name of the change point distribution
## shape: shape parameter for change point distribution
## scale: scale parameter for change point distribution
## obs_model: name of the observation distribution
## obs_prior: prior parameters for observation model
##                  if obs_model = "univariate-normal" or "multivariate-gaussian", prior should be a named list: list(m0,k0,v0,S0)
##                  if obs_model = "poisson" or "exponential", prior should be a be a named list: list(scale)
##                  if obs_model = "gamma" or "weibull", prior should be a named list:  list(shape,scale)
##                  if obs_model = ...
## l: inference lag, bcpOline will perform online filtering when when l=0, smoothing when l = Inf, fixed lag smoothing when 0<l<Inf. Default 0, filtering.
##
bcpo <- function(shape=NULL,scale=NULL,cpt_model=c("weibull","gamma","exponential"),obs_model=c("univariate-gaussian","multivariate-gaussian","multinomial","poisson","exponential","gamma","linear"),obs_prior=list(),cpt_prior=list(),l=0){

    cpt_model <- match.arg(cpt_model)
    obs_model <- match.arg(obs_model)

    object <- new.env(parent=globalenv())

    if(is.null(shape) & is.null(scale)){
        ss <- rcpt(cpt_model = cpt_model,cpt_prior = cpt_prior)
        object$shape <- ss[1]
        object$scale <- ss[2]
    }else if(!is.null(shape) & !is.null(scale)){
        object$shape <- shape
        object$scale <- scale
    }else{
        stop("Error in bcpo(): shape and scale should both be NULL of non-NULL")
    }
    object$cpt_model <- cpt_model
    object$obs_model <- obs_model
    object$obs_prior <- obs_prior
    object$cpt_prior <- cpt_prior

    object$x <- NULL
    object$T <- 0L

    ## place holder for filtered/smoothing result and evidence likelihood
    object$a <- list()
    object$pxr <- list()
    object$pxr_exp <- list()

    ## place holder for changepoint probability
    object$pCPT <- numeric()

    ## place holder for changepoint indicator
    object$isCPT <- numeric()

    ## most recent posteriors
    if(obs_model %in% c("univariate-gaussian","multivariate-gaussian")){
        object$prePost <- list(m=list(obs_prior$m0),
                               k=obs_prior$k0,
                               v=obs_prior$v0,
                               S=list(obs_prior$S0))
    }else{
        stop("In bcpo(): ",obs_model," not supported yet!")
    }

    ## generate lower/upper search bound for L-BFGS-B algorithm
    if(cpt_model=="weibull"){
        object$lower <- c(cpt_prior$start,1e-7)
        object$upper <- c(cpt_prior$end,qgamma(0.99999999,shape = cpt_prior$shape,scale=cpt_prior$scale))
        ## object$upper <- c(cpt_prior$end,500)
    }else{
        stop("In bcpo(): ",cpt_model," not supported yet!")
    }

    object$l <- as.integer(l)                       #inference lag

    ## tracker for most recent filter/smoother index
    ## bcpOnline will only calculate the filter status between filterTracker and T
    ## bcpOnline will only calculate the (fixed-lag)smoother status between smootherTracker and T-l
    object$filterTracker <- 0L
    object$smootherTracker <- 0L

    object$transition <- matrix(numeric(),ncol = 2)

    class(object) <- 'bcpo'

    return(object)

}

## attach new observation(s) to an bcpo object
## newObs: numeric matrix of at least 1 row, or an object that can be coerced to a matrix.
## bcpoObj: an bcpo object
bcpoAttach <- function(bcpoObj,newObs) UseMethod("bcpoAttach")
bcpoAttach.bcpo <- function(bcpoObj,newObs){
    newObs <- as.matrix(newObs)

    if(is.null(bcpoObj$x)){
        bcpoObj$x <- newObs
    }else{
        bcpoObj$x <- rbind(bcpoObj$x,newObs)
    }

    currentMaxRun <- bcpoObj$T+nrow(newObs)-1L
    ## transition matrix P(r_i | r_{i-1})
    bcpoObj$transition <- rbind(bcpoObj$transition,
                                exp(logLTRC(bcpoObj$T:currentMaxRun,cpt_model = bcpoObj$cpt_model,shape = bcpoObj$shape,scale=bcpoObj$scale)))
    bcpoObj$T <- currentMaxRun+1L

    ## prediction probability log P(x_t | r_t, x^{(r_t)})
    ## and update posteriors
    if(bcpoObj$obs_model %in% c("univariate-gaussian","multivariate-gaussian")){
        for(i in 1:nrow(newObs)){                   #for each obs
            m <- list()
            S <- list()
            px <- numeric(length(bcpoObj$prePost$k))
            for(j in 1:length(bcpoObj$prePost$k)){                          #for each prior combination
                tmp <- posteriorGaussian(x=newObs[i,,drop=FALSE],m0=bcpoObj$prePost$m[[j]],k0=bcpoObj$prePost$k[[j]],v0=bcpoObj$prePost$v[[j]],S0=bcpoObj$prePost$S[[j]])
                m[[j]] <- tmp$mN
                S[[j]] <- tmp$SN
                px[j] <- marginalLikelihoodGaussian_byPosterior(N=tmp$N,
                              mN = tmp$mN,kN = tmp$kN,vN = tmp$vN,SN = tmp$SN,
                              m0 = bcpoObj$prePost$m[[j]],k0 = bcpoObj$prePost$k[[j]],v0 = bcpoObj$prePost$v[[j]],S0=bcpoObj$prePost$S[[j]],LOG = TRUE)
            }
            bcpoObj$prePost$k <- c(bcpoObj$obs_prior$k0,bcpoObj$prePost$k+1)
            bcpoObj$prePost$v <- c(bcpoObj$obs_prior$v0,bcpoObj$prePost$v+1)
            bcpoObj$prePost$m <- c(list(bcpoObj$obs_prior$m0),m)
            bcpoObj$prePost$S <- c(list(bcpoObj$obs_prior$S0),S)
            bcpoObj$pxr <- c(bcpoObj$pxr,list(px))
            bcpoObj$pxr_exp <- c(bcpoObj$pxr_exp,list(exp(px)))
        }
    }

}

## Online change point detection
##
## bcpoObj: an object of class "bcpo"
## newObs: an new observation, must be a matrix of at least one row, or anything that be converted to a matrix.
##
## attach the probability of change point bcpoObj$pCPT and the change point indicator bcpoObj$isCPT of each time index to bcpoObj
bcpOnline <- function(bcpoObj,newObs) UseMethod("bcpOnline")
bcpOnline.bcpo <- function(bcpoObj,newObs){
    newObs <- as.matrix(newObs)
    bcpoAttach(bcpoObj,newObs)           #attach new observation
    ## online filter ----------------------------------------
    magneticHead <- 0
    while(bcpoObj$T > bcpoObj$filterTracker){
        magneticHead <- bcpoObj$filterTracker+1L
        if(magneticHead==1){
            bcpoObj$a[[1]] <- 1
            bcpoObj$filterTracker <- magneticHead
            bcpoObj$pCPT <- 1
            bcpoObj$isCPT <- TRUE
            next
        }
        bcpoObj$a[[magneticHead]] <- log(c(sum(bcpoObj$transition[1:(magneticHead-1),2]*bcpoObj$a[[magneticHead-1]]),bcpoObj$transition[1:(magneticHead-1),1]*bcpoObj$a[[magneticHead-1]])) + bcpoObj$pxr[[magneticHead]]
        bcpoObj$a[[magneticHead]] <- bcpoObj$a[[magneticHead]]-logsumexp(matrix(bcpoObj$a[[magneticHead]],nrow = 1)) #minus the logsumexp to normalize
        bcpoObj$a[[magneticHead]] <- exp(bcpoObj$a[[magneticHead]])
        bcpoObj$filterTracker <- magneticHead
        bcpoObj$pCPT <- c(bcpoObj$pCPT,bcpoObj$a[[magneticHead]][1]) #attach change point probability
        bcpoObj$isCPT <- c(bcpoObj$isCPT,which.max(bcpoObj$a[[magneticHead]])==1)
    }

    ## online fixed-lag smoother ----------------------------
    magneticHead <- 0
    magneticEnd <- 0
    while(bcpoObj$smootherTracker < (bcpoObj$T-bcpoObj$l) & bcpoObj$l > 0L){
        magneticHead <- bcpoObj$smootherTracker+1L
        magneticEnd <- bcpoObj$smootherTracker+1L+bcpoObj$l
        bPre <- rep(1,magneticEnd)       #the last backward info
        ## pass backward info
        for(i in (magneticEnd-1L):magneticHead){
            b <- bcpoObj$transition[1:i,1] * bcpoObj$pxr_exp[[i+1]][-1] * bPre[-1]+
                bcpoObj$transition[1:i,2] * bcpoObj$pxr_exp[[i+1]][1]  * bPre[1]
            b <- b/sum(b)    #normalize to make sure it won't underflow
            bPre <- b
        }
        ## merge with forward info
        bcpoObj$a[[magneticHead]] <- b*bcpoObj$a[[magneticHead]] #merge backward info into a
        bcpoObj$a[[magneticHead]] <- bcpoObj$a[[magneticHead]]/sum(bcpoObj$a[[magneticHead]])
        bcpoObj$smootherTracker <- magneticHead
        bcpoObj$pCPT[magneticHead] <- bcpoObj$a[[magneticHead]][1] #update the believe of the lagged change point probability
        bcpoObj$isCPT[magneticHead] <- which.max(bcpoObj$a[[magneticHead]])==1 #update the changepoint ideicator
    }

}


# If we list all the natural numbers below 10 that are multiples of 3 or 5,
# we get 3, 5, 6 and 9. The sum of these multiples is 23.

# Find the sum of all the multiples of 3 or 5 below 1000.

# Gives remainder when x is divided by y
rem <- function(x, y) {
  a <- (x / y)
  b <- floor(a)
  diff <- a - b
  return(diff* y)
}

# Takes two numbers and returns true if x is a multiple of y
mo <- function(x, y) {
  r <- rem(x, y)
  return(r == 0)
}

nums <- 1:999
fun1 <- function(x) { return (mo(x,3) || mo(x,5)) }
indexes <- sapply(nums, fun1)
sum(nums[indexes])


# Make Dataset
set.seed(0)
x1 <- rnorm(1000)
x2 <- rnorm(1000)
z <- 1 + 4 * x1 + 3 * x2
pr <- 1 / (1 + exp(-z))

y <- rbinom(1000, 1, pr)

# Training
df <- data.frame(
    y = y,
    x1 = x1,
    x2 = x2
)
glm(y~x1+x2, data = df, family = "binomial")


suppressPackageStartupMessages(library(float))
set.seed(1234)

tol = 1e-4
m = 10
n = 3

x = matrix(stats::rnorm(m*n), m, n)
s = fl(x)

type = "O"
test = dbl(rcond(s, type))
truth = rcond(x, type)
stopifnot(all.equal(test, truth, tol=tol))

type = "I"
test = dbl(rcond(s, type))
truth = rcond(qr.R(qr(x, LAPACK=TRUE)), type)
stopifnot(all.equal(test, truth, tol=tol))

cp = crossprod(x)
cp_s = fl(cp)

type = "O"
test = dbl(rcond(cp_s, type))
truth = rcond(cp, type)
stopifnot(all.equal(test, truth, tol=tol))

type = "I"
test = dbl(rcond(cp_s, type))
truth = rcond(cp, type)
stopifnot(all.equal(test, truth, tol=tol))


d1<- function(S,K,t,r,sig) {
  ans <- (log(S/K) + (r + sig^2/2)*t) / (sig*sqrt(t))
  return(ans)
}

d2 <- function(S,K,t,r,sig) {
  return(d1(S,K,t,r,sig) - sig*sqrt(t))
}

Call <- function(S,K,t,r,sig) {
  d_1 <- d1(S,K,t,r,sig)
  d_2 <- d2(S,K,t,r,sig)
  return(S*pnorm(d_1) - K*exp(-r*t)*pnorm(d_2))
}

print(d1(300,250,1,0.03,0.15))
microbenchmark::microbenchmark(Call(300,250,1,0.03,0.15))


Cholesterol_Reading=c(133,137,148,149,152,167,174,179,189,192,201,209,210,211,218,238,245,248,253,257)
normal_quantile=c(-1.96,-1.44,-1.15,-.935,-.755,-.598,-.454,-.319,-.189,-.063,.063,.189,.319,.454,.598,.755,.935,1.15,1.44,1.96)
plot(normal_quantile,Cholesterol_Reading)
model1=lm(Cholesterol_Reading~normal_quantile)
summary(model1)
 # Cholesterol = 195.5 + 39.4884 Normal Quantiles
# . The 20 points appear to be relatively close to the fitted line and thus the normal quantile plot would appear to suggest that the normality of the population distribution is plausible.


####      Exercise 2      #####

### Preamble ####

library("tidyverse")
library("haven")
library("maptools")
library("raster")
library("rgdal")
library("gridExtra")

####(a)####
# The data childrenfinal.dta are given in the STATA format.Read the data into R using an appropriate function from the tidyverse.
childrendata <- read_dta("childrenfinal.dta") #method suitable for STATA data

# Next, remove all variables that start with \s\, \v" and \m", followed by a number (avoid listing all of them).
#remove all variables that start with "s", "v" and "m", followed by a number
childrendata_1<- childrendata %>%
  dplyr::select(-matches("^[svm][0-9]"))

# Check all the remaining variables. Do all variables have reasonable variable type (character,factor, double, integer, etc)? Convert the variables to a suitable type, if necessary.

#convert labelled double into double variables
childrendata_2<- childrendata_1 %>%
  mutate_if(is.double, as.double)

### (b) ###
# Make a smaller tibble that contains variables hypage, ruralfacto, female, zstunt, zweight, zwast, adm2.
childrendata_3<- childrendata_2 %>%
  dplyr::select(c(hypage, ruralfacto, female, zstunt, zweight, zwast, adm2))

#Variable zstunt is the so-called Z-score for stunting and is defined as the height of a child standardised with the median and standard deviation of heights of children at the same age from a healthy population. Children with Z-score less than -2 are dfined to be stunted.
#Make a scatter plot of zstunt against hypage.Add a smooth line to the plot.
g1 <- ggplot(childrendata_3, aes(x = hypage, y = zstunt)) +
  geom_point(alpha=0.2) +
  geom_smooth(se = T, color = "blue") +
  geom_hline(yintercept=-2, linetype='twodash', color='red', size=1.3) +
  labs(x = "Age", y = "Z-score")

g1
ggsave('scatter.png', plot = g1)

# Comment on the results.

#Make smooth plots of zstunt against hypage for females and males on one plot, add a suitable legend.
#Use different colors for males and females.
g2 <- ggplot(childrendata_3, aes(x = hypage, y = zstunt,  col = factor(female))) +
  geom_point(alpha = 0.3) +
  geom_smooth(se = F) +
  scale_colour_manual(name='gender',labels = c("male", "female"), values = c("orange", "blue")) +
  theme(legend.key = element_rect(fill = "white", colour = "black"))+
  geom_hline(yintercept=-2, linetype='twodash', color='red', size=1.3) +
  labs(x = "Age", y = "Z-score")

g2

#Plot zstunt against age for urban and rural children
g3 <- ggplot(childrendata_3, aes(x = hypage, y = zstunt,  colour = factor(ruralfacto))) +
  geom_point(alpha = 0.4) +
  geom_smooth(se = F) +
  scale_colour_manual(name='area',labels = c("urban", "rural"), values = c("blue", "deeppink")) +
  theme(legend.key = element_rect(fill = "white", colour = "black")) +
  geom_hline(yintercept=-2, linetype='twodash', color='red4', size=1.3) +
  labs(x = "Age", y = "Z-score")
g3

#Comment on the results.
#Experiment with different aesthetics, themes and font sizes for the plots, report your favourite(s).
g4<-grid.arrange(g2, g3,nrow=2, heights=c(12,12))
ggsave('scatter_1.png', plot = g4)

### (c) ###
#Most of the following commands are taken from https://rpubs.com/spoonerf/countrymapggplot2

# Plot the map of Kenya with all counties listed in adm2. Colour the county areas according to the mean of zstunt in the corresponding county.#Kenya shapefile data
Kenya<-getData("GADM", country="KE", level=1)
plot(Kenya)#basic map

# setting an appropriate projection
Kenya_UTM<-spTransform(Kenya, CRS("+init=epsg:32537"))

#the names of the regions
Kenya_UTM@data$NAME_1
#childrendata_3[7]
#sort the data in alphabetic order with respect to the column
childrendata_3<- childrendata_3[order(childrendata_3$adm2),]
Kenya_UTM@data<- Kenya_UTM@data[order(Kenya_UTM@data$NAME_1),]

#summarising childrendata_3 data according to the counties
childrendata_4 <- childrendata_3 %>% group_by(adm2) %>%
  summarise(Mzstunt = mean(zstunt,na.rm=TRUE), n = n())

#Note that the one county (Isiolo) is missing in the data.
#adding the missing county Isiolo
childrendata_4[nrow(childrendata_4) + 1,] <- NaN
childrendata_4$adm2[47] <- "ISIOLO"

#again reordering
childrendata_4<- childrendata_4[order(childrendata_4$adm2),]

#dataframe for ggplot
Kenya_UTM@data$id <- rownames(Kenya_UTM@data)
Kenya_UTM@data <- mutate(Kenya_UTM@data, Mzstunt= childrendata_4$Mzstunt)
Kenya_df <- fortify(Kenya_UTM)
Kenya_df <- full_join(Kenya_df,Kenya_UTM@data, by="id")

#Make suitable legend and add county names (or corresponding labels) to the map. Comment on the results. In which counties are the children stunted?
# lets try to draw the map with colors according to zscore

ggplot() +
  geom_polygon(data = Kenya_df, aes(x = long, y = lat, group = group, fill =
                                      Mzstunt), color = "black", size = 0.25) +
  theme(aspect.ratio = 1)+
  scale_fill_gradient(name='mean Z-stunt', high='white', low='darkred', na.value='grey50')+
  theme_void()+
  theme(aspect.ratio = 1)

#now we add names of the counties
#In order to add names to map, we need another dataframe with all the conunties' centroids
# "coordinates" extracts centroids of the polygons, in the order listed at Kenya1_UTM@data
centroids_df <- as.data.frame(coordinates(Kenya_UTM))
names(centroids_df) <- c("long", "lat")
childrendata_4<- childrendata_4[order(childrendata_4$adm2),]
centroids_df$NAME_1 <- Kenya_UTM@data$NAME_1
centroids_df$Mzstunt <- childrendata_4$Mzstunt

#Generating the map
ggplot(data = Kenya_df, aes(x = long, y = lat, group = group, fill = Mzstunt)) +
  geom_polygon(color = "black", size = 0.25) +
  geom_text(data = centroids_df, aes(x = long, y = lat, label = NAME_1, group = NULL), size = 3) +
  scale_fill_distiller(name='mean Z-stunt', palette = "Spectral") +
  #scale_fill_gradient(name='mean Z-stunt', high='white', low='darkred', na.value='grey60')+
  theme_void() +
  theme(aspect.ratio = 1)

ggsave('Kenya.png')

##(d)write the tibble from (b) into a text file
write.table(childrendata_3,"childrendata_ex9.txt")
write_csv2(childrendata_3, 'children_ex9.csv')


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 3.4C   Chapter : 3.4     Page No: 162
# Find the Complete solution of the given system

library(pracma)
completesolution <- function(A,b){
  R<-rref(A)
  m<-nrow(A)
  n<-ncol(A)
  pivotcol<-c() #vector to store the column numbers of pivot columns
  freecol<-c()  #vector to store the column numbers of free columns
  i<-1
  j<-1

  # to find which columns are pivot and which are free
  while(i<=m & j<=n){
    if(R[i,j]==1){
      pivotcol<-c(pivotcol,j)
      i<-i+1
      j<-j+1
    }
    else{
      j<-j+1
    }
  }
  y<-length(pivotcol)
  freecol<-c(1:n)
  freecol<-freecol[!freecol%in%pivotcol]
  x<-length(freecol)
  N<-c()
  #find the basis for null space based on Row reduced echelon form of given matrix
  if(y==n){
    N<-c()
  }
  for(i in 1:x){
    temp<-c(1:n)
    for(j in 1:x){
      temp[freecol[j]]<-0
    }
    temp[freecol[i]]<-1
    temp[freecol[i]]
    for(j in 1:y){
      temp[pivotcol[j]]<-R[j,freecol[i]]*-1
    }
    N<-c(N,temp)
  }
  N<-matrix(N,nrow=n,ncol=x)
  s<-N
  Ab<-cbind(A,b)
  Rd<-rref(Ab)
  temp<-Rd[,n+1]
  p<-c(1:n)
  for(i in 1:length(freecol)){
    p[freecol[i]]<-0
  }
  for(i in 1:length(pivotcol)){
    p[pivotcol[i]]<-temp[i]
  }
  print("The special solution is")
  print(s)
  print("The particular solution is")
  print(p)
  print("Complete solution = particular solution + Special solution")
}
A<-matrix(c(1,2,4,2,4,8,1,4,6,0,8,8),nrow=3)
b<-c(4,2,10)
completesolution(A,b)


install.packages("ggplot2") #Install GGPLOT
library(ggplot2) #Import library
sal = read.csv("/Salaries.csv", header = TRUE) #Import File
sortedSalary = sort(sal$Salary) #sort values
salSD = sd(sortedSalary) # Standard Deviation
salMean= mean(sortedSalary) # Mean
dnorm(sortedSalary,salMean,salSD) # Density Function
plot(sortedSalary, dnorm(sortedSalary,salMean,salSD), type = "l") # Plot Bell Curve Normally
Norms = dnorm(sortedSalary,salMean,salSD) # assign density function
Postion = as.factor(sal$Position) # assign factor
saldf = data.frame("Salary" = sortedSalary,"Distribution" = Norms) # assign values to data frame
ggplot(saldf, aes(x = Salary, y = Distribution)) + geom_point()  # Plot Bell Curve
dataFrames = data.frame("Salary" = sortedSalary, "Distribution" = Norms, "Position" = Postion) # assign values to data frame
ggplot(dataFrames, aes(x = Salary, y = Distribution, color=Position)) + geom_point() # Bell Curve with Position Colors


=begin
  # sample-galois-group01.rb

  require "algebra/rational"
  require "algebra/polynomial"

  P = Algebra.Polynomial(Rational, "x")
  x = P.var

  (x**3 - 3*x + 1).galois_group.each do |g|
    p g
  end
  #=> [0, 1, 2]
  #   [1, 2, 0]
  #   [2, 0, 1]]

  (x**3 - x + 1).galois_group.each do |g|
    p g
  end
  #=> [0, 1, 2]
  #   [1, 0, 2]
  #   [2, 0, 1]
  #   [0, 2, 1]
  #   [1, 2, 0]
  #   [2, 1, 0]
((<_|CONTENTS>))
=end


shiller<-read_tsv("Shiller Data - sp500.tsv") %>%
  mutate(date=as.Date(sprintf("%s-%s-01", year, month)))

ggplot(shiller, aes(date, sp500)) + geom_line() + scale_y_log10()
ggplot(shiller, aes(date, sp500_growth)) + geom_line() + geom_smooth(method="loess", span=0.5)
ggplot(shiller, aes(sp500_growth)) + geom_density()
qqnorm(shiller$sp500_growth)

ggplot(shiller, aes(date, dividend_yield)) + geom_line()
qqnorm(shiller$dividend_yield)

ggplot(shiller, aes(date, cpi)) + geom_line() + scale_y_log10()
ggplot(shiller, aes(date, inflation)) + geom_line()
ggplot(shiller, aes(inflation)) + geom_density()
qqnorm(shiller$inflation)

ggplot(shiller, aes(date, ten_yr_treasury_yield)) + geom_line()

shiller %>% filter(year>=1950) %>% ggplot(aes(date, inflation)) + geom_line() + geom_smooth(span=0.25)
shiller %>% filter(year>=1950) %>% ggplot(aes(date, ten_yr_teasury_yield)) + geom_line() + geom_smooth(span=0.25)

shiller %>% filter(year>=1950) %>%
  ggplot(aes(inflation, (1+ten_yr_teasury_yield)^(1/12)-1)) +
  geom_point() +
  geom_smooth(method="lm")

shiller %>% filter(year>=1950) %>%
  ggplot(aes(inflation, sp500_growth)) +
  geom_point() +
  geom_smooth(method="lm")

shiller %>%
  ggplot(aes(inflation, sp500_growth)) +
  geom_point() +
  geom_smooth(method="lm")

with(shiller %>% filter(year>=1950), cor(ten_yr_teasury_yield, inflation))
with(shiller %>% filter(year>=1950), cor(ten_yr_teasury_yield, sp500_growth))
with(shiller %>% filter(year>=1950), cor(inflation, sp500_growth))

with(shiller, cor(ten_yr_teasury_yield, inflation))
with(shiller, cor(ten_yr_teasury_yield, sp500_growth))
with(shiller, cor(inflation, sp500_growth))

shiller %>% View()

shiller_annual <- shiller %>%
  group_by(year) %>%
  arrange(month) %>%
  summarize(sp500_growth=sp500_growth[1],
            dividend_yield=dividend_yield[1],
            inflation=inflation[1],
            ten_yr_treasury_yield=ten_yr_treasury_yield[1]) %>%
  filter(year > 1871)

shiller_annual %>%
  gather(var, value, -year) %>%
  ggplot(aes(year, value)) + geom_line() +
  facet_wrap(~var)


model_selectin <- function(train_df, outcome, n_sample = 0.2) {
  ## Turning off warnings
  options(warn=-1)
  library(caret)

  outcomes.eq <- paste(outcome, "~.")
  outcomes.formula <- as.formula(outcomes.eq)

  # Define subset rows default: 20% of total train_df
  # train2 <- train_df[1:2000,]
  n <- round(nrow(train_df) * n_sample)
  train_subset <- train_df[sample(nrow(train_df), n), ]

  #x = nearZeroVar(train_subset, saveMetrics = TRUE)
  #x

  control <- trainControl(method="repeatedcv", number=10, repeats=3)
  seed <- 123
  metric <- "Accuracy"

  # Linear Discriminant Analysis
  message("Learning: Linear Discriminant Analysis")
  set.seed(seed)
  fit.lda <- train(outcomes.formula, data=train_subset, method="lda", metric=metric, preProc=c("center", "scale"), trControl=control)
  # Logistic Regression
  #message("Learning: Logistic Regression")
  #set.seed(seed)
  #fit.glm <- train(outcomes.formula, data=train_subset, method="glm", metric=metric, trControl=control)
  # GLMNET
  message("Learning: GLMNET")
  set.seed(seed)
  fit.glmnet <- train(outcomes.formula, data=train_subset, method="glmnet", metric=metric, preProc=c("center", "scale"), trControl=control)
  # SVM Radial
  message("Learning: SVM Radial")
  set.seed(seed)
  fit.svmRadial <- train(outcomes.formula, data=train_subset, method="svmRadial", metric=metric, preProc=c("center", "scale"), trControl=control, fit=FALSE)
  # kNN
  message("Learning: kNN")
  set.seed(seed)
  fit.knn <- train(outcomes.formula, data=train_subset, method="knn", metric=metric, preProc=c("center", "scale"), trControl=control)
  # Naive Bayes
  message("Learning: Naive Bayes")
  set.seed(seed)
  fit.nb <- train(outcomes.formula, data=train_subset, method="nb", metric=metric, trControl=control)
  # CART
  message("Learning: CART")
  set.seed(seed)
  fit.cart <- train(outcomes.formula, data=train_subset, method="rpart", metric=metric, trControl=control)
  # C5.0
  #set.seed(seed)
  #fit.c50 <- train(outcomes.formula, data=train_subset, method="C5.0", metric=metric, trControl=control)
  # Bagged CART
  message("Learning: Bagged CART")
  set.seed(seed)
  fit.treebag <- train(outcomes.formula, data=train_subset, method="treebag", metric=metric, trControl=control)
  # Random Forest
  message("Learning: Random Forest")
  set.seed(seed)
  fit.rf <- train(outcomes.formula, data=train_subset, method="rf", metric=metric, trControl=control)
  # Stochastic Gradient Boosting (Generalized Boosted Modeling)
  message("Learning: Stochastic Gradient Boosting (Generalized Boosted Modeling)")
  set.seed(seed)
  fit.gbm <- train(outcomes.formula, data=train_subset, method="gbm", metric=metric, trControl=control, verbose=FALSE)
  # Extreme Gradient Boosting
  #message("Learning: Extreme Gradient Boosting")
  #set.seed(seed)
  #fit.egb <- train(outcomes.formula, data=train_subset, method="xgbTree", metric=metric, trControl=control, verbose=FALSE)

  #
  message("Done Leearing!")

  #
  #results <- resamples(list(lda=fit.lda, logistic=fit.glm, glmnet=fit.glmnet,
  #                      svm=fit.svmRadial, knn=fit.knn, nb=fit.nb, cart=fit.cart,
  #                      bagging=fit.treebag, rf=fit.rf, egb=fit.egb))

  results <- resamples(list(lda=fit.lda, glmnet=fit.glmnet,
                            svm=fit.svmRadial, knn=fit.knn, nb=fit.nb, cart=fit.cart,
                            bagging=fit.treebag, rf=fit.rf))

  results_sumary <- summary(results)
  print(results_sumary)
}


# Above Ground Biomass estimation
#
# Estimate above ground biomass following Chave et al. (2005)
#
# Chave, J. et al. 2005. Tree allometry and improved estimation of carbon
#   stocks and balance in tropical forests. - Oecologia 145: 87–99.
#

estbiomass <- function(ro, h=NULL, dhb=NULL, chb=NULL, type=NULL){

  if (is.null(chb) & is.null(dhb)) { stop("chb or dhb must be defined\n") }
  if (!is.null(chb) & is.null(dhb)) { dhb <- chb/pi }
  if (missing(ro)) { stop("ro must be defined\n") }
  if (!(type %in% c("dry","moist","mangrove","wet"))){
    stop("type must be defined as: 'dry', 'moist', 'mangrove' or 'wet'\n")
  }

  if (!is.null(h)){
    out <- switch(type,
                  dry =  exp(-2.187 + 0.916 * log(ro * (dhb^2) * h)),
                  moist = exp(-2.977 + log(ro * (dhb^2) * h)),
                  mangrove = exp(-2.977 + log(ro * (dhb ^ 2) * h)),
                  wet = exp(-2.557 + 0.940 * log(ro * (dhb^2) * h)))
  } else {
    out <- switch(type,
                  dry =  (ro * exp(-0.667 + (1.784 * log(dhb)) + (0.207 * (log(dhb) ^ 2)) - (0.0281 * (log(dhb) ^ 3)))),
                  moist = (ro * exp(-1.449 + (2.148 * log(dhb)) + (0.207 * (log(dhb) ^ 2)) - (0.0281 * (log(dhb) ^ 3)))),
                  mangrove = (ro * exp(-1.349 + (1.980 * log(dhb)) + (0.207 * (log(dhb) ^ 2)) - (0.0281 * (log(dhb) ^ 3)))),
                  wet = (ro * exp(-1.239 + (1.980 * log(dhb)) + (0.207 * (log(dhb) ^ 2)) - (0.0281 * (log(dhb) ^ 3)))))
  }

  return(out)
}


euclidean <- function(a, b) sqrt(sum((a - b) ^ 2))

rectKernel <- function(dist, h) if (dist <= h) 0.5 else 0

trKernel <- function(dist, h) if (dist <= h) (h - dist) / h else 0

epKernel <- function(dist, h) if (dist <= h) (1 - dist ^ 2) * 0.75 else 0

gaussKernel <- function(dist, h) exp(sqrt(h / pi * 0.5) * -0.5 * (dist * h) ^ 2)

kvKernel <-function(dist, h) if (dist <= h) 15 / 16 * (1 - (dist / h) ^ 2) ^ 2 else 0

parzen <- function(dset, labels, point, h, kernel, dist = euclidean) {
  dsetLength <- length(dset[,1])
  distances <- array(dim = c(dsetLength))

  uLabels <- unique(labels)
  # print("LABBB")
  # print(apply(uLabels, 1, paste))
  classScores <- array(0L, dim = c(length(uLabels)))
  names(classScores) = uLabels;
  classScores["undefined"] <- 0.000001

  for (i in 1:dsetLength) {
    classScores[labels[i]] <- classScores[labels[i]] + kernel(dist(point, dset[i,]), h)
  }

  return(names(which.max(classScores)))
}

generateMaps <- function() {
  xs <- seq(from = 0.5, to = 7.5, by = 0.1)
  ys <- seq(from = -1, to = 3.5, by = 0.1)

  colors <- c("setosa" = "blue", "virginica" = "red", "versicolor" = "green", "undefined" = "grey")

  kernels <- c("rect" = rectKernel, "tr" = trKernel, "ep" = epKernel, "gauss" = gaussKernel, "kv" = kvKernel)

  # par(mfrow = c(length(kernels) / 2, 2), pty="s", mar=c(1,1,1,1))

  index <- 1
  for (kernelName in names(kernels)) {
    kernel <- kernels[[kernelName]]
    png(sprintf("plot-%03d.png", index), width = 1024, height = 700, unit = "px", pointsize = 20)
    cat("Kernel:", kernelName, index, "of", length(kernels), "\n")
    index <- index + 1
    plot(iris[, 3:4], col = colors[paste(iris$Species)], pch=16, asp=1)

    all <- length(xs) * length(ys)
    progress = 1
    for (i in xs) {
      for (j in ys) {
        cat("\rProcessing point", progress, "of", all)
        progress <- progress + 1
        result <- parzen(iris[3:4], paste(iris$Species), c(i, j), 0.4, kernel)
        points(i, j, col = colors[result], pch = 21)
      }
    }
    cat("\rDone.                      \n")
    dev.off()
  }
}

parzen_loo <- function (dset, labels, kernel, hs) {
  dsetLen <- dim(dset)[1]
  hLen <- length(hs)
  ans <- array(0L, dim = c(hLen))

  for (i in 1:hLen) {
    cat("h:", hs[i], "index:", i, "of", hLen, "\n")
    for (j in 1:dsetLen) {
      cat("\rProcessing sample", j, "of", dsetLen)
      tmpRes <- parzen(dset[-j,], labels[-j], dset[j,], hs[i], kernel)
      if (tmpRes != paste(labels[j])) {
        ans[i] <- ans[i] + 1
      }
    }
    print(ans)
  }

  ans <- ans / dsetLen
  return (ans)
}

generateLoos <- function() {
  kernels <- c("tr" = trKernel, "ep" = epKernel, "gauss" = gaussKernel, "kv" = kvKernel)
  hs <- seq(from = 0, to = 6, by = 0.2)

  index <- 1
  for (kernelName in names(kernels)) {
    kernel <- kernels[[kernelName]]
    png(sprintf("loo-%03d.png", index), width = 1324, height = 700, unit = "px", pointsize = 20)
    cat("Kernel:", kernelName, index, "of", length(kernels), "\n")
    index <- index + 1

    loo <- parzen_loo(iris[3:4], iris$Species, kernel, hs)
    plot(hs, loo, type="l", xlab="h", ylab="LOO")
    points(hs[which.min(loo)], loo[which.min(loo)], pch = 19, col = "red")
    text(hs[which.min(loo)], loo[which.min(loo)] + 0.05, paste("best:", hs[which.min(loo)]))

    cat("\rDone.                      \n")
    dev.off()
  }
}

# generateLoos()
generateMaps()

#parzen(iris[3:4], paste(iris$Species), c(4, 1), 0.4, rectKernel)


fib <- function(n) {
    if (n < 2) {
        return(n)
    }
    return(fib(n-1) + fib(n-2))
}


## 3. The for Loop ##

millimeter_measurements <- c(10000, 54900, 94312, 49185, 2100)
meter_measurements <- c()
for (measurement in millimeter_measurements) {
  meter <- measurement / 1000
  meter_measurements <- c(meter_measurements, meter)
}

## 4. Another Way To Write for Loops ##

millimeter_measurements <- c(10000, 54900, 94312, 49185, 2100)
meter_measurements <- integer(length(millimeter_measurements))
indices <- 1:length(millimeter_measurements)

for (i in indices) {
  calc <- millimeter_measurements[i] / 1000
  meter_measurements[i] <- calc
}

## 7. Your Own while Loop ##

prices <- c(138.19, 82.72, 118.97, 77.55, 62.28, 89.71, 97.36, 91.98, 113.45, 73.93)
is_below_70 <- FALSE
i <- 1
while (!is_below_70) {
  current_price <- prices[i]
  is_below_70 <- current_price < 70
  i = i + 1
}

buy_price <- current_price

Data Analyst in R/Step 1 - Introduction to R/3. Control Flow, Iteration and Functions in R/2. Iterations in R.r


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

 install.packages("quantmod")
 install.packages("neuralnet")
 library(quantmod)
 library(neuralnet)

 startDate = as.Date("2009-01-01")

 endDate = as.Date("2014-01-01")

 getSymbols("^GSPC",src="yahoo",from=startDate,to=endDate)

 relativeStrengthIndex3 <- RSI(Op(GSPC),n=3)

 summary(relativeStrengthIndex3)

 exponentialMovingAverage5 <- EMA(Op(GSPC),n=5)

 head(exponentialMovingAverage5)

 summary(exponentialMovingAverage5)

 exponentialMovingAverageDiff <- Op(GSPC) - exponentialMovingAverage5

 head(exponentialMovingAverageDiff)

 summary(exponentialMovingAverageDiff)

 MACD <- MACD(Op(GSPC),fast = 12, slow = 26, signal = 9)

 tail(MACD)

 summary(MACD)

 MACDsignal <- MACD[,2]

 BollingerBands <- BBands(Op(GSPC),n=20,sd=2)

 tail(BollingerBands)

 summary(BollingerBands)

 PercentageChngpctB <- BollingerBands[,4]

 tail(PercentageChngpctB)

 summary(PercentageChngpctB)

 Price <- Cl(GSPC)-Op(GSPC)

 tail(Price)

 DataSet<-data.frame(relativeStrengthIndex3, exponentialMovingAverage5, MACDsignal, PercentageChngpctB, Price)

 str(DataSet)

 DataSet<-DataSet[-c(1:33),]

 dim(DataSet)

 colnames(DataSet)<-c("RSI3","EMAcross","MACDsignal","BollingerB","Price")

 str(DataSet)

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

 NormalizedData<-as.data.frame(lapply(DataSet,Normalized))

 tail(NormalizedData)

 TrainingSet<-NormalizedData[1:816,]

 dim(TrainingSet)

 summary(TrainingSet)

 TestSet<-NormalizedData[817:1225 ,]

 dim(TestSet)

 summary(TestSet)

 nn1<-neuralnet(Price~RSI3+EMAcross+MACDsignal+BollingerB,data=TrainingSet, hidden=c(3,3), learningrate=.001,algorithm="backprop")

plot(nn1)


M=c(62,60,60,25,24,23,20,13,12,6)
C=c(62,62,24,24,22,20,19,10,8,8)
P=c(37,31,15,15,14,14,14,5,3,2)

Group1=abs(M-median(M))
Group2=abs(C-median(C))
Group3=abs(P-median(P))

Combined_Groups <- data.frame(cbind(Group1, Group2, Group3)) # combines the data into a single data set.
Combined_Groups # shows spreadsheet like results
#summary(Combined_Groups)  # min, median, mean, max

Stacked_Groups <- stack(Combined_Groups)
Stacked_Groups #shows the table Stacked_Groups

Anova_Results <- aov(values ~ ind, data = Stacked_Groups)
summary(Anova_Results) # shows Anova_Results


library(Sleuth3)
library(ggplot2)

head(case0402)
qplot(Treatment,Time,data=case0402,geom="boxplot")

qplot(Time,data=case0402,geom="histogram",xlim=c(0,300)) +
  facet_grid(Treatment ~ .)

summary(case0402$Treatment)
wilcox.test(Time~Treatment,data=case0402,alternative="greater",
            exact=FALSE,correct=FALSE)
wilcox.test(Time~Treatment,data=case0402,exact=FALSE,correct=FALSE,
            conf.int=TRUE)

difference<-with(case0202,Unaffected-Affected)
length(difference)
length(which(difference>0))
binom.test(14,15,alternative="greater")

wilcox.test(difference,exact=FALSE,alternative="greater")

head(case0201)
t.test(Depth~Year,data=case0201) # Not assuming equal variance
t.test(Depth~Year,data=case0201,var.equal=TRUE)


Time=c(6,7,8,9,10,11,12,13,14,15,16,17,18,19)
Temp=c(4,6,7,9,10,11,11.5,12,12,11.5,11,10,9,8)

plot(Time,Temp,cex.axis=0.6,cex.lab=0.6)

Polyfit2 <- lm(Temp ~ Time + I(Time^2))
Polyfit3 <- lm(Temp ~ Time + I(Time^2) + I(Time^3))

Polyfit2b <- lm(Temp ~ poly(Time, 2, raw=TRUE))
Polyfit3b <- lm(Temp ~ poly(Time, 3, raw=TRUE))

summary(Polyfit2)
summary(Polyfit3)

PredData = data.frame(Time = seq(min(Time), max(Time), length.out = 100))
PredData$Temp = predict(Polyfit2, newdata = PredData)

plot(Time,Temp,cex.axis=0.6,cex.lab=0.6)
with(PredData, lines(x = Time, y = Temp))

PredData2 = data.frame(Time = seq(min(Time), max(Time), length.out = 100))
PredData2$Temp = predict(Polyfit3, newdata = PredData)

plot(Time,Temp,cex.axis=0.6,cex.lab=0.6)
with(PredData2, lines(x = Time, y = Temp))


# Master Thesis Project - Extreme Value Theory
# We assume that the stock prices follow a geometric
# Brownian motion (Black-Scholes model). We plot the
# empirical stock price data as well as the simulated
# geometric Brownian motions associated to them.
# Killian Martin--Horgassan
# 08-06-2015

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

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

# Sourcing the auxiliary files
source("loadStockData_plain.r")
source("firstElement.r")
source("computeApproximateGradient.r")
source("meanAndVariance.r")
source("Visualisation_StockPriceVariations.r")

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

# Loading the original data for the LVMHH and Total
# stocks and getting the indexes where to cut the
# data.
df_plain <- loadStockData_plain(CHOICE)
indexes <- Visualisation_StockPriceVariations()
index_lvmh <- indexes[1]-1
index_total <- indexes[2]-1

S_lvmh <- df_plain[[3]]
S_total <- df_plain[[5]]

S_lvmh <- S_lvmh[1:index_lvmh]
S_total <- S_total[1:index_total]

LS_lvmh <- log(S_lvmh)
LS_total <- log(S_total)

LR_lvmh <- diff(LS_lvmh)
LR_total <- diff(LS_total)

index_lvmh <- length(LR_lvmh)
index_total <- length(LR_total)

m_lvmh <- mean(LR_lvmh)
s2_lvmh <- var(LR_lvmh)

m_total <- mean(LR_total)
s2_total <- var(LR_total)

# Building the Geometric Brownian motions
B_lvmh1 <- rnorm(index_lvmh,0,1)
B_lvmh1 <- S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh1))

B_lvmh2 <- rnorm(index_lvmh,0,1)
B_lvmh2 <-  S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh2))

B_lvmh3 <- rnorm(index_lvmh,0,1)
B_lvmh3 <-  S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh3))

B_lvmh4 <- rnorm(index_lvmh,0,1)
B_lvmh4 <-  S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh4))

B_lvmh5 <- rnorm(index_lvmh,0,1)
B_lvmh5 <-  S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmh5))

minima_lvmh <- min(c(B_lvmh1, B_lvmh2, B_lvmh3, B_lvmh4, B_lvmh5))
maxima_lvmh <- max(c(B_lvmh1, B_lvmh2, B_lvmh3, B_lvmh4, B_lvmh5))

B_total1 <- rnorm(index_total,0,1)
B_total1 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total1))

B_total2 <- rnorm(index_total,0,1)
B_total2 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total2))

B_total3 <- rnorm(index_total,0,1)
B_total3 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total3))

B_total4 <- rnorm(index_total,0,1)
B_total4 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total4))

B_total5 <- rnorm(index_total,0,1)
B_total5 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_total5))

minima_total <- min(c(B_total1, B_total2, B_total3, B_total4, B_total5))
maxima_total <- max(c(B_total1, B_total2, B_total3, B_total4, B_total5))

quartz()
dev.new(width = 7, heigth = 7)
png(file = "cleanedLVMH.png")
plot(1:index_lvmh, S_lvmh[1:index_lvmh], col = 'grey', lwd = 2,
	type = 'l', main = 'LVMH Stock actual & simulated', xlab =
    'Time steps in weeks', ylab = 'Stock prices', ylim =
    c(minima_lvmh, maxima_lvmh))
lines(1:index_lvmh, B_lvmh1, col = 'red')
lines(1:index_lvmh, B_lvmh2, col = 'blue')
lines(1:index_lvmh, B_lvmh3, col = 'green')
lines(1:index_lvmh, B_lvmh4, col = 'yellow')
lines(1:index_lvmh, B_lvmh5, col = 'purple')
dev.off()
graphics.off()

quartz()
dev.new(width = 7, heigth = 7)
png(file = "cleanedTotal.png")
plot(1:index_total, S_total[1:index_total], col = 'grey', lwd = 2,
	type = 'l', main = 'Total Stock actual & simulated', xlab =
    'Time steps in weeks', ylab = 'Stock prices', ylim =
    c(minima_total, maxima_total))
lines(1:index_total, B_total1, col = 'red')
lines(1:index_total, B_total2, col = 'blue')
lines(1:index_total, B_total3, col = 'green')
lines(1:index_total, B_total4, col = 'yellow')
lines(1:index_total, B_total5, col = 'purple')
dev.off()
graphics.off()

B_totalBeta1 <- rnorm(6*index_total,0,1/sqrt(6))
B_totalBeta1 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_totalBeta1))

B_totalBeta2 <- rnorm(6*index_total,0,1/sqrt(6))
B_totalBeta2 <- S_total[1]*exp(cumsum((m_total + 0.5*s2_total) + sqrt(s2_total)*B_totalBeta2))

minima_total_Beta <- min(c(B_totalBeta1, B_totalBeta2))
maxima_total_Beta <- max(c(B_totalBeta1, B_totalBeta2))

quartz()
dev.new(width = 7, heigth = 7)
png(file = "cleanedTotal_better_simulation.png")
plot(1:index_total, S_total[1:index_total], col = 'grey', lwd = 2,
	type = 'l', main = 'Total Stock actual [weekly increment] & \n simulated [daily increment]', xlab =
    'Time steps in weeks', ylab = 'Stock prices')#, ylim =
    #c(minima_total_Beta, maxima_total_Beta))
lines(1:(6*index_total), B_totalBeta1, col = 'purple')
lines(1:(6*index_total), B_totalBeta2, col = 'blue')

dev.off()
graphics.off()

B_lvmhBeta1 <- rnorm(6*index_lvmh,0,1/sqrt(6))
B_lvmhBeta1 <- S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmhBeta1))

B_lvmhBeta2 <- rnorm(6*index_lvmh,0,1/sqrt(6))
B_lvmhBeta2 <- S_lvmh[1]*exp(cumsum((m_lvmh + 0.5*s2_lvmh) + sqrt(s2_lvmh)*B_lvmhBeta2))

minima_lvmh_Beta <- min(c(B_lvmhBeta1, B_lvmhBeta2))
maxima_lvmh_Beta <- max(c(B_lvmhBeta1, B_lvmhBeta2))

quartz()
dev.new(width = 7, heigth = 7)
png(file = "cleanedLVMH_better_simulation.png")
plot(1:index_lvmh, S_lvmh[1:index_lvmh], col = 'grey', lwd = 2,
	type = 'l', main = 'LVMH Stock actual [weekly increment] & \n simulated [daily increment]', xlab =
    'Time steps in weeks', ylab = 'Stock prices')#, ylim =
    #c(minima_total_Beta, maxima_total_Beta))
lines(1:(6*index_lvmh), B_lvmhBeta1, col = 'purple')
lines(1:(6*index_lvmh), B_lvmhBeta2, col = 'blue')

dev.off()
graphics.off()


## https://israeldi.github.io/bookdown/_book/monte-carlo-simulation-of-stock-portfolio-in-r-matlab-and-python.html

source('/home/dlhjel/GitHub_repos/R-setup/setup.r')

##-----------------------------------------------------------------------------
## Determine mean for each asset and covariance matrix
data <- '
    Date           AAPL           GOOG           FB
11/15/17       166.5791        1020.91       177.95
11/16/17       168.5693        1032.50       179.59
11/17/17       167.6333        1019.09       179.00
11/20/17       167.4658        1018.38       178.74
11/21/17       170.5791        1034.49       181.86
11/22/17       172.3721        1035.96       180.87
11/24/17       172.3820        1040.61       182.78
11/27/17       171.5150        1054.21       183.03
11/28/17       170.5101        1047.41       182.42
11/29/17       166.9732        1021.66       175.13
'
history <- as_tibble(readall(data))
history$Date <- as.Date(history$Date, "%m/%d/%Y")
increment <- (max(history$Date) - min(history$Date)) / nrow(history)
# alternately, I could grab the most common increment
# increment <- mode(diff(history$Date))
price <- history[2:ncol(history)]

# This function returns the first differences of a t x q df of data
returns = function(df){
  rows  <- nrow(df)
  return <- df[2:rows, ] / df[1:rows-1, ] - 1
}

# Get the asset returns
return <- returns(price)

## calculate mean return for each asset
means = colMeans(return)

## Get the Variance Covariance Matrix of Stock Returns
pairs(return)
coVarMat = cov(return)
print(coVarMat)

## Lower Triangular Matrix from Choleski Factorization, L where L * t(L) = CoVarMat
## needed for R_i = mean_i + L_ij * Z_ji
L = t( chol(coVarMat) )
print(L)

##-----------------------------------------------------------------------------
## SET PARAMETERS FOR MONTE CARLO SIMULATIONS

# Set number of Monte Carlo Simulations
mc_rep = 1000
# Set number of days for the simulation
sim_days = 30
# Set simulation start date
sim_start <- Sys.Date()
# Calculate simulation end date
sim_end <- sim_start + increment * sim_days
# Set date vector for simulation (length should be sim_days + 1)
Date <- seq(sim_start, sim_end, increment)

# Suppose we invest our money evenly among all three assets
# We use today's Price 11/14/2018 to find the number of shares each stock
# that we buy
weights <- c(1/3, 1/3, 1/3)
print(weights)

##-----------------------------------------------------------------------------
## START MONTE CARLO SIMULATION

## initialize sim_return matrix
## row for each simulation date
## column for each monte carlo simulation
cum_sim_m = matrix(0, sim_days, mc_rep)

## Extend means vector to a matrix
## one row for each account (or investment column) repeated in columns for each simulation
means_matrix = matrix(rep(means, sim_days), nrow = ncol(return))

## set seed if want to repeat exactly
set.seed(200)
for (i in 1:mc_rep) {
    ## do following for each monte carlo simulation

    ## obtain random z values for each account (rows) for each date increment (columns)
    Z <- matrix( rnorm( ncol(return) * sim_days ), ncol = sim_days)

    ## simulate returns for each increment forward in time (assumed same as whatever data was)
    sim_return <- means_matrix + L %*% Z
    ## to view as a dataframe
    ## dfsim <- as_tibble(as.data.frame(t(sim_return)))

    ## Calculate vector of portfolio returns
    cum_sim_i = cumprod( weights %*% sim_return + 1 )

    ## Add it to the monte-carlo matrix
    cum_sim_m[,i] = cum_sim_i;
}
# put results into dataframe
cum_sim_df <- as_tibble(as.data.frame(cum_sim_m))
# add row for starting value
ones <- rep(1, ncol(cum_sim_df))
cum_sim_df <- rbind(ones, cum_sim_df)

##-----------------------------------------------------------------------------
## DISPLAY RESULTS

# plot results
# first establish plot area
ylim <- range(cum_sim_df)
plot(Date, cum_sim_df$V1, type='n',
     ylab='Simulation Returns',
     ylim=ylim)
for (i in 2:ncol(cum_sim_df)) {
  lines(Date, t(cum_sim_df[i]), type='l')
}

# Porfolio Returns statistics at end of simulation
cum_final <- as.numeric( cum_sim_df[nrow(cum_sim_df),] )
cum_final_stats <- data.frame(mean   = mean(cum_final),
                        median = median(cum_final),
                        sd     = sd(cum_final))
print(cum_final_stats)

## Construct Confidential Intervals for returns
## first define function
ci <- function(df, conf) {
    # calculate confidence limit for specified confidence level
    # note specified conf = 1 - alpha
    # i.e., if want alpha=0.05 to get 95% conf limit, specify 0.95
    apply(df, 1, function(x) quantile(x, conf))
}
## create dataframe of confidence intervals
df <- cum_sim_df
cis <- as_tibble( data.frame(Date,
                  conf_99.9_upper_percent = ci(df, 0.999),
                  conf_99.0_upper_percent = ci(df, 0.99),
                  conf_95.0_upper_percent = ci(df, 0.95),
                  conf_50.0_percent       = ci(df, 0.5),
                  conf_95.0_lower_percent = ci(df, 0.05),
                  conf_99.0_lower_percent = ci(df, 0.01),
                  conf_99.9_lower_percent = ci(df, 0.001)) )

## plot confidence intervals on simulation
lines(cis$Date, cis$conf_99.9_upper_percent, lwd=4, lty=2, col='red')
lines(cis$Date, cis$conf_50.0_percent      , lwd=4,        col='red')
lines(cis$Date, cis$conf_99.9_lower_percent, lwd=4, lty=2, col='red')


#se cargan los datos colocando como parametros que los decimales seran separados por un ","
y<-read.table("datos.txt",header=TRUE,dec=",")
y
#Se realiza el Analisis de de Componentes Principales usando la matriz de Covarianza #
com1<-princomp(y[,1:4],cor=F)
#Seleccionar cuantas o cuales componentes
summary(com1)
plot(com1)
names(com1)
#Intepretar las componentes
loadings(com1)
#x11()
#graf(com1,2)
x11()
biplot(com1)#no se que significa

#Grafica de las componentes
x11()
par(mfrow=c(2,2))
plot(com1$score[,1],com1$score[,2])
sal<-c(1,3,3,3,3,4,4,4,4,4,4,5,5,5,5,6,6,6,7,7,7,8,10,10,10,11,11,12,12,12,13,13,15,15,15,15,15,15,15,16,16,16,16,16,16,16,17,17,17,17,17,17,17,18,18,18,18,18,19,19)
clase<-rep(FALSE,length(sal))
clase[sal<12]<-1 #Grupo Bronce
clase[sal>=12&sal<16]<-2 #Grupo Plata
clase[sal>=16]<-3 #Grupo Oro

plot(com1$score[,1],com1$score[,2],pch=21,bg=c("red", "blue","green")[unclass(clase)])

plot(com1$score[,1],com1$score[,3])
sal<-c(1,3,3,3,3,4,4,4,4,4,4,5,5,5,5,6,6,6,7,7,7,8,10,10,10,11,11,12,12,12,13,13,15,15,15,15,15,15,15,16,16,16,16,16,16,16,17,17,17,17,17,17,17,18,18,18,18,18,19,19)
clase<-rep(FALSE,length(sal))
clase[sal<12]<-1 #Grupo Bronce
clase[sal>=12&sal<16]<-2 #Grupo Plata
clase[sal>=16]<-3 #Grupo Oro

plot(com1$score[,1],com1$score[,3],pch=21,
bg=c("red", "blue","green")[unclass(clase)])

################################
# Graficacion de 3 componentes #
################################
library(rgl)
plot3d(com1$scores[,1:3], col=c("red", "blue","green")[unclass(clase)])

#grafico biplot 3d
text3d(com1$scores[,1:3],texts=rownames(y))
text3d(com1$loadings[,1:3], texts=rownames(com1$loadings), col="red")
coords <- NULL
for (i in 1:nrow(com1$loadings)) {
  coords <- rbind(coords, rbind(c(0,0,0),com1$loadings[i,1:3]))
}
lines3d(coords, col="red", lwd=4)

#Redes neuronales
library(AMORE)
#linealmente no separable
## Creamos dos conjuntos de datos artificiales: ''P'' es el conjunto
#de datos de entrada y ''target'' el de salida.
target1<-matrix(c(clase),ncol=1,byrow=TRUE)
P1<-matrix(c(com1$score[,1],com1$score[,2]),ncol=2,byrow=TRUE)
## Creamos el objeto red neuronal feedforward
net1 <- newff(n.neurons=c(2,3,1), learning.rate.global=1e-2, momentum.global=0.5,
error.criterium="LMS", Stao=NA, hidden.layer="sigmoid",
output.layer="sigmoid", method="ADAPTgdwm")
##Se entrena la red
result1 <- train(net1,P1 , target1, error.criterium="LMS", report=TRUE, show.step=10000, n.shows=5 )
#simulacion
Ps<-matrix(c(com1$score[1,1],com1$score[1,2]),ncol=2,byrow=TRUE)
s <- sim(result1$net, Ps)

plot3d(P1,s, col=c("red", "blue","green")[unclass(clase)])

#lecetura de datos para entrenar
ent<-read.table("entre.txt",header=FALSE,dec=",")
#salida deseada
sal_e<-c(1,3,3,3,3,4,4,4,4,4,4,5,5,5,5,6,6,6,7,7,7,8,10,10,10,11,11,12,12,12,13,13,15,15,15,15,15,15,15,16,16,16,16,16,16,16,17,17)
clase_e<-rep(FALSE,length(sal_e))
clase_e[sal_e<12]<-1 #Grupo Bronce
clase_e[sal_e>=12&sal_e<16]<-2 #Grupo Plata
clase_e[sal_e>=16]<-3 #Grupo Oro
sal_v<-c(17,17,17,17,17,18,18,18,18,18,19,19)
clase_v<-rep(FALSE,length(sal_v))
clase_v[sal_v<12]<-1 #Grupo Bronce
clase_v[sal_v>=12&sal_v<16]<-2 #Grupo Plata
clase_v[sal_v>=16]<-3 #Grupo Oro
#objeto para salida deseada
target_e<-matrix(clase_e,ncol=1,byrow=TRUE)

#PRUEBA CON COMPONENTE 1 Y 2
#datos para entrenar
P_e<-matrix(c(com1$score[1:48,1],com1$score[1:48,2]),ncol=2,byrow=TRUE)

## Creamos el objeto red neuronal feedforward
net1 <- newff(n.neurons=c(2,3,1), learning.rate.global=1e-2, momentum.global=0.5,
error.criterium="LMS", Stao=NA, hidden.layer="sigmoid",
output.layer="sigmoid", method="ADAPTgdwm")
##Se entrena la red
result_e <- train(net1,P_e , target_e, error.criterium="LMS", report=TRUE, show.step=10000, n.shows=5 )

#simulacion
P_v<-matrix(c(com1$score[49:60,1],com1$score[49:60,2]),ncol=2,byrow=TRUE)
s <- sim(result_e$net, P_v)

plot3d(P_v,s, col=c("red", "blue","green")[unclass(clase_v)])
x11()
s <- sim(result_e$net, P_e)
plot3d(P_e,s, col=c("red", "blue","green")[unclass(clase_e)])

#PRUEBA CON COMPONENTE 1 , 2 Y 3 ###############################################
#datos para entrenar
P_e<-matrix(c(com1$score[1:48,1],com1$score[1:48,2],com1$score[1:48,3]),ncol=3,byrow=TRUE)

## Creamos el objeto red neuronal feedforward
net1 <- newff(n.neurons=c(3,3,1), learning.rate.global=1e-2, momentum.global=0.5,
error.criterium="LMS", Stao=NA, hidden.layer="sigmoid",
output.layer="sigmoid", method="ADAPTgdwm")
##Se entrena la red
result_e <- train(net1,P_e , target_e, error.criterium="LMS", report=TRUE, show.step=10000, n.shows=5 )

#simulacion
P_v<-matrix(c(com1$score[49:60,1],com1$score[49:60,2],com1$score[49:60,3]),ncol=3,byrow=TRUE)
s <- sim(result_e$net, P_v)

#PRUEBA CON COMPONENTE 1 , 2 Y 3 4 ###############################################
#datos para entrenar
P_e<-matrix(c(com1$score[1:48,1],com1$score[1:48,2],com1$score[1:48,3],com1$score[1:48,4]),ncol=4,byrow=TRUE)

## Creamos el objeto red neuronal feedforward
net1 <- newff(n.neurons=c(4,5,1), learning.rate.global=1e-2, momentum.global=0.5,
error.criterium="LMS", Stao=NA, hidden.layer="sigmoid",
output.layer="sigmoid", method="ADAPTgdwm")
##Se entrena la red
result_e <- train(net1,P_e , target_e, error.criterium="LMS", report=TRUE, show.step=10000, n.shows=5 )

#simulacion
P_v<-matrix(c(com1$score[49:60,1],com1$score[49:60,2],com1$score[49:60,3],com1$score[49:60,4]),ncol=4,byrow=TRUE)
s <- sim(result_e$net, P_v)

require(AMORE)
## Creamos dos conjuntos de datos artificiales: ''P'' es el conjunto de datos de entrada y ''target'' el de salida.
P <- matrix(sample(seq(-1,1,length=500), 500, replace=FALSE), ncol=1)
target <- P^2 + rnorm(500, 0, 0.5)
## Creamos el objeto red neuronal feedforward
net.start <- newff(n.neurons=c(1,3,1), learning.rate.global=1e-2, momentum.global=0.5,error.criterium="LMS",Stao=NA,hidden.layer="
sigmoid",output.layer="sigmoid",method="ADAPTgdwm")
## Entrenamos la red según P y target
result <- train(net.start, P, target, error.criterium="LMS",
report=TRUE, show.step=100, n.shows=5 )
str(result)
#objeto red neuronal entrenada con pesos y tendencias ajustadas mediante el entrenamiento adaptativo backpropagation con el método de momentum (detallado en el apartado anterior)
#matriz con los errores obtenidos durante el entrenamiento
result$Merror
#[,1]
#[1,] 0.2753484
#[2,] 0.2749079
#[3,] 0.2746274
#[4,] 0.2744657
#[5,] 0.2743568
## Gráficos para remarcar que ahora la red entrenada en un elemento de la lista resultante
y <- sim(result$net, P)
#vector de 500 elementos
str(y)
#num [1:500, 1] 0.0374 0.8303 0.7052 0.0704 0.2761 ...
plot(P,y, col="blue", pch="+")
points(P,target, col="red", pch="x")


marginOfError =
function(prob,  # sample probability (or response rate)
         n,  # sample size
         N=NULL,
         conf.level=0.95  # Confidence interval
         ) {
    z <- qnorm(p=1.0 - (1.0 - conf.level) * 0.5)
    B <- prob * (1 - prob)
    moe <- z * sqrt(B / n)

    if (!is.null(N)) {
        # tmp <- z ^ 2 * (prob * (1 - prob)) / moe^2
        # n <- tmp / (1 + tmp / N)
        # n + n/N * tmp <- tmp
        # n <- tmp * (1 - n/N)
        fpcf <- sqrt((N - n) / (N - 1))
        moe <-  moe * fpcf
    }
    return(moe)
}

sampleSize =
function(prob,
         moe,  # Margin of error
         N=NULL,  # Population size
         conf.level=0.95
         ) {
    z <- qnorm(p=1.0 - (1.0 - conf.level) * 0.5)
    B <- prob * (1 - prob)
    n <- z ^ 2 * B / moe^2
    if (!is.null(N)) {
        n <- n * N / (n + N - 1)
    }
    return(n)
}

binom.test =
function() {
    prob <- 0.15
    moe <- 0.025
    N <- 1000
    n <- sampleSize(prob=prob, moe=moe, N=N)
    message(n)
    message("Expected margin of error: ", moe)
    moe <- marginOfError(prob=prob, n=n, N=N)
    message(moe)
}