#' @title splitAt
#' @description Function to split a vector into a list at specified positions. Adapted from http://stackoverflow.com/questions/16357962/r-split-numeric-vector-at-position
#' @param x vetor of data
#' @param pos positions to split the data vector
#' @return a list of split data
splitAt <- function(x, pos) unname(split(x, cumsum(seq_along(x) %in% pos)))

#' @title smooth.deri.glkerns
#' @description Function to smooth data and calculate derivative with glkerns
#' @import lokern
#' @param x vector of data
#' @param t time stamp of each point
#' @param deriv order of derivative to calculate
#' @param t.out time stamp of output (default: to be the same as input)
#' @return a vector of fitted value after smoothing
smooth.deri.glkerns <- function(x, t, deriv=0, t.out=t, smethod='glkerns', ...){
    fit.tmp <- glkerns(t, x, deriv=deriv, x.out = t.out, bandwidth=10)$est
    res <- abs(x - fit.tmp)
    res.med <- median(res)
    res.mad <- mad(res)
    outliers <- (res - res.med) / (res.mad+1e-16) > 5
    outliers[c(1:3,length(outliers))] <- FALSE
    if(smethod=='glkerns'){
        glkerns(t[!outliers], x[!outliers], deriv=deriv, x.out = t.out,...)$est
    }else{
        lokerns(t[!outliers], x[!outliers], deriv=deriv, x.out = t.out,...)$est
    }
}

#' @title smooth.deri.pspline
#' @description Function to smooth data and calculate derivative with pspline
#' @param x vector of data
#' @param t time stamp of each point
#' @param deriv order of derivative to calculate
#' @param t.out time stamp of output (default: to be the same as input)
#' @param method spline fitting method used for "pspline" (default: 3)
#' @param norder order of spline basis (default: 3)
#' @import pspline
#' @return a vector of fitted value after smoothing
smooth.deri.pspline <- function(x, t, deriv=0, t.out=t, smethod=3, norder=3, ...){
    ## initial fit to find outliers
    fit.tmp <- c(smooth.Pspline(t, x,method=smethod, norder=norder, spar=1e10)$ysmth)
    res <- abs(x - fit.tmp)
    res.med <- median(res)
    res.mad <- mad(res)
    outliers <- (res - res.med) / (res.mad+1e-16) > 5
    outliers[c(1:3,length(outliers))] <- FALSE
    if (2*norder + 1 >= length(t[!outliers])){outliers[1:length(outliers)] <- FALSE}
    c(predict(smooth.Pspline(t[!outliers], x[!outliers],method=smethod, norder=norder, ...), t.out, deriv ) )
}

#' @title SmoothGradient
#' @description Function to smooth data and calculate derivative with pspline
#' @param m a matrix of data (variable in columns and time in rows)
#' @param t matrix or vector of time points for each data
#' @param breaks break points to re-smooth the data
#' @param t.out time stamps of output (default: to be the same as input)
#' @param deriv order of derivative to calculate
#' @param ncpu number of cpus (default: 10)
#' @param method smoothing method used to calculate gradients (default: pspline)
#' @return a matrix of gradients calculated (deriv=1), a matrix of smoothed data (deriv=0)
SmoothGradient <- function(m, t, breaks, t.out = t, deriv=1, ncpu=10, method='pspline', ...){
    m[is.na(m)] <- 0
    registerDoMC(ncpu)
    p <- ncol(m)
    if(is.null(ncol(t))){
        t.mat <- matrix(rep(t, p), ncol=p)
    }
    idList <- splitAt(seq_along(t) , breaks)
    ## assertion on method used
    try(if(!method %in% c('pspline', 'glkerns'))  stop('Invalid method!'))

    smoothed <- foreach(c = 1:p, .combine='cbind') %dopar% {
        ts <- t.mat[,c]
        x <- m[,c]
        res <- foreach(id=idList, .combine = 'c') %do%{
            if(method == 'pspline'){
                smooth.deri.pspline(x[id],ts[id],deriv=deriv, t.out=ts[id],...)
            }else if(method == 'glkerns'){
                smooth.deri.glkerns(x[id],ts[id],deriv=deriv, t.out=ts[id],...)
            }
        }
        res
    }
    smoothed
}

#' @title alr.transformation
#' @description Function to transform a matrix of compositions with addative log ratio (alr)
#' @param m matrix of data (variables in columns, samples in rows)
#' @param refSp reference variable
#' @return transformed matrix
alr.transformation <- function(m, refSp){
    if(min(m, na.rm = TRUE)==0) {
        pseudo <- 10^(floor(log10(min(m[m!=0], na.rm = TRUE))))
        m[m==0] <- pseudo
    }
    log(m/m[,refSp])
}

#' @title alr.transformation.inv
#' @description Function to inverse transform a matrix from addative log ratio (alr) to compostions
#' @param alr matrix of data (variables in columns, samples in rows)
#' @param refSp reference variable
#' @return inverse transformed matrix
alr.transformation.inv <- function(alr,refSp){
    tmp <- exp(alr)
    tmp[, refSp] <- 1
    tmp/rowSums(tmp,na.rm=TRUE)
}

#' @title clr.transformation
#' @description Function to transform a matrix of compositions with centered log ratio (clr)
#' @param m matrix of data (variables in columns, samples in rows)
#' @return transformed matrix
clr.transformation <- function(m){
    ##m: matrix of data (variables in columns, samples in rows)
    log(m) - rowMeans(log(m))
}

#' @title tsoutliers
#' @description Function to detect outliers in time serires
#' @param x vector of time series
#' @param t vector of time stamps
#' @param dev deviation (dev * mad) from the median to be considered as outliers
tsoutliers <- function(x,t,dev=2){
    NAs <- is.na(x)
    score <- rep(Inf, length(x))
    x <- x[!NAs]
    t <- t[!NAs]
    resid <- abs(residuals(loess(x ~ t)))
    score[!NAs] <- (resid - median(resid))>mad(resid) * dev

    ## resid.med <- median(resid)
    ## resid.mad <- mad(resid)
    ## limits <- resid.med+resid.mad * dev* c(-1,1)
    ## score[!NAs] <- abs(pmin((resid-limits[1]),0) + pmax((resid - limits[2]),0))
    return(score)
}

#' @title tsoutliers.w.brks
#' @description Function to detect outliers in time serires
#' @param x vector of time series
#' @param t vector of time stamps
#' @param breaks break points to re-smooth the data
#' @param dev deviation (dev * mad) from the median to be considered as outliers
tsoutliers.w.brks <- function(x,t,breaks,dev=2){
    idList <- splitAt(1:length(x) , breaks)
    score <- foreach(id=idList, .combine = 'c') %do%{
        tsoutliers(x[id],t[id],dev)
    }
    return(score)
}

#' @title formatOutput
#' @description Function to convert parameter vector alpha and matrix beta to MDSINE's output format
#' @importFrom reshape2 melt
#' @param alpha growth rates
#' @param beta interaction matrix
#' @param gamma perturbation matrix
#' @param vnames variable names
#' @return a data frame in MDSINE's output format
formatOutput <- function(alpha, beta, gamma=NULL, vnames){
    p <- length(alpha)
    nPerturbs <- ncol(gamma)
    if(is.null(gamma)) nPerturbs <- 0
    parm <- data.frame(parameter_type=c(rep("growth_rate",p), rep("interaction",p*p), rep("perturbation", nPerturbs*p)))
    if(nPerturbs>0){
        tmp <- rep(paste0("perturbation",1:nPerturbs), each=p)
    }else{
        tmp <- NULL
    }
    parm$source_taxon <- c(rep(NA,p),rep(vnames, each = p),tmp)
    parm$target_taxon <- vnames
    parm$value <- 0
    parm$significance <- NA
    parm$MCMC_std <- NA
    tmp.beta <- melt(t(beta))
    tmp.beta <- tmp.beta[order(tmp.beta$Var1),]
    parm$value <- c(alpha, tmp.beta$value, c(gamma))
    parm
}

#' @title BLASSO
#' @description Function to estimate parameters using gradient matching bayesian lasso
#' @import monomvn
#' @param X matrix of data (variables in columns, measurements in rows)
#' @param P matrix of perturbation indicators
#' @param Ys matrix of response (variables in columns, measurements in rows)
#' @param Fs matrix of filter indicating whether the Y-X pair is used
#' @param ncpu number of CPU used
#' @param rmSp the index of variable removed for alr transformed data
#' @param vnames the name of species to format output
#' @param seed the seed
#' @return a list with alpha, beta, and output in MDSINE's format
BLASSO <- function(X, P, Ys, Fs, ncpu, rmSp, vnames, seed=NULL){
    registerDoMC(ncpu)
    p <- ncol(X)
    nPerturbs <- ncol(P)
    X[is.na(X)] <- 0
    tmp <- ifelse(rmSp==0, p, p-1)
    Fs[is.na(Fs)] <- TRUE
    theta <- foreach(o = 1:tmp, .combine=cbind) %dopar% {
        Y <- Ys[, o]
        f <- Fs[, o]
        if(!is.null(seed)) set.seed(seed)
        if(is.null(P)){
            bl.fit <- blasso(X[!f & !is.na(Y),], Y[!f & !is.na(Y)], verb = 0, T=1500)
        }else{
            bl.fit <- blasso(cbind(P[!f & !is.na(Y),],X[!f & !is.na(Y),]), Y[!f & !is.na(Y)], verb = 0, T=1500)
        }
        a <- mean(bl.fit$mu[-(1:500)])
        b <- apply(bl.fit$beta[-c(1:500),],2,mean)
        c(a,b)
    }
    alpha.v <- rep(0, p)
    beta.m <- matrix(0, p,p)
    if(rmSp==0){
        alpha.v <- theta[1,]
    }else{
        alpha.v[-rmSp] <- theta[1,]
    }
    if(is.null(nPerturbs)){
        gamma.m <- NULL
        if(rmSp==0){
            beta.m <- t(theta[-1,])
        }else{
            beta.m[-rmSp,] <- t(theta[-1,])
        }
    }else{
        if(rmSp==0){
            gamma.m <- matrix(0, nrow=p, ncol=nPerturbs)
            gamma.m <- t(theta[-1,][1:nPerturbs,])
            beta.m <- t(theta[-1,][-(1:nPerturbs),])
            gamma.m <- postProcessGamma(alpha.v, gamma.m)
        }else{
            gamma.m <- matrix(0, nrow=p, ncol=nPerturbs)
            gamma.m[-rmSp,] <- t(theta[-1,][1:nPerturbs,])
            beta.m[-rmSp,] <- t(theta[-1,][-(1:nPerturbs),])
            gamma.m <- postProcessGamma(alpha.v, gamma.m)
        }
    }
    beta.m <- postProcessBeta(beta.m)

    return(list(alpha.v=alpha.v, beta.m=beta.m, gamma.m=gamma.m,
                mdsine=formatOutput(alpha.v, beta.m, gamma.m, vnames)))
}

#' @title cumSumScale
#' @description Function to perform cumulative sum scaling (CSS)
#' @param m matrix of data (variables in columns, measurements in rows)
#' @param p quantile used for normalization (default: 0.5)
cumSumScale <- function(m, p=0.5){
    m[m==0] <- NA
    ## find the quantile in each sample
    quant <- apply(m,1,function(x) quantile(x, p=p, na.rm = TRUE))
    ## calculate normalization factor
    f <- rowSums(m*sweep(m, 1, quant, '<='),na.rm = TRUE)
    nf <- f/exp(mean(log(f)))
    dat.css <- sweep(m,1,nf, '/')
    return(list("normCounts" = dat.css, "normFactors"=nf))
}

#' @title preProcess
#' @description Function to preprocess input data. Input counts are normalized with CSS within each subject across all time points and then normalized across subjects with method described by David et. al.
#' @param counts input data following MDSINE's OTU table (i.e. variables in rows and samples in columns)
#' @param metadata metadata following MDSINE's metadata format
#' @param rsp reference species used for alr transformation
#' @param dev deviation (dev * mad) from the median to be considered as outliers
#' @param scaling scale the normalized counts (default 5000)
#' @param smooth_data data will be smoothed before initial normalization (default: TRUE)
#' @param forceBreak force to break the trajectory to handle pulsed perturbation (or species invasion) (default: NULL)
#' @param finite_diff use finite difference method to calculate gradients (default FALSE)
#' @param ncpu number of CPUs (default: 10)
#' @param norder order of spline basis (default: 3)
preProcess <- function(counts, metadata, rsp, dev=100, scaling=5000, smooth_data=TRUE, ncpu=10, norder=3, finite_diff=FALSE, forceBreak=NULL){
    ## get perturbation identifier matrix (mu)
    if(any(metadata[,5]!=0)){
        mu <- model.matrix(~factor(metadata[,5]))[,-1]
        if(is.null(ncol(mu))) mu <- matrix(mu, ncol=1)
    }else{mu = NULL}
    ## normalize counts into relative abundances
    dat.norm <- apply(counts, 2, function(x) x/sum(x, na.rm = TRUE))
    ## compute alr transformed data
    dat.alr <- alr.transformation(t(dat.norm), rsp)
    if(smooth_data && !finite_diff){
        ## data smoothing
        dat.alr.smoothed <- foreach(i=unique(metadata$subjectID), .combine='rbind') %do%{
            sel <- metadata$subjectID == i
            brk <- unique(sort(c(which(diff(metadata[sel,5]) !=0) + 1,
                                 which(forceBreak[sel] == 1))))
            SmoothGradient(dat.alr[sel, ], metadata[sel, 4], breaks=brk,
                           deriv=0, ncpu=10, method='pspline',smethod=3, norder=norder)
        }
        dat.alr.smoothed[is.na(dat.alr)] <- NA
        ## transform back
        dat.norm.smoothed <- t(alr.transformation.inv(dat.alr.smoothed, rsp))
        dat.norm <- dat.norm.smoothed
    }
    ## CSS normalization across all the samples
    dat.norm <- t(cumSumScale(t(dat.norm))$normCounts)
    ## compute gradients
    dat.norm.scale <- data.frame(matrix(NA, nrow(counts),0))
    isOutlier <- NULL
    dalr_x_dt <- data.frame(matrix(NA, nrow(counts)-1,0))
    rel_diff <- data.frame(matrix(NA, nrow(counts),0))
    for(i in unique(metadata$subjectID)){
        sel <- metadata$subjectID==i
        dat.tmp.norm <- dat.norm[, sel]
        ## compute addative log ratio transformation
        alr.tmp <- dat.alr[sel,]
        brk <- unique(sort(c(which(diff(metadata[sel,5]) !=0) + 1,
                             which(forceBreak[sel] == 1))))
        if(finite_diff){
            dalr_x_dt.tmp <- t(rbind(diff(alr.tmp[,-rsp])/diff(metadata[sel,4]),NA))
        }else{
            dalr_x_dt.tmp <- t(SmoothGradient(alr.tmp[,-rsp],
                                              metadata[sel, 4], breaks=brk,
                                              method = "pspline", ncpu=10, smethod=3, norder=norder))
        }
        dalr_x_dt <- cbind(dalr_x_dt, dalr_x_dt.tmp)
        ## detect outliers
        if (!finite_diff){
            outliers.tmp <- t(apply(dalr_x_dt.tmp, 1, function(x)
                tsoutliers.w.brks(x,metadata[sel,4],brk,dev=dev) > 0))
        }else{
            outliers.tmp <- matrix(FALSE, nrow(dalr_x_dt.tmp), ncol(dalr_x_dt.tmp))
        }
        isOutlier <- cbind(isOutlier, outliers.tmp)
        ## scaling
        dat.tmp.norm <- dat.tmp.norm * scaling
        dat.norm.scale <- cbind(dat.norm.scale, dat.tmp.norm)
        ## find relative change in relative abundances
        rel_diff <- cbind(rel_diff,
                          cbind(Inf, t(diff(t(dat.tmp.norm))))/(dat.tmp.norm))
    }
    if(finite_diff){
        ## detect outliers for all gradients
        isOutlier <- t(apply(dalr_x_dt,1, function(x)
            abs(x-median(x, na.rm = TRUE))/mad(x, na.rm = TRUE) > dev ))
    }
    equilibrium_thre <- 0.05
    isOutlier[,colSums(abs(rel_diff) < equilibrium_thre) > nrow(rel_diff) * 0.8] <- TRUE
    list(normData=dat.norm.scale, perturbInd=mu, alrGradient=dalr_x_dt, isOutlier=isOutlier)
}

#' @title postProcessBeta
#' @description Function to filter small interactions. Small interaction is defined relative to the mean of the diagonal of the matrix
#' @param beta interaction matrix estimated with BLASSO
#' @param thre_pos threshold used to remove small positive interactions (default 1e-3 * slef interaction)
#' @param thre_neg threshold used to remove small negative interactions (default 1e-3 * slef interaction)
postProcessBeta <- function(beta, thre_pos=1e-3, thre_neg=1e-3){
    tmp <- abs(diag(beta))
    ##scale <- median(tmp[tmp!=0])
    f <- foreach(r=1:nrow(beta), .combine = 'rbind') %do%{
        cr1 <- beta[r,]>0 & abs(beta[r,]) < (tmp[r] * thre_pos)
        cr2 <- beta[r,]<0 & abs(beta[r,]) < (tmp[r] * thre_neg)
        res <- cr1 | cr2
        res[r] <- FALSE
        res
    }
    beta[f] <- 0
    beta
}

#' @title postProcessGamma
#' @description Function to filter small perturbation effect. Small interaction is defined relative to the mean of the diagonal of the matrix
#' @param alpha growth vector estimated with BLASSO
#' @param gamma perterbation effect matrix estimated with BLASSO
#' @param thre threshold used to remove small perturbation effect (default 1e-2 * self interactions)
postProcessGamma <- function(alpha, gamma, thre=1e-2){
    f <- min(abs(alpha)) * thre
    gamma * sweep(abs(gamma), 1, f , '>')
}

#' @title NORM
#' @description Function to calculate biomass for each sample
#' @param tss matrix of relative abundances (proportions), variables in rows and sample in columns
#' @param gradients matrix of gradients of addative log (alr) transformed abundances
#' @param perturbInd matrix of perturbation indicator generated by preProcess
#' @param meta metadata
#' @param rmSp Speices removed for alr tranformation
#' @param params list(alpha=, beta=) estimated with BLASSO
#' @param ncpu number of CPUs used (default: 10)
#' @param norder order of spline basis (default: 3)
#' @param scale scale the median of all samples
#' @param smooth smooth the biomass after normalization
#' @param forceBreak force to break the trajectory to handle pulsed perturbation (or species invasion) (default: NULL)
NORM <- function(tss, gradients, perturbInd, metadata, rmSp, params, ncpu=10, norder=3, scale=NA, smooth=FALSE, forceBreak=NULL){
    registerDoMC(ncpu)
    tss[is.na(tss)] <- 0
    if(is.null(params$gamma)){
        perturbOffset <- 0
    }else{
        perturbOffset <- (params$gamma %*% perturbInd)[-rmSp,]
    }
    gradients[is.na(gradients)] <- 0
    Ys <- gradients - params$alpha[-rmSp] - perturbOffset
    Xs <- params$beta[-rmSp,] %*% tss

    comb <- function(x, ...) {
        ## adapted from http://stackoverflow.com/questions/19791609/saving-multiple-outputs-of-foreach-dopar-loop
        ## might have an efficient implementation
        lapply(seq_along(x),
               function(i) c(x[[i]], lapply(list(...), function(y) y[[i]])))
    }

    w.list <- foreach (t = 1:ncol(tss), .combine='comb', .multicombine=TRUE) %dopar%{
        Y <- Ys[,t]
        X <- Xs[,t]
        ## remove points that have different signs
        wrong.sign <- sign(X) != sign(Y)
        outliers <- abs(Y - median(Y)) > 1.5 * IQR(Y) | abs(X - median(X)) > 1.5 * IQR(X) | wrong.sign
        if(all(outliers)) outliers <- wrong.sign
        if(all(wrong.sign)) {
            w.tmp <- scale
            warning(paste0("Sample @", t,' has a negative biomass estimation!'))
        }else{
            ## OLS
            model <- lm(Y[!outliers]~X[!outliers]-1)
            w.tmp <- abs(model$coeff[1])
        }
        mse <- (X*w.tmp-Y)^2
        names(w.tmp) <- NULL
        list(w.tmp, mse)
    }

    mse.mat <- (matrix(unlist((w.list[[2]])), nrow(tss)-1)) ##* apply(abs(Xs),2,function(x)x/sum(x))
    w <- unlist(w.list[[1]])

    mse <- mean(c(mse.mat), na.rm = TRUE)
    mse.weighted <- mean(apply(mse.mat,2,mean)*1/w, na.rm = TRUE)

    if(smooth){
        w <- foreach(i=unique(metadata$subjectID), .combine="c") %dopar%{
            sel <- metadata$subjectID==i
            brk <- unique(sort(c(which(diff(metadata[sel,5]) !=0) + 1,
                                 which(forceBreak[sel] == 1))))
            tmp <- abs(SmoothGradient(matrix(w[sel], ncol=1), metadata[sel, 4],
                               breaks = brk, deriv=0, smethod=1, norder=norder))
        }
    }

    if(!is.na(scale)){
        w <- w/median(w) * scale
    }
    normCounts <- t(sweep(tss, 2, w, '*'))
    list(biomass=w, normCounts=normCounts, mse=mse, mse.weighted=mse.weighted)
}

#' @title testStop
#' @description Function to determine whether to stop the EM
#' @param x a vector of mse trace
#' @param epsilon tolerance of mse
#' @return a boolean value about the termination
testStop <- function(x, epsilon=0.002, win=3){
    ## MSE plateau for stopIter iterations
    len <- length(x)
    ## moving window smoothing
    x <- sapply(win:len, function(i) abs( median(x[(i-win+1):i]) ) )
    len <- length(x)
    if(len > win){
        testMSE <- x[(len-win+1):len]
        if(all(abs(diff(testMSE))/(testMSE[-1]) <= epsilon)){
            return(TRUE)}
    }
    return(FALSE)
}

#' @title suggestRefs
#' @description Function to select references for ALR
#' @param dat input data in relative abundances
#' @param meta metadata following MDSINE's metadata format
#' @export
suggestRefs <- function(dat, meta){
    ##dat <- apply(dat,2,function(x)x/sum(x))
    sps <- rownames(dat)
    ##1. remove ref with 0 values
    message("The following species are not recommended due to 0 values:")
    fil1 <- rowSums(dat==0)/ncol(dat) > 0.05
    message(paste0(sps[fil1], collapse=', '))
    ##2. filtering two tails
    tmp <- rowMeans(apply(dat,2, function(x)x/sum(x)))
    fil2 <- tmp<0.05
    fil3 <- tmp==max(tmp)
    message("The following species are not recommended due to their low/high abudances:")
    message(paste0(sps[fil2|fil3], collapse=', '))
    cv <- foreach(s=unique(meta$subjectID), .combine=rbind) %do% {
        apply(dat[, meta$subjectID==s], 1, function(x) sd(x)/mean(x))
    }
    if(!is.null(dim(cv))){
        cv <- apply(cv,2,mean)
    }
    message("The following species is recommended as the reference:")
    sel <- names(sort(cv[!(fil1 | fil2 | fil3)])[1])
    message(sel)
    list(table=data.frame(cv=cv, index=1:length(cv), hasZero=fil1, isTooHigh=fil3, isTooLow=fil2)[order(cv),],
         selected=which(sps==sel))
}

#' @title EM
#' @description Function to estimate biomass and parameters simultaneously
#' @param dat input data following MDSINE's OTU table (i.e. variables in rows and samples in columns)
#' @param meta metadata following MDSINE's metadata format
#' @param forceBreak force to break the trajectory to handle pulsed perturbation (or species invasion) (default: NULL)
#' @param useSpline use spline to smooth data and calculate gradients (default: TRUE)
#' @param dev deviation (dev * mad) from the median to be considered as outliers (default: 5)
#' @param verbose print more information (default: TRUE)
#' @param refSp reference OTU for addative log ratio transformation (default: selected by BEEM)
#' @param warmup_iter number of iterations to skip for estimating parameters (default: min_iter/2)
#' @param max_iter maximal number of iterations for the EM algorithm (default: 100)
#' @param min_iter minimal number of iterations for the EM algorithm (default: 30)
#' @param converge_thres tolerance of change in mse to determine convergence (default: 1e-3)
#' @param ncpu maximal number of CPUs used (default:2)
#' @param seed seed used in BLASSO (default:NULL)
#' @param scaling median total biomass to scale all biomass data (default:1000)
#' @param norder order of spline basis (default: 3)
#' @export
EM <- function(dat, meta, forceBreak=NULL, useSpline=TRUE,
               dev=5, verbose=TRUE,
               refSp = NULL,
               warmup_iter = min_iter/2, min_iter = 30,  max_iter = 100, converge_thres=0.001,
               ncpu=2, seed=NULL, scaling=1000, norder=3){

    if(nrow(dat) < 7){
        message("[!]: There are less than 7 species. This might results in an inaccurate model.")
    }
    if(nrow(dat) * ncol(dat) < ncol(dat) + nrow(dat) * (nrow(dat) + 1) ) {
        message("[!]: You might have insufficient data for model fitting.")
    }
    if(length(unique(meta$subjectID)) < 10){
        message("[!]: Small number (<10) of biological replicates detected. Note that BEEM works best with >10 biological replicates or the time series contains intrinsic infrequent perturbations.")
    }
    refRank <- suggestRefs(dat, meta)
    if(median(refRank$table$cv, na.rm=TRUE) < 0.4 ){
        message("[!]: Low variation detected across time series. Are you sure the input data is not at equilibrium?")
    }
    if(is.null(refSp)){
        message("BEEM selecting reference species as default...")
        refSp <- refRank$selected
    }
    if(sum(dat[refSp,]==0)>0){
        message("[!]: The reference species has zero abundance in some samples. This will treated as non-zeros by adding a pseudo count.")
    }
    if(refRank$table[rownames(dat)[refSp], 1]>0.9) {
        message("[!]: The reference species has high CV (>90%). Parameter estiamtes might be inaccurate (check the trace of weighted mse for convergence).")
    }
    message(paste0("Reference species: ",  rownames(dat)[refSp]))
    ## assuming there is no perturbation for the moment
    if(ncol(meta) < 5){
        meta$perturbID <- 0
    }
    p <- nrow(dat)
    dat.tss <- apply(dat, 2, function(x)x/sum(x, na.rm = TRUE))
    if(verbose) message("Preprocessing data ...")
    tmpPreProcessed <- preProcess(dat, meta, rsp=refSp, dev=dev, scaling=scaling, smooth_data = TRUE, finite_diff=!useSpline, ncpu=ncpu, forceBreak=forceBreak)
    gradients.T <- tmpPreProcessed$alrGradient
    gradients <- t(gradients.T)
    perturbInd <- tmpPreProcessed$perturbInd
    isOutlier <- t(tmpPreProcessed$isOutlier)
    ##print(sum(c(isOutlier), na.rm = TRUE))
    ## if we know the species abundance should be 0, we force them to be outliers
    isOutlier[t(is.na(dat))[,-refSp]] <- TRUE

    ## initialization
    SpNames <- rownames(dat)
    dat.iter <- t(tmpPreProcessed$normData)
    biomass.traj <- data.frame("0"=rowSums(dat.iter))
    mse.traj <- c(Inf)
    mse.weighted.traj <- c(Inf)

    parm.traj <- apply(expand.grid(SpNames, SpNames), 1,
                       function(x) paste0(x[2], '->', x[1]))
    parm.traj <- c(paste0(NA, '->',SpNames), parm.traj)
    for(i in unique(meta[,5])){
        if(i!=0){
            parm.traj <- c(parm.traj, paste0("perturb" ,i, '->',SpNames))
        }
    }
    parm.traj <- data.frame(name=parm.traj)

    for(iter in 1:max_iter){
        if(verbose){
            message(paste0("##Iteration ", iter))
            message("####solve alpha and beta (E step)")
        }

        parms <- BLASSO(X=dat.iter,P=perturbInd,Ys=gradients,
                        Fs=isOutlier, ncpu=ncpu, rmSp=refSp, vnames=SpNames, seed=seed)

        alpha.v = parms$alpha.v
        beta.m <- parms$beta.m
        gamma.m <- parms$gamma.m
        mdsine <- parms$mdsine
        tmp <- mdsine$value
        parm.traj <- cbind(parm.traj, tmp)

        ## test for termination
        if(iter > min_iter && testStop(mse.traj, converge_thres)) break
        if(verbose) message( "####normalize (M step)####")

        tmp <- NORM(dat.tss, gradients.T, t(perturbInd), meta, refSp, list(alpha=alpha.v, beta=beta.m, gamma=gamma.m), ncpu=ncpu, scale=scaling, smooth=useSpline, forceBreak = forceBreak)
        biomass.traj <- cbind(biomass.traj, tmp$biomass)
        mse.traj <- c(mse.traj, tmp$mse)
        mse.weighted.traj <- c(mse.weighted.traj, tmp$mse.weighted)
        normCounts <- tmp$normCounts
        if(verbose) message(paste0("Weighted mse: ", tmp$mse.weighted))
        dat.iter <- normCounts
        if(verbose) message( "##########################")

    }
    if(iter == max_iter){
        message('[!] BEEM did not converge within the specified number of iterations.')
    }
    mse.traj[1:warmup_iter] <- Inf
    return(list(
        final.params=mdsine,
        trace.biomass=biomass.traj,
        trace.params=parm.traj,
        trace.mse=mse.traj,
        trace.mse.weighted=mse.weighted.traj,
        min.iter=min_iter,
        max.iter=max_iter,
        epsilon=converge_thres,
        refSp=refSp
        ) )
}

#' @title param.infer
#' @description Independent function for inferring parameters with Bayesian Lasso
#' @param dat input data following MDSINE's OTU table
#' @param metadata metadata following MDSINE's metadata format
#' @param biomass biomass data following MDSINE's biomass data format
#' @param forceBreak force to break the trajectory to handle pulsed perturbation (or species invasion) (default: NULL)
#' @param dev deviation (dev * mad) from the median to be considered as outliers (default:Inf, no filtering)
#' @param ncpu maximal number of CPUs used (default:4)
#' @param norder order of spline basis (default: 3)
#' @param infer_flag run inference (default:TRUE)
#' @export
param.infer <- function(dat, metadata, biomass,
                        forceBreak=NULL, dev=Inf, ncpu=4, norder=3, infer_flag=TRUE){
    registerDoMC(ncpu)
    log.transform <- function(x){
        tmp <- log(x)
        tmp[!is.finite(tmp)] <- 0
        tmp
    }
    dat[is.na(dat)] <- 0
    counts.tss <- t(apply(dat, 2, function(x)x/sum(x)))
    ## smooth to calculate gradient for log relative abundances
    dlnx_tilde_dt <- foreach(i=unique(metadata$subjectID), .combine='rbind') %do%{
        sel <- metadata$subjectID == i
        brk <- unique(sort(c(which(diff(metadata[sel,5]) !=0) + 1,
                             which(forceBreak[sel] == 1))))
        SmoothGradient(log.transform(counts.tss)[sel, ], metadata[sel, 4],
                       breaks=brk,method='pspline',smethod=3, deriv=1, ncpu=ncpu, norder=norder)
    }
    ## smooth to calculate gradient for log biomass
    dlnm_dt <- foreach(i=unique(metadata$subjectID), .combine='c') %do%{
        sel <- metadata$subjectID == i
        brk <- unique(sort(c(which(diff(metadata[sel,5]) !=0) + 1,
                             which(forceBreak[sel] == 1))))
        SmoothGradient(matrix(log.transform(biomass)[sel],ncol=1), metadata[sel, 4],
                       breaks=brk,method='pspline',smethod=3, deriv=1, ncpu=ncpu, norder=norder)
    }
    Ys <- dlnx_tilde_dt + dlnm_dt
    Xs <- exp(sweep(log.transform(counts.tss), 1, log.transform(biomass), '+'))
    if(infer_flag == FALSE) return(list(Ys=Ys, Xs=Xs))
    ## detect outliers
    isOutlier <- foreach(i=unique(metadata$subjectID), .combine='rbind') %dopar%{
        sel <- metadata$subjectID==i
        brk <- unique(sort(c(which(diff(metadata[sel,5]) !=0) + 1,
                             which(forceBreak[sel] == 1))))
        apply(Ys[sel,], 2, function(x)
            tsoutliers.w.brks(x,metadata[sel,4],brk,dev=dev) > 0)
    }
    BLASSO(X=Xs, P=NULL, Ys=Ys, Fs=isOutlier, ncpu=ncpu, rmSp=0, vnames=rownames(dat))
}

#' @title inspectEM
#' @description Diagnose the EM process
#' @param beem.obj BEEM output list
#' @export
inspectEM <- function(beem.obj){
    if(sum(beem.obj$final.params$parameter_type=='growth_rate') < 7){
        warning('You have less than 7 species. The estimation of parameters might be inaccurate.')
    }
    trace.mse.weighted <- beem.obj$trace.mse.weighted
    idx <- is.finite(beem.obj$trace.mse)
    if(min(trace.mse.weighted) > trace.mse.weighted[2]){
        warning('Optimization failed.') ## worse fit than CSS (first iteration)
        return(NA)
    }
    if( any(trace.mse.weighted[idx] > 1e-5) ){
        warning('Poor fitting detected.') ## iterations with large MSE
        return(NA)
    }
    return(0)
}

#' @title biomassFromEM
#' @description Inferring biomass from BEEM results
#' @param beem.obj BEEM output list
#' @param forceSkipWarning Use with caution! Force to skip model fit check.
#' @param dev tolerance in mse to select iterations for estimating parameters (default: 0.05)
#' @export
biomassFromEM <- function(beem.obj, forceSkipWarning=FALSE, dev=0.05){
    if(is.na( inspectEM(beem.obj) ) & !forceSkipWarning){
        message("BEEM failed... Consider increasing the number of samples or reducing the number of species.")
        return(NA)
    }
    trace.mse <- beem.obj$trace.mse
    min.mse <- min(trace.mse)
    em.idx <- which((trace.mse-min.mse) < dev*min.mse)

    if(length(em.idx)==1) {
        biomass <- beem.obj$trace.biomass[,em.idx]
    }else{
        biomass <- apply(beem.obj$trace.biomass[,em.idx],1,median)
    }
    biomass
}

#' @title paramFromEM
#' @description Inferring parameters from BEEM results
#' @param beem.obj BEEM output list
#' @param counts counts data following MDSINE's OTU table
#' @param metadata metadata following MDSINE's metadata format
#' @param sparse use the sparse mode to estimate the parameters (default: TRUE)
#' @param forceBreak force to break the trajectory to handle pulsed perturbation (or species invasion) (default: NULL)
#' @param ncpu maximal number of CPUs used (default:4)
#' @param enforceLogistic re-estimate the self-interaction parameters (enforce to negative values)
#' @param forceSkipWarning Use with caution! Force to skip model fit check.
#' @param dev tolerance in mse to select iterations for estimating parameters (default: 0.05)
#' @export
paramFromEM <- function(beem.obj, counts, metadata, sparse=TRUE,
                        forceBreak=NULL, ncpu=4, enforceLogistic=FALSE, dev=0.05, forceSkipWarning=FALSE){
    if(is.na( inspectEM(beem.obj) ) & !forceSkipWarning){
        message("BEEM failed... Consider increasing the number of samples or reducing the number of species.")
        return(NA)
    }
    registerDoMC(ncpu)
    trace.mse <- beem.obj$trace.mse
    min.mse <- min(trace.mse)
    em.idx <- which((trace.mse-min.mse) < dev*min.mse)

    refSp <- beem.obj$refSp
    if(length(em.idx)==1) {
        beem.biomass <- beem.obj$trace.biomass[,em.idx]
        beem.param <- beem.obj$trace.params[,em.idx]
    }else{
        beem.biomass <- apply(beem.obj$trace.biomass[,em.idx],1,median)
        beem.param <- apply(beem.obj$trace.params[,em.idx],1,median)
    }

    if(!sparse){
        message('Re-estimating parameters with the non-sparse mode...')
        return(param.infer(dat=counts, metadata=metadata, biomass=beem.biomass,
                       forceBreak=forceBreak, ncpu=ncpu)$mdsine)
    }

    p <- nrow(counts)
    ## solve for interaction matrix
    beem.a <- beem.param[1:p]
    beem.b <- matrix(beem.param[-(1:p)],p,p)
    beem.b.median <- apply(beem.b[-refSp,],2,median)
    beem.beta <- t(t(beem.b) - beem.b.median)

    ## significance
    tmp <- beem.beta
    diag(tmp) <- NA
    beem.sig <- abs(beem.beta)/sd(tmp,na.rm = T)
    ## growth rate for reference species
    tmp <- param.infer(dat=counts, metadata=metadata, biomass=beem.biomass,
                       forceBreak=forceBreak, ncpu=ncpu, infer_flag=FALSE)
    Xs <- tmp$Xs
    Ys <- tmp$Ys
    beem.alpha <- foreach(idx=1:p, .combine =c) %dopar%{
        tmp <- (Ys[,idx] - (beem.beta %*% t(Xs))[idx,])
        ## tmp <- tmp[(tmp-median(tmp)) <= 2*IQR(tmp)]
        median(tmp[tmp>0])
    }
    if(any(beem.alpha<0) || any(is.na(beem.alpha))) {
        message("Warning: Not enough time points to enforce positive growth rate.")
    }
    ## fix self interaction
    if (enforceLogistic){
        beem.diag <- foreach(idx=1:p, .combine =c) %dopar%{
            beem.tmp <- beem.beta
            diag(beem.tmp) <- 0
            tmp <- (Ys[,idx] - (beem.tmp %*% t(Xs))[idx,] - beem.alpha[idx])/Xs[,idx]
            tmp <- tmp[(tmp-median(tmp)) <= 2*IQR(tmp)]
            median(tmp[tmp<0])
        }
        diag(beem.beta) <- beem.diag
    }

    beem.MDSINE <- beem.obj$final.params
    beem.MDSINE$value <- c(beem.alpha, c(beem.beta))
    beem.MDSINE$significance <- c(rep(10000,p), c(beem.sig))
    if (enforceLogistic){
        beem.MDSINE$significance[beem.MDSINE$parameter_type=='interaction' & beem.MDSINE$source_taxon == beem.MDSINE$target_taxon ] <- rep(10000,p)
    }
    beem.MDSINE
}


pdf_file<-"pdf/pyramids_multicoloured.pdf"
cairo_pdf(bg="grey98", pdf_file,width=9,height=9)

par(mai=c(0.5,1,0.5,0.5),omi=c(0.5,0.5,0.5,0.5),family="Lato Light",las=1)

# Import data and prepare chart

myWomen<-read.csv("myData/women.txt",header =F,sep=",")
for(i in 1:111) colnames(myWomen)[i]<-paste("x",i+1949,sep="")
myMen<-read.csv("myData/men.txt",header =F,sep=",")
for(i in 1:111) colnames(myMen)[i]<-paste("x",i+1949,sep="")

right<-myWomen$x2010
left<-myMen$x2010

myColour_right<-c(rep(rgb(210,210,210,maxColorValue=255),15),rep(rgb(144,157,172,maxColorValue=255),50),rep(rgb(225,152,105,maxColorValue=255),length(right)-65))
myColour_left<-myColour_right

# Create chart and other elements

barplot(right,axes=F,horiz=T,axis.lty=0,border=NA,col=myColour_right,xlim=c(-750,750))
barplot(-left,axes=F,horiz=T,axis.lty=0,border=NA,col=myColour_left,xlim=c(-750,750),add=T)

abline(v=0,lwd=28,col=par("bg"))
for (i in seq(10,90,by=10)) text(0,i+i*0.2,i,cex=1.1)
mtext(abs(seq(-600,600,by=200)),at=seq(-600,600,by=200),1,line=-1,cex=0.80)

rect(-1000,15+15*0.2,1000,66+66*0.2,xpd=T,col=rgb(210,210,210,90,maxColorValue=255), border=NA)

mtext("working age",2,line=1.5,las=3,adj=0.38)
mtext("Men",3,line=-5,adj=0.25,cex=1.5,col="grey")
mtext("Women",3,line=-5,adj=0.75,cex=1.5,col="grey")

# Titling

mtext("Age structure of the population in Germany in 2010",3,line=-1.5,adj=0,cex=1.75,family="Lato Black",outer=T)
mtext("Values in thousands per year of age",3,line=-3.25,adj=0,cex=1.25,font=3,outer=T)
mtext("Source: www.destatis.de/bevoelkerungspyramide/",1,line=0,adj=1.0,cex=0.95,font=3,outer=T)
dev.off()


library(sp)
library(raster)
library(rgdal)

boxes <- list(
    matrix(c(-180, -90, 180, -66.56325), nrow=2),
    matrix(c(-180, -66.56325, 180, -56.04217), nrow=2),
    matrix(c(-180, -56.04217, 180, -45.52108), nrow=2),
    matrix(c(-180, -45.52108, 180, -35 ), nrow=2),
    matrix(c(-180, -35, 180, -23.43674), nrow=2),
    matrix(c(-180, -23.43674, 180, -11.71837), nrow=2),
    matrix(c(-180, -11.71837, 180, 0), nrow=2),

    matrix(c(-180, 0, 180, 11.71837), nrow=2),
    matrix(c(-180, 11.71837, 180, 23.43674), nrow=2),
    matrix(c(-180, 23.43674, 180, 35), nrow=2),
    matrix(c(-180, 35, 180, 45.52108), nrow=2),
    matrix(c(-180, 45.52108, 180, 56.04217), nrow=2),
    matrix(c(-180, 56.04217, 180, 66.56325), nrow=2),
    matrix(c(-180, 66.56325, 180, 90), nrow=2)
)

boxes <- lapply(boxes, function(x) {
    x <- as(raster::extent(x), "SpatialPolygons")
    proj4string(x) <- "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"
    x
})

boxes <- raster::bind(boxes)

names <- c("Tropics 1", "Tropics 2", "Subtropics", "Temperate 1", "Temperate 2", "Temperate 3", "Polar")
unique <- c(
    paste0("S ", rev(names)),
    paste0("N ", names)
)
boxes <- SpatialPolygonsDataFrame(
    boxes,
    data.frame(
        id=1:length(boxes),
        name = unique,
        type = c(rev(names), names),
        NS = c(rep("S", length(names)), rep("N", length(names))))
)

file <- "2020-12-09-latitude-boxes.gpkg"
writeOGR(boxes, layer = 'poly', dsn = file, driver="GPKG")

df <- fread("C:/_dev/gis.csv")
df[, sum := sum(area), by = "GID_0"][
    , prop := area/sum, by = c("GID_0", "name")][, sum := NULL]
df <- df[order(GID_0, name, prop)]
df <- df[!duplicated(df[,c("GID_0")]),]

write.csv(df, "test.csv")


nonzeroRequirment = function(varnames) {

  len = length(varnames)
  vars = vector(mode = "integer", length = len*len)
  mat = matrix(vars, nrow = len, ncol = len, byrow=TRUE,
               dimnames = list(
                 n=sprintf("req.gt0%s",varnames)))

  for(i in 1:len) {
    mat[i,i] = -1
  }
  return(mat)
}

nonzeroConstraint = function(varnames) {

  len = length(varnames)
  vars = vector(mode = "integer", length = len)
  mat = matrix(vars, nrow = len, ncol = 1, byrow=TRUE,
               dimnames = list(
                 n=sprintf("con.gt0%s",varnames)))

  return(mat)
}


select_regression_response_columns <- function(data) {

  stopifnot(data %>% is.data.frame())
  stopifnot(data %>% nrow() >= 3)
  stopifnot(data %>% ncol() >= 2)

  column_names <- data %>% colnames()

  class_filter <- function(x) { x == "numeric" || x == "integer" }
  class_filter_result <-
    data %>%
    sapply(class) %>%
    sapply(class_filter) %>%
    column_names[.]

  if((class_filter_result %>% length()) == 0) return(c())

  variability_filter <- function(x) { x > 1 }
  variability_filter_result <-
    data[class_filter_result] %>%
    lapply(unique) %>%
    lapply(length) %>%
    sapply(variability_filter) %>%
    class_filter_result[.]

  if((variability_filter_result %>% length()) == 0) return(c())

  variability_filter_result
}


# Expanding datasets

# A. Creating unique combinations of vectors
# 1. Letters of the genetic code
letters <- c("A", "C", "G", "U")

# Create a tibble with all possible 3 way combinations
codon_df <- expand_grid(
  letter1 = letters,
  letter2 = letters,
  letter3 = letters
)

codon_df %>%
  # Unite these three columns into a "codon" column
  unite("codon", letter1:letter3, sep = " ")

# 2. When did humans replace dogs in space
# Create a tibble with all combinations of years and species
full_df <- expand_grid(
  year = 1951:1970,
  species = c("Human", "Dog")
)

space_df %>%
  # Join with full_df so that missing values are introduced
  right_join(full_df, by = c("year", "species")) %>%
  # Overwrite NA values for n_in_space with 0L
  replace_na(list(n_in_space = 0L)) %>%
  # Create a line plot with n_in_space over year, color by species
  ggplot(aes(x = year, y = n_in_space, color = species)) +
  geom_line()

# 3. Finding missing observations
# Create a tibble with all combinations of dates and reactors
full_df <- expand_grid(
  date = dates,
  reactor = reactors
)

# Find the reactor - date combinations not present in reactor_df
full_df %>%
  anti_join(
    reactor_df, by = c("date", "reactor")
  )

# B. Completing data with all value combinations
# 1. Completing the solar system
planets = c("Mercury", "Venus", "Earth", "Mars", "Jupiter", "Saturn", "Uranus", "Neptune")

planet_df %>%
  complete(
    # Complete the planet variable
    planet = planets,
    # Overwrite NA values for n_moons with 0L
    fill = list(n_moons = 0L)
  )

# 2. Zero olympic medals
medal_df %>%
  # Count the medals won per team and year
  count(team, year, name = "n_medals") %>%
  # Complete the team and year variables, fill n_medals with zeros
  complete(
    team, year, fill = list(n_medals = 0L)
  ) %>%
  # Plot n_medals over year, colored by team
  ggplot(aes(x = year, y = n_medals, color = team)) +
  geom_line() +
  scale_color_brewer(palette = "Paired")

# 3. Creating a full_seq()
# Generate all years from 2020 to 2030
years <- full_seq(c(2020, 2030), period = 1)
years

# Generate all decades from 1980 to 2030
decades <- full_seq(c(1980, 2030), period = 10)
decades

outer_dates <- c(as.Date("1980-01-01"), as.Date("1980-12-31"))

# Generate the dates for all days in 1980
full_seq(outer_dates, period = 1)

# 4. The Cold War's hottest year
cumul_nukes_1962_df %>%
  # Complete the dataset
  complete(country, date = full_seq(date, period = 1)) %>%
  # Group the data by country
  group_by(country) %>%
  # Impute missing values with the last known observation. Default is "down"
  fill(total_bombs) %>%
  # Plot the number of bombs over time, color by country
  ggplot(aes(x = date, y = total_bombs, color = country)) +
  # These two lines will mark the Cuban Missile Crisis
  geom_rect(xmin = as.Date("1962-10-16"), xmax = as.Date("1962-10-29"), ymin = -Inf, ymax = Inf, color = NA)+
  geom_text(x = as.Date("1962-10-22"), y = 15, label = "Cuban Missile Crisis", angle = 90, color = "white")+
  geom_line()

# D. Advanced completions
# 1. Olympic medals per continent. Comparison across summer and winter games
medal_df %>%
  # Give each continent an observation at each Olympic event. nesting: maintains relationship to avoid non-sensical connections
  complete(
    continent,
    nesting(season, year),
    fill = list(medals_per_participant = 0L)
  ) %>%
  # Plot the medals_per_participant over time, colored by continent
  ggplot(aes(x = year, y = medals_per_participant, color = continent)) +
  geom_line() +
  facet_grid(season ~ .)

# 2. Tracking a virus outbreak
patient_df %>%
  # Pivot the infected and recovered columns to long format
  pivot_longer(-patient, names_to = "status", values_to = "date") %>%
  select(-status) %>%
  # Group by patient
  group_by(patient) %>%
  # Complete the date range per patient using full_seq()
  complete(date = full_seq(date, period = 1)) %>%
  # Ungroup the data
  ungroup() %>%
  # Count the dates, the count goes in the n_sick variable
  count(date, name = "n_sick") %>%
  ggplot(aes(x = date, y = n_sick))+
  geom_line()

# 3. Counting office occupants
sensor_df %>%
  # Complete the time column with a 20 minute interval
  complete(time = seq(min(time), max(time), by = "20 min"),
           fill = list(enter = 0L, exit = 0L)) %>%
  # Calculate the total number of people inside
  mutate(total_inside = cumsum(enter + exit)) %>%
  # Pivot the enter and exit columns to long format
  pivot_longer(enter:exit, names_to = "direction", values_to = "n_people") %>%
  # Plot the number of people over time, fill by direction
  ggplot(aes(x = time, y = n_people, fill = direction)) +
  geom_area() +
  geom_line(aes(y = total_inside))


equity.history <- function(symbol, from=NULL, to=Sys.Date(), source='yahoo', period='days') {
    ## function returns a dataframe of adjusted prices
    ## period = 'days' (default), 'weeks', 'months', 'quarters', or 'years'

    ## e.g., equity.history(c("SPY","EFA", "IJS", "EEM","AGG"), from='2005-01-01')
    ##       equity.history(c("SPY","EFA", "IJS", "EEM","AGG"), from='2005-01-01')

    ## install.packages('quantmod')

    ## Download historical info into dataframes with each symbol name.
    ## The last column from yahoo is the adjusted price.
    ## "While closing price merely refers to the cost of shares at the end of the day,
    ##  the adjusted closing price considers other factors like dividends, stock splits,
    ##  and new stock offerings. Since the adjusted closing price begins where the
    ##  closing price ends, it can be called a more accurate measure of stocks' value"
    if (is.null(to)) to <- Sys.Date()

    ## get XTS object for symbol with historical closing price and adjusted price
    ## quantmod::getSymbols('SPY', src='yahoo')
    quantmod::getSymbols(symbol,
                         src = source,
                         auto.assign = TRUE,
                         warnings = FALSE)

    ## copy XTS OHLCV format data for 1st symbol to variable asset
    asset <- get(symbol[1])

    ## days the market is open
    market.open.days <- as.Date( zoo::index(asset) )

    ## last market day of each month
    asset.months <- xts::to.period(asset, period='months')
    market.open.months <- as.Date( zoo::index(asset.months) )

    ## last market day of each year
    asset.years  <- xts::to.period(asset, period='years')
    market.open.years  <- as.Date( zoo::index(asset.years) )

    if (period != 'days') {
        ## convert OHLCV format data to some other period
        asset <- xts::to.period(asset, period=period)
    }

    ## find column numbers with closing and adjusted prices
    colclose <- which(grepl('Close',    names(asset)))
    coladj   <- which(grepl('Adjusted', names(asset)))

    ## copy 1st asset information into XTS objects for closing and adjusted prices
    closeprice <- asset[, colclose]
    adjprice   <- asset[, coladj]

    ## merge adjusted prices for additional symbols, if any
    if (length(symbol) > 1) {
        for (i in 2:length(symbol)) {
            asset <- get(symbol[i])
            if (period != 'days') {
                ## convert OHLCV format data to some other period
                asset <- xts::to.period(asset, period=period)
            }
            closeprice <- merge(closeprice, asset[, colclose])
            adjprice   <- merge(adjprice  , asset[, coladj])
        }
    }

    ## fix names and return
    names(closeprice) <- symbol
    names(adjprice)   <- symbol

    ## approximate any missing prices
    closeprice <- zoo::na.approx(closeprice)
    adjprice   <- zoo::na.approx(adjprice)

    ## calculate incremental TWR
    twri  <- adjprice / xts::lag.xts(adjprice, 1) - 1
    ## remove 1st row since NA
    twri <- twri[-1,]

    ## ## the following does the same with matrices
    ## ## calculate return
    ## ## convert to matrix until maybe someday if I learn xts
    ## adjpricem <- as.matrix(adjprice)
    ## nrows <- nrow(adjpricem)
    ## twrim <- adjpricem[2:nrows,] / adjpricem[1:(nrows-1),] - 1
    ## ## convert back to xts
    ## ## twri <- xts::as.xts(twrim)

    ## extract dates as a vector of dates
    dates <- as.Date( zoo::index( twri ) )
    if (is.null(from)) from  <- dates[1]

    ## restrict to duration
    ## xtsrange <- paste('"', noquote(duration[1]), '/', noquote(duration[2]), '"', sep='')
    xtsrange <- paste(noquote(from), '/', noquote(to), sep='')
    xtsrange
    twri <- twri[xtsrange]

    ## figure out how to divide xts object by a vector
    ## ## create test xts1 object
    ## a <- rbind(0.1, 0.2, 0.3)
    ## b <- rbind(0.01, 0.02, 0.03)
    ## xts1 <- xts::xts(cbind(a,b), order.by=Sys.Date()-3:1)
    ## ## calculate cumulative TWR
    ## twrcum_test <- t(t(cumprod(xts1+1)) / as.vector(xts1[1,]+1) - 1)
    ## class(twrcum_test)
    ## convert back to xts
    ## twrcum_test <- xts::as.xts( twrcum_test )

    ## calculate twrcum and standard deviation
    ## 1st date should have twrcum = 0
    twrcum <- xts::as.xts( t(t(cumprod(twri+1)) / as.vector(twri[1,]+1) - 1) )
    std    <- apply(twri[2:nrow(twri),], 2, sd, na.rm=TRUE)

    return(list(close = closeprice, adjprice = adjprice, twri=twri, twrcum=twrcum, std=std,
                market.open.days   = market.open.days,
                market.open.months = market.open.months,
                market.open.years  = market.open.years))
}

## out  <- equity.history(c('SPY', 'IWM', 'EFA', 'AGG', 'SHV'), from='1995-01-01', period='years')
## twri <- out$twri


## About:
## This function is to make subject-specific prediction based
## on an existing fit of class "face_sparse".

## Function arguments:

## "fit": an object of class "face_sparse"
## "Y.pred": a data frame with three arguments:
# (1) "argvals": observation times;
# (2) "subj": subject indices;
# (3) "y": values of observations;
## NA values are allowed in "y" but not in the other two.

predict.face.sparse <- function(object,newdata,...){

  ## check inputs
  if(class(object)!="face.sparse") stop("'fit' has to be a face.sparse object")
  check.data(newdata,type="predict")

  subj.pred = newdata$subj
  subj_unique.pred = unique(subj.pred)
  y.pred = newdata$y

  Theta = object$Theta
  knots = object$knots
  npc = object$npc
  p = object$p

  center = object$center
  #const.var.error = object$const.var.error
  fit_mean = object$fit_mean
  #fit_var_error = object$fit_var_error
  sigma2 = object$sigma2

  mu.pred <- rep(0,nrow(newdata))
  var.error.pred <- rep(max(sigma2,0.000001),nrow(newdata))
  cov.pred <-  matrix(0,length(mu.pred),length(mu.pred))

  if(center) {mu.pred <- predict.pspline.face(fit_mean,newdata$argvals) }
  #if(!const.var.error){
  #  var.error.pred <- predict.pspline(fit_var_error,newdata$argvals)
  #  var.error.pred <-  sapply(var.error.pred,function(x) max(x,0))### added Sept 8, 2015 by Luo
  #}

  Bnew = spline.des(knots=knots, x=object$argvals.new, ord = p+1,outer.ok = TRUE,sparse=TRUE)$design
  scores = list(subj=subj_unique.pred,
                scores = matrix(NA,nrow=length(subj_unique.pred),ncol=npc),
                u = matrix(NA,nrow=length(subj_unique.pred),ncol=nrow(Theta))
                )

  for(i in 1:length(subj_unique.pred)){
    sel.pred = which(subj.pred==subj_unique.pred[i])
    pred.points <- newdata$argvals[sel.pred]
    mu.predi <- mu.pred[sel.pred]
    var.error.predi <- var.error.pred[sel.pred]

    y.predi = y.pred[sel.pred] - mu.predi
    sel.pred.obs = which(!is.na(y.predi))
    obs.points <- pred.points[sel.pred.obs]

    if(!is.null(obs.points)){
      var <- mean(var.error.predi[sel.pred.obs])
      if(var==0&length(sel.pred.obs) < npc)
        stop("Measurement error estimated to be zero and there are fewer observed points thans PCs; scores
               cannot be estimated.")
      B3i.pred = spline.des(knots=knots, x=pred.points, ord = p+1,outer.ok = TRUE,sparse=TRUE)$design
      B3i = spline.des(knots=knots, x=obs.points, ord = p+1,outer.ok = TRUE,sparse=TRUE)$design
      Chati = tcrossprod(B3i%*%Theta,B3i)

      if(length(sel.pred.obs)==1) Ri = var.error.predi[sel.pred.obs]
      if(length(sel.pred.obs)>1) Ri = diag(var.error.predi[sel.pred.obs])
      Vi.inv = as.matrix(solve(Chati + Ri))
      Vi.pred = as.matrix(tcrossprod(B3i.pred%*%Theta,B3i.pred))
      Hi = as.matrix(B3i.pred%*%tcrossprod(Theta,B3i)%*%Vi.inv)
      ui =tcrossprod(Theta,B3i)%*%Vi.inv %*%y.predi[sel.pred.obs]
      scores$u[i,] = as.vector(ui)
      y.pred[sel.pred] = as.numeric(Hi%*%y.predi[sel.pred.obs]) + mu.predi
      temp = as.matrix(B3i.pred%*%tcrossprod(Theta,B3i))
      if(length(sel.pred.obs) >1){
        cov.pred[sel.pred,sel.pred] = Vi.pred - temp%*%Vi.inv%*%t(temp)
      }
      if(length(sel.pred.obs) ==1){
        cov.pred[sel.pred,sel.pred] = Vi.pred - Vi.inv[1,1]*temp%*%t(temp)
      }
      ## predict scores
      if(object$calculate.scores==TRUE){
        temp = matrix(t(object$eigenfunctions),nrow=npc)%*%(as.matrix(Bnew)%*%ui)/sum(object$eigenfunctions[,1]^2)
        temp = as.matrix(temp)
        scores$scores[i,1:npc] = temp[,1]
      }
    }
  }

  B = spline.des(knots=knots, x=newdata$argvals, ord = p+1,outer.ok = TRUE,sparse=TRUE)$design
  Chat.pred = as.matrix(tcrossprod(B%*%Matrix(Theta),B))

  return(list(object=object,newdata=newdata,y.pred = y.pred,mu.pred=mu.pred,var.error.pred=var.error.pred,
              scores = scores, cov.pred = cov.pred, se.pred = sqrt(diag(cov.pred)),
              Chat.pred = Chat.pred,Chat.diag.pred = diag(Chat.pred)))
}


# 3. faza: Vizualizacija podatkov

# Prenocitve, tipi turisticnih obcin

graf.prenocitve.tipi <- function(datoteka){
  graf <- ggplot(datoteka) +
    aes(x=Leto, y=Stevilo, group=Tip, colour=Tip) +
    geom_point(size=2) +
    geom_line(size=1) +
    labs(title="Število prenočitev po tipu občin",
        y="Število prenočitev (milijoni)", x="Leto") +
    theme_hc() +
    scale_x_continuous(limits=c(2010, 2019), breaks=seq(2010, 2019, 1)) +
    scale_y_continuous(limits=c(0, 5),
                              breaks=seq(0,5, 0.5)) +
    scale_color_discrete(name = "Tip občine")
  return(graf)
}

graf.prenocitve.tipi <- graf.prenocitve.tipi(prenocitve.tipi.mio)

# Stolpicni diagram vseh gostov

gostje <- vsi.gosti[-c(34:66),] %>%
  filter(Leto %in% c(2000:2020))

gostje.mio <- gostje %>% mutate(Stevilo = Stevilo / 1000000)

diagram.vseh.gostov <- ggplot(gostje.mio) +
  aes(x=Leto, y=Stevilo, fill=Tip) +
  geom_bar(stat="identity", position = "dodge") +
  labs(title = "Število vseh gostov ", y="Število gostov (milijoni)",
       x="Leto") + theme_bw() +
  scale_x_continuous(limits=c(1999, 2021), breaks=seq(2000, 2020, 2)) +
  scale_y_continuous(limits=c(0, 5),
                     breaks=seq(0,5, 0.5)) +
  scale_color_discrete(name = "Gosti")

# Graf vseh prenocitev

prenocitve <- filter(vse.prenocitve, Tip=="Skupaj",
                     Leto %in% c(2000:2020)) %>%
  mutate(Stevilo = Stevilo / 1000000)

graf.vseh.prenocitev <- ggplot(prenocitve) +
  aes(x=Leto, y=Stevilo) +
  geom_point(size=2) +
  geom_line(size=1, colour="blue") +
  scale_y_continuous(limits=c(5,16),
                     breaks=seq(5, 16, 1)) +
  scale_x_continuous(limits=c(2000, 2020), breaks=seq(2000, 2020, 2)) +
  labs(title="Število vseh prenočitev", y="Število prenočitev (milijoni)") +
  theme_hc()

# Zemljevid obcin

zemljevid <- function(datoteka){
obcine <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/OB.zip", "OB",
                          pot.zemljevida="OB", encoding="Windows-1250")
proj4string(obcine) <- CRS("+proj=utm +zone=10+datum=WGS84")
tm_shape(obcine) + tm_polygons("OB_UIME") + tm_legend(show=FALSE)
obcine$OB_UIME <- as.factor(obcine$OB_UIME)

lvls <- levels(obcine$OB_UIME) %>% str_replace("Slov[.]", "Slovenskih") %>%
  sort()

prihodi <- datoteka$Obcina %>%
  str_replace(" - ","-") %>%
  str_replace("/.*","") %>%
  str_replace("Slov[.]", "Slovenskih") %>%
  sort() %>% parse_factor()

obcine_prihodi2 <- datoteka
obcine_prihodi2$Obcina <- prihodi

zdruzena <- merge(obcine, obcine_prihodi2, by.x="OB_UIME", by.y="Obcina")
zdruzena$Stevilo[95] <- 0
obcine_podatki <- data.frame("id"=zdruzena$OB_ID, "Stevilo"=zdruzena$Stevilo)
obcine_podatki <- mutate(obcine_podatki, id = as.character(obcine_podatki$id))
zdruzena_fort <- tidy(zdruzena, region="OB_ID")

fort_stevilo <- zdruzena_fort %>% left_join(obcine_podatki, by="id")

vrednosti <- round((quantile(obcine_prihodi_2018$Stevilo) + quantile(obcine_prihodi_2018$Stevilo)) / c(2, 2, 2, 2, 2))

brezOzadja <- theme_bw() +
  theme(
    axis.line=element_blank(),
    axis.text.x=element_blank(),
    axis.text.y=element_blank(),
    axis.ticks=element_blank(),
    axis.title.x=element_blank(),
    axis.title.y=element_blank(),
    panel.background=element_blank(),
    panel.border=element_blank(),
    panel.grid.major=element_blank(),
    panel.grid.minor=element_blank(),
    plot.background=element_blank()
  )

legenda <- c("Prvi skupina", "Druga skupina", "Tretja skupina", "Četrta skupina")

zemljevid <- fort_stevilo %>% mutate(vrednost=factor(findInterval(fort_stevilo$Stevilo,
                                       vrednosti, all.inside=TRUE))) %>%
  ggplot() + geom_polygon(color="black", size=0.001) +
  aes(x=long, y=lat, group=group, fill=vrednost) +
  scale_fill_brewer(type = 4, palette="Reds", labels=legenda) +
  labs(title="Število prihodov po posameznih občinah") +
  guides(fill=guide_legend(title="Število prihodov")) +
  brezOzadja

return(zemljevid)
}

zemljevid_2019 <- zemljevid(obcine_prihodi_2019)
zemljevid_2018 <- zemljevid(obcine_prihodi_2018)

# Graf rasti stevila prenocitvenih zmogljivosti

kapacitete.vrste.obcin$Rast <- 0

zdraviliske.obcine <- subset(kapacitete.vrste.obcin, Tip=="Zdraviliške občine")
gorske.obcine <- subset(kapacitete.vrste.obcin, Tip=="Gorske občine")
obmorske.obcine <- subset(kapacitete.vrste.obcin, Tip=="Obmorske občine")
ljubljana <- subset(kapacitete.vrste.obcin, Tip=="Ljubljana")
mestne.obcine <- subset(kapacitete.vrste.obcin, Tip=="Mestne občine")
ostale.obcine <- subset(kapacitete.vrste.obcin, Tip=="Ostale občine")

rast <- function(data){
  k <- ncol(data)
  for (n in c(2:10)){
    data[n,k] <- (data[n,k-1] - data[n-1,k-1]) / data[n-1,k-1] * 100
  }
  data[,k] <- round(data[,k], digits=2)
  return(data)
}

zdraviliske.obcine.rast <- rast(zdraviliske.obcine)
gorske.obcine.rast <- rast(gorske.obcine)
obmorske.obcine.rast <- rast(obmorske.obcine)
ljubljana.rast <- rast(ljubljana)
mestne.obcine.rast <- rast(mestne.obcine)
ostale.obcine.rast <- rast(ostale.obcine)

kapacitete.vrste.obcin.rast <- data.frame(rbind(zdraviliske.obcine.rast,
  gorske.obcine.rast, obmorske.obcine.rast, ljubljana.rast,
  mestne.obcine.rast, ostale.obcine.rast))

graf.zmogljivosti.rast <- ggplot(kapacitete.vrste.obcin.rast) +
  aes(x=Leto, y=Rast, colour=Tip) +
  geom_point(size=2) +
  geom_line(size=1) +
  facet_wrap(.~Tip, ncol=2) +
  labs(title="Rast prenocitvenih zmogljivosti za posamezen tip turističnih občin",
       y="Rast prenocitvenih zmogljivosti (%)", x="Leto") +
  scale_x_continuous(limits=c(2010, 2019), breaks=seq(2010, 2019, 2)) +
  scale_y_continuous(limits=c(-20, 20), breaks=seq(-20, 20, 10)) +
  scale_color_discrete(name = "Tip občine")

# Graf prenocitvenih zmogljivosti

kapacitete.vrste.obcin.tisoci <- kapacitete.vrste.obcin %>%
  mutate(Stevilo = Stevilo / 1000)

graf.zmogljivosti.tipi <- ggplot(kapacitete.vrste.obcin.tisoci) +
  aes(x=Leto, y=Stevilo, group=Tip, colour=Tip) +
  geom_point(size=2) +
  geom_line(size=1) +
  labs(title="Prenočitvene zmogljivosti za posamezen tip turističnih občin",
       y="Prenočitvena zmogljivost (tisoči)", x="Leto") +
  scale_x_continuous(limits=c(2010, 2019), breaks=seq(2010, 2019, 3)) +
  facet_wrap(.~Tip, ncol=2, scales="free") +
  scale_color_discrete(name = "Tip občine")


#' deficitsat
#'
#' Computes saturation deficit in hPa. This is air dryness evaluation.
#'
#' @param t  numeric Air temperature in degC.
#' @param rh numeric Relative humidity in percentage.
#' @return deficit of saturation
#'
#'
#' @author  Istituto per la Bioeconomia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibe.cnr.it}
#'
#' @export
#'
#'
#'
#'

deficitsat=function(t,rh) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=deficitsat(t[i],rh[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


# qvalue() function extracted from the package "qvalue"
# by Alan Dabney and John D. Storey, with assistance from Gregory R. Warnes
#
# DESCRIPTION file follows:
#
# Package: qvalue
# Title: Q-value estimation for false discovery rate control
# Version: 1.32.0
# Author: Alan Dabney <adabney@u.washington.edu> and John D. Storey
# <jstorey@u.washington.edu>, with assistance from Gregory R.
# Warnes <gregory_r_warnes@groton.pfizer.com>
#
# Description: This package takes a list of p-values resulting from the
# simultaneous testing of many hypotheses and estimates their
# q-values. The q-value of a test measures the proportion of
# false positives incurred (called the false discovery rate)
# when that particular test is called significant. Various plots
# are automatically generated, allowing one to make sensible
# significance cut-offs. Several mathematical results have
# recently been shown on the conservative accuracy of the
# estimated q-values from this software. The software can be
# applied to problems in genomics, brain imaging, astrophysics,
# and data mining.
# Maintainer: John D. Storey <jstorey@u.washington.edu>
# 	Imports: graphics, stats
# License: LGPL
# biocViews: MultipleComparisons
# Packaged: 2012-10-02 02:49:23 UTC; biocbuild
# InstallableEverywhere: yes

qvalue <- function(p=NULL, lambda=seq(0,0.90,0.05), pi0.method="smoother", fdr.level=NULL, robust=FALSE,
									 gui=FALSE, smooth.df = 3, smooth.log.pi0 = FALSE) {

	#This is just some pre-processing
	if(is.null(p))  ## change by Alan
	{qvalue.gui(); return("Launching point-and-click...")}
	if(gui & !interactive())  ## change by Alan
		gui = FALSE

	if(min(p)<0 || max(p)>1) {
		if(gui) ## change by Alan:  check for GUI
			eval(expression(postMsg(paste("ERROR: p-values not in valid range.", "\n"))), parent.frame())
		else
			print("ERROR: p-values not in valid range.")
		return(0)
	}
	if(length(lambda)>1 && length(lambda)<4) {
		if(gui)
			eval(expression(postMsg(paste("ERROR: If length of lambda greater than 1, you need at least 4 values.",
																		"\n"))), parent.frame())
		else
			print("ERROR: If length of lambda greater than 1, you need at least 4 values.")
		return(0)
	}
	if(length(lambda)>1 && (min(lambda) < 0 || max(lambda) >= 1)) { ## change by Alan:  check for valid range for lambda
		if(gui)
			eval(expression(postMsg(paste("ERROR: Lambda must be within [0, 1).", "\n"))), parent.frame())
		else
			print("ERROR: Lambda must be within [0, 1).")
		return(0)
	}
	m <- length(p)
	#These next few functions are the various ways to estimate pi0
	if(length(lambda)==1) {
		if(lambda<0 || lambda>=1) { ## change by Alan:  check for valid range for lambda
			if(gui)
				eval(expression(postMsg(paste("ERROR: Lambda must be within [0, 1).", "\n"))), parent.frame())
			else
				print("ERROR: Lambda must be within [0, 1).")
			return(0)
		}

		pi0 <- mean(p >= lambda)/(1-lambda)
		pi0 <- min(pi0,1)
	}
	else {
		pi0 <- rep(0,length(lambda))
		for(i in 1:length(lambda)) {
			pi0[i] <- mean(p >= lambda[i])/(1-lambda[i])
		}

		if(pi0.method=="smoother") {
			if(smooth.log.pi0)
				pi0 <- log(pi0)

			spi0 <- smooth.spline(lambda,pi0,df=smooth.df)
			pi0 <- predict(spi0,x=max(lambda))$y

			if(smooth.log.pi0)
				pi0 <- exp(pi0)
			pi0 <- min(pi0,1)
		}
		else if(pi0.method=="bootstrap") {
			minpi0 <- min(pi0)
			mse <- rep(0,length(lambda))
			pi0.boot <- rep(0,length(lambda))
			for(i in 1:100) {
				p.boot <- sample(p,size=m,replace=TRUE)
				for(i in 1:length(lambda)) {
					pi0.boot[i] <- mean(p.boot>lambda[i])/(1-lambda[i])
				}
				mse <- mse + (pi0.boot-minpi0)^2
			}
			pi0 <- min(pi0[mse==min(mse)])
			pi0 <- min(pi0,1)
		}
		else {  ## change by Alan: check for valid choice of 'pi0.method' (only necessary on command line)
			print("ERROR: 'pi0.method' must be one of 'smoother' or 'bootstrap'.")
			return(0)
		}
	}
	if(pi0 <= 0) {
		if(gui)
			eval(expression(postMsg(
				paste("ERROR: The estimated pi0 <= 0. Check that you have valid p-values or use another lambda method.",
							"\n"))), parent.frame())
		else
			print("ERROR: The estimated pi0 <= 0. Check that you have valid p-values or use another lambda method.")
		return(0)
	}
	if(!is.null(fdr.level) && (fdr.level<=0 || fdr.level>1)) {  ## change by Alan:  check for valid fdr.level
		if(gui)
			eval(expression(postMsg(paste("ERROR: 'fdr.level' must be within (0, 1].", "\n"))), parent.frame())
		else
			print("ERROR: 'fdr.level' must be within (0, 1].")
		return(0)
	}
	#The estimated q-values calculated here
	u <- order(p)

	# change by Alan
	# ranking function which returns number of observations less than or equal
	qvalue.rank <- function(x) {
		idx <- sort.list(x)

		fc <- factor(x)
		nl <- length(levels(fc))
		bin <- as.integer(fc)
		tbl <- tabulate(bin)
		cs <- cumsum(tbl)

		tbl <- rep(cs, tbl)
		tbl[idx] <- tbl

		return(tbl)
	}

	v <- qvalue.rank(p)

	qvalue <- pi0*m*p/v
	if(robust) {
		qvalue <- pi0*m*p/(v*(1-(1-p)^m))
	}
	qvalue[u[m]] <- min(qvalue[u[m]],1)
	for(i in (m-1):1) {
		qvalue[u[i]] <- min(qvalue[u[i]],qvalue[u[i+1]],1)
	}
	#The results are returned
	if(!is.null(fdr.level)) {
		retval <- list(call=match.call(), pi0=pi0, qvalues=qvalue, pvalues=p, fdr.level=fdr.level, ## change by Alan
									 significant=(qvalue <= fdr.level), lambda=lambda)
	}
	else {
		retval <- list(call=match.call(), pi0=pi0, qvalues=qvalue, pvalues=p, lambda=lambda)
	}
	class(retval) <- "qvalue"
	return(retval)
}


 ZGTRFS Example Program Results

 Solution(s)
                    1                 2
 1  ( 1.0000, 1.0000) ( 2.0000,-1.0000)
 2  ( 3.0000,-1.0000) ( 1.0000, 2.0000)
 3  ( 4.0000, 5.0000) (-1.0000, 1.0000)
 4  (-1.0000,-2.0000) ( 2.0000, 1.0000)
 5  ( 1.0000,-1.0000) ( 2.0000,-2.0000)

 Backward errors (machine-dependent)
       2.2E-17    1.0E-16

 Estimated forward error bounds (machine-dependent)
       5.3E-14    7.7E-14


#!/bin/bash Rscript
require("lars")
require("stats")
lassopv<-function (x,y,normalize=TRUE,H0=c("spherical","normal"),log.p=FALSE,max.predictors=NULL,trace = FALSE,Gram,eps = .Machine$double.eps,max.steps,use.Gram=TRUE)
{
  dx=dim(x)[2]
  ds=dim(x)[1]
  if(ds!=length(y))
    stop("Incorrect dimensions for x or y. The number of rows in x should match the length of y.")
  if(is.null(max.predictors))
    max.predictors=dx
  else if(max.predictors<=0)
    stop("Incorrect max.predictors")

  isdone=rep(F,dx)
  if(dx==1)
  {
    ans=cor(drop(x),y)
    isdone[1]=T
  }
  else
  {
    #Normalize
    x=t(t(x)-colMeans(x))
    sx=sqrt(colMeans(x**2))
    y=y-mean(y)
    sy=sqrt(mean(y**2))
    if(normalize)
    {
      x=t(t(x)/sx)
      sx=sqrt(colMeans(x**2))
    }
    a=lars(x,y,type='lasso',trace=trace,normalize=F,intercept=F,Gram=Gram,eps=eps,max.steps=max.steps,use.Gram=use.Gram)
    #Crop away ascending lambda values (supposed bug in lars)
    nstep=which(a$lambda[2:length(a$lambda),drop=F]>a$lambda[1:length(a$lambda)-1])
    if(length(nstep)==0)
      nstep=length(a$lambda)
    else
      nstep=nstep[1]
    #lambda values
    lambda=a$lambda[1:nstep,drop=F]/ds
    #Residue
    ypredict=predict.lars(a,x,s=a$lambda[1:nstep,drop=F],mode='lambda')$fit
    if(is.null(dim(ypredict)))
    {
      ypredict=matrix(ypredict,ncol=1)
    }
    yres=y-ypredict
    #Residue variance
    pv=t(t(yres)-colMeans(yres))
    pv=colMeans(pv**2)
    wcl=lambda/sqrt(pv)
    #ans=lambda_i/(sigma_i*sigma_yres)
    ans=rep(0.,dx)
    ntot=0
    for (i in 1:nstep)
    {
      if(!is.finite(wcl[i]))
        next
      pa=unlist(a$actions[i])
      for(j in 1:length(pa))
      {
        if((pa[j]<=0)||isdone[pa[j]])
          next
        ans[pa[j]]=wcl[i]/sx[pa[j]]
        isdone[pa[j]]=T
        ntot=ntot+1
      }
      if(ntot>=max.predictors)
        break
    }
  }

  if(H0[1]=="normal")
  {
    ans=pchisq((ans**2)*ds,1,lower.tail=F,log.p=log.p)
  }
  else if(H0[1]=="spherical")
  {
    ans=pt(abs(ans)*sqrt((ds-2)/(1-ans**2)),ds-2,lower.tail=F,log.p=log.p)
    if(log.p)
      ans=ans+log(2)
    else
      ans=ans*2
  }
  else
    stop("Unknown null distribution type H0.")
  if(log.p)
  {
    ans[!isdone]=0
    ans[is.nan(ans)]=-Inf
    #Account for numerical precision limitations
    ans[ans>0]=0
  }
  else
  {
    ans[!isdone]=1
    ans[is.nan(ans)]=0
    #Account for numerical precision limitations
    ans[ans>1]=1
  }
  names(ans)=colnames(x)
  ans
}
`Blink.LDRemoveBlock`<-function(GDneo=NULL,LD=NULL,Porder=NULL,bound=FALSE,model="A",orientation=NULL){
#`Blink.LDRemove`<-function(GDneo=NULL,LD=NULL,Porder=NULL,bound=FALSE,model="A",orientation=NULL){
#Objects: Calculate LD and remove the correlated SNPs
#Authors: Yao Zhou
#Last Update:  03/03/16
	if (model=="D"){
		GDneo=1-abs(GDneo-1)
	}

	GDneo=as.matrix(GDneo)
	if(min(ncol(GDneo),nrow(GDneo))<201) bound=FALSE
	if(orientation=="col"){
		n=nrow(GDneo)
		if(bound){
			GDneo=GDneo[sample(n,200,replace=F),]
		}
	}else{
		n=ncol(GDneo)
		if(bound){
			GDneo=GDneo[,sample(n,200,replace=F)]
		}
		GDneo=t(GDneo)
	}
	# cat("ncol(GDneo) is",ncol(GDneo),"\n")
	corr=cor(GDneo)
	corr[is.na(corr)]=1
	corr[abs(corr)<=LD]=0
	corr[abs(corr)>LD]=1
	Psort=as.numeric(matrix(1,1,ncol(corr)))
	# print(ncol(corr))
	for(i in 2:ncol(corr)){
		p.a=Psort[1:(i-1)]
		p.b=as.numeric(corr[1:(i-1),i])
		index=(p.a==p.b)
		index[(p.a==0)&(p.b==0)]=FALSE
		if(sum(index)!=0) Psort[i]=0
	}
	seqQTN=Porder[Psort==1]
	return(seqQTN)
}

`Blink.LDRemove`<-function(GDneo=NULL,LD=0.7,Porder=NULL,bound=FALSE,model="A",orientation="row",block=1000,LD.num =50){
#Objects: LD remove, especially length(Porder)>10000
#Authors: Yao Zhou
#Last update: 08/15/2016
  GDneo = as.matrix(GDneo)
  SNP.index = apply(GDneo,1,sd)!=0
  GDneo = GDneo[SNP.index,]
  Porder = Porder[SNP.index]
  l = block
	seqQTN=NULL
	lp=length(Porder)
	k=ceiling(lp/l)
	GDneo=as.matrix(GDneo)
	if(min(ncol(GDneo),nrow(GDneo))<201) bound=FALSE
	if(orientation=="col"){
		n=nrow(GDneo)
		if(bound){
			GDneo=GDneo[sample(n,200,replace=F),]
		}
	}else{
		n=ncol(GDneo)
		if(bound){
			GDneo=GDneo[,sample(n,200,replace=F)]
		}
		GDneo=t(GDneo)
	}
	for(i in 1:k){
		bottom=(i-1)*l+1
		up=l*i
		if(up>lp) up = lp
		Porderb=Porder[bottom:up]

		index = seq(bottom:up)
		GDneob = GDneo[,index]
		# cat("i is ",i,"\n")
		# print(length(index))
		seqQTNs = Blink.LDRemoveBlock(GDneo=GDneob,LD=LD,Porder=Porderb,orientation="col",model=model)
		# print(seqQTN)
		seqQTN = append(seqQTN,seqQTNs)
		if(k >1){
		  index1 = which(Porder %in% seqQTN)
		  Porderb = Porder[index1]
		  GDneob = GDneo[,index1]
		  if(length(index1)>1){
		    seqQTN = Blink.LDRemoveBlock(GDneo=GDneob,LD=LD,Porder=Porderb,orientation="col",model=model)
		  }else{
		    seqQTN = Porderb
		  }

		}
		if(LD.num < length(seqQTN)) break
	}
	rm(GDneob,Porderb)
	return(seqQTN)
}
num=4
dsnps = try( read.table(paste("./",num,".dat",sep=""),head=F), silent=TRUE)
if ('try-error' %in% class(dsnps)) {
  dsnps = NULL
  msnps = NULL
}else{
  msnps= read.table(paste("./",num,".filtered.bim",sep=""),head=F)
  msnps = msnps[,c(2,1,4)]
}
dat = dsnps
GM = msnps
if(nrow(dat)>1){
a = Blink.LDRemove(GDneo=dat,LD=0.84,Porder=seq(1:nrow(dat)))
}else{
a=1
}
if (!is.null(dat)){
  y = read.table("pheno.txt",head=T)
  colnames(GM) = c("ID","chr","pos")
  # EM-lasso analysis
  p = try( lassopv(x=t(dat[a,]),y=y[,4]+y[,6]+y[,8],H0=c("spherical"),use.Gram=F), silent=TRUE)
  if (!('try-error' %in% class(p))){
    res = data.frame(GM[a,],pvalue=p)
    write.table(res,paste("./",num,".gwas.txt",sep=""),col.names=T,row.names=F,quote=F,sep="\t")
  }
}


## source('../../../../../functions.r')
## includemk('../vars.mk')
## load(MAINDATA)
library(data.table)

source('../../functions.r')
source('pst_parameter_chosen_values.r')
source('../../config.r')

dat <- fread('../generated/@estimates_table_final.csv')
dat <- dat[sp != 'DAQ']

spp <- fread('../acap-species-list.csv')
spp <- spp[base_species == T]
spp <- spp[code.sra != 'DAQ']

load('../../input-data/species-demography/pop-corrections.rdata', verb=T)
setnames(smpls, 'sp', 'sptype')

sp1="black petrel"
rhos <- rbindlist(lapply(levels(smpls$sptype), function(sp1) {
    data.table(sptype = sp1, sample = seq_len(NSAMPLES), rho = sample(smpls[sptype == sp1, ng_corr], NSAMPLES, replace=T))
}))
saveRDS(rhos, '../generated/rhos.rds')

d <- setdiff(spp$code.sra, dat$sp)
stopifnot(length(setdiff(spp$code.sra, dat$sp)) == 0)

## * Population size

pops <- readRDS('../../input-data/species-demography/colony-population-sizes-samples.rds')
pops <- pops[!(species %in% c("Waved Albatross",  "Pink-footed Shearwater"))]
sp_pop_samples <- pops[, .(breeding_pairs = sum(breeding_pairs)), .(species_code, sample)]

stopifnot(length(c(setdiff(spp$code.sra, sp_pop_samples$species_code),
                   setdiff(sp_pop_samples$species_code, spp$code.sra))) == 0)

## * Samples

summt <- list()
ntot_summ <- list()

dir.create('../generated/parameter_samples', showWarnings=F)

demsamples <- NULL

cat('\n=== Creating samples for each species\n')

i=2
for (i in seq_len(nrow(dat))) {
    d <- dat[i]
    sp <- d$sp
    cat(sp, '\t')
    params <- c('A','Scurr','Sopt','PB')
    rm(list=params[params %in% ls()])

    ## A
    if (!is.na(d$A.mean) & !is.na(d$A.sd)) {
        A <- exp(rnorm(NSAMPLES, mean=log(d$A.mean), sd=d$A.sd))
        summt[[sp]][['A']] <- sprintf('lognormal with mean %0.2f and sd %0.2f', log(d$A.mean), d$A.sd)
    } else if (!is.na(d$A.min) & !is.na(d$A.max)) {
        A <- runif(NSAMPLES, min=d$A.min, max=d$A.max)
        summt[[sp]][['A']] <- sprintf('uniform btw %0.2f and %0.2f', d$A.min, d$A.max)
    }
    ##  Scurr
    if (!is.na(d$Scurr.mean) & !is.na(d$Scurr.sd)) {
        Scurr <- surv_var_norm_mean_se(NSAMPLES, smean=d$Scurr.mean, sse=d$Scurr.sd)
        summt[[sp]][['Scurr']] <- sprintf('normal on logit scale with mean %0.2f and sd %0.2f', d$Scurr.mean, d$Scurr.sd)
    } else if (!is.na(d$Scurr.min) & !is.na(d$Scurr.max)) {
        Scurr <- runif(NSAMPLES, min=d$Scurr.min, max=d$Scurr.max)
        summt[[sp]][['Scurr']] <- sprintf('uniform btw %0.2f and %0.2f', d$Scurr.min, d$Scurr.max)
    }

    ##  Sopt
    if (!is.na(d$Sopt.mean) & !is.na(d$Sopt.sd)) {
        Sopt <- surv_var_norm_mean_se(NSAMPLES, smean=d$Sopt.mean, sse=d$Sopt.sd)
        summt[[sp]][['Sopt']] <- sprintf('normal on logit scale with mean %0.2f and sd %0.2f', d$Sopt.mean, d$Sopt.sd)
    } else if (!is.na(d$Sopt.min) & !is.na(d$Sopt.max)) {
        Sopt <- runif(NSAMPLES, min=d$Sopt.min, max=d$Sopt.max)
        summt[[sp]][['Sopt']] <- sprintf('uniform btw %0.2f and %0.2f', d$Sopt.min, d$Sopt.max)
    }

    ##  PB
    if (!is.na(d$PB.mean) & !is.na(d$PB.sd)) {
        if (d$PB.mean != 1)
            PB <- surv_var_norm_mean_se(NSAMPLES, smean=d$PB.mean, sse=d$PB.sd) else
                                                                                PB <- rep(d$PB.mean, NSAMPLES)
        summt[[sp]][['PB']] <- sprintf('normal on logit scale with mean %0.2f and sd %0.2f', d$PB.mean, d$PB.sd)
    } else if (!is.na(d$PB.min) & !is.na(d$PB.max)) {
        PB <- runif(NSAMPLES, min=d$PB.min, max=d$PB.max)
        summt[[sp]][['PB']] <- sprintf('uniform btw %0.2f and %0.2f', d$PB.min, d$PB.max)
    }

    ##  N
    breedpairs_tot <- NA
    breedpairs_tot <- sp_pop_samples[species_code == sp, breeding_pairs]
    summt[[sp]][['Nbp']] <- sprintf('from colonies')

    totpairs_tot <- breedpairs_tot / PB
    totads_tot <- totpairs_tot * 2
    NN_tot <- ntot2(Nadtot=totads_tot, surv=Scurr, afr=A, nsims=NSAMPLES)

    ## ** Apply correction of Ntot
    NN_tot$all <- NN_tot$all * rhos[sptype == spp[code.sra == sp, rho_group], rho]

    df <- data.frame(sp=dat$sp[i], scurr=Scurr, sopt=Sopt,
                    a=A, pb=PB,
                    nbp_tot=breedpairs_tot, nads_tot = totads_tot,
                    ntot_tot=NN_tot$all
                    )

    demsamples[[sp]] <- df

    ntot_summ[[sp]][['nbptot_mean']] <- mean(df$nbp_tot, na.rm=T)
    ntot_summ[[sp]][['nbptot_med']] <- quantile(df$nbp_tot, .5, na.rm=T)
    ntot_summ[[sp]][['nbptot_lcl']] <- quantile(df$nbp_tot, .025, na.rm=T)
    ntot_summ[[sp]][['nbptot_ucl']] <- quantile(df$nbp_tot, .975, na.rm=T)

}

cat('\n\n')

save(demsamples, file='../generated/dem-samples.rdata')
spl <- names(summt)
summt <- cbind(sp = spl, data.table(do.call('rbind', summt)))
ntot_summ <- cbind(sp = spl, data.table(do.call('rbind', ntot_summ)))
print(summt)
fwrite(summt, '../generated/samples_creation_summary.csv')
fwrite(ntot_summ, '../generated/ntot_summary_before_truncation.csv')


#BEGIN_HEADER
library(jsonlite)
library(fpc)
#END_HEADER

methods <- list()

#BEGIN_CONSTRUCTOR
source("./lib/Workspace/WorkspaceClient.r")

get_ws_client <- function(context) {
    token <- context[['token']]
    ws_url <- context[['config']][['workspace-url']]
    ret <- WorkspaceClient(ws_url, token=token, simplifyVector = TRUE, simplifyMatrix = TRUE)
    return(ret)
}

mean_m = function(vec){
    vec[as.vector(is.nan(vec))] <- NA
    n <- sum(!is.na(vec))
    summ <- sum(vec,na.rm=TRUE)
    summ/n
}

naToNaN = function(x) {
    x[is.na(x)] <- NaN
    return(x)
}

calc_cluster_props = function(logratios_median, cluster, ret) {
    ###mean pairwise correlation
    meancor <- c()
    for(i in 1:max(cluster)) {
        clust_ind <- which(cluster == i)
        if (length(clust_ind) == 1) {
            meancor <- c(meancor, NA)
        } else {
            cors <- cor(t(logratios_median[clust_ind,]), use="pairwise.complete.obs",method="pearson")
            AbCorC <- mean(cors[lower.tri(cors, diag=FALSE)])
            meancor <- c(meancor, AbCorC)
        }
    }
    #print(meancor)
    meancor <- naToNaN(meancor)

    ###MSEC
    MSECs <- c()
    for(i in 1:max(cluster)) {
        clust_ind <- which(cluster == i)
        if (length(clust_ind) == 1) {
            MSECs <- c(MSECs, NA)
        } else {
            curdata <- logratios_median[clust_ind,]
            MSEall <- mean_m((curdata-mean_m(curdata))^2)
            cmeans <- colMeans(curdata,na.rm=TRUE)
            csds <- apply(curdata,2,sd,na.rm=TRUE)
            MSEC <- mean_m((sweep(curdata,2,cmeans))^2/MSEall)
            MSECs <- c(MSECs, MSEC)
        }
    }
    #print(MSECs)
    MSECs <- naToNaN(MSECs)

    ret[["meancor"]] <- meancor
    ret[["msecs"]] <- MSECs
    return(ret)
}
#END_CONSTRUCTOR

methods[["RKmeansClustering.estimate_k"]] <- function(params, context) {
    #BEGIN estimate_k
    matrix_ref <- params[['input_matrix']]
    min_k <- params[['min_k']]
    max_k <- params[['max_k']]
    crit <- params[['criterion']]
    usepam <- params[['usepam']]
    alpha <- params[['alpha']]
    diss <- params[['diss']]
    random_seed <- params[['random_seed']]
    out_workspace <- params[['out_workspace']]
    out_estimate_result <- params[['out_estimate_result']]
    object_identity <- list(ref=unbox(matrix_ref))
    ws_client <- get_ws_client(context)
    object_data <- ws_client$get_objects(list(object_identity))[[1]]
    expr_matrix_obj <- object_data[['data']]
    matrix <- expr_matrix_obj[['data']]
    if (!is.null(random_seed))
        set.seed(random_seed)
    if (is.null(min_k))
        min_k <- 2
    if (is.null(max_k))
        max_k <- 200
    if (is.null(crit))
        crit <- "asw"
    if (is.null(usepam))
        usepam <- FALSE
    values <- matrix[["values"]]
    #row_names <- matrix[["row_ids"]]
    row_names <- c(1:length(matrix[["row_ids"]]))-1
    row.names(values) <- row_names
    values <- data.matrix(values)
    max_clust_num = min(c(max_k,nrow(values)-1))
    pk<- pamk(values,krange=c(min_k:max_clust_num),criterion=crit,
        usepam=usepam,ns=10)
    ret_names <- c(min_k:max_clust_num)
    best_pos <- pk$nc
    cluster_count_qualities <- list()
    for (pos in 1:length(ret_names)) {
        cluster_count = unbox(ret_names[pos])
        quality <- unbox(pk$crit[cluster_count])
        cluster_count_qualities <- rbind(cluster_count_qualities, list(cluster_count, quality))
    }
    obj <- list(best_k=unbox(as.numeric(best_pos)), estimate_cluster_sizes=cluster_count_qualities)
    prov_act <- list(service=unbox("RKmeansClustering"),method=unbox("estimate_k"),
        service_ver=unbox("0.1"), input_ws_objects=list(unbox(matrix_ref)),
        description=unbox("K estimation for K-Means clustering method"), method_params=list(params))
    prov <- list(prov_act)
    info <- ws_client$save_objects(list(workspace=unbox(out_workspace), objects=list(list(
        type=unbox('KBaseFeatureValues.EstimateKResult'), name=unbox(out_estimate_result),
        data=obj, provenance=prov))))[[1]]
    ret <- paste(info[[7]],info[[1]],info[[5]],sep="/")
    return(unbox(ret))
    #END estimate_k
}

methods[["RKmeansClustering.cluster_k_means"]] <- function(params, context) {
    #BEGIN cluster_k_means
    k <- params$k
    matrix_ref <- params$input_data
    n_start <- params$n_start
    max_iter <- params$max_iter
    random_seed <- params$random_seed
    algorithm_name <- params$algorithm
    out_workspace <- params$out_workspace
    out_clusterset_id <- params$out_clusterset_id
    object_identity <- list(ref=unbox(matrix_ref))
    ws_client <- get_ws_client(context)
    object_data <- ws_client$get_objects(list(object_identity))[[1]]
    expr_matrix_obj <- object_data[['data']]
    matrix <- expr_matrix_obj[['data']]
    if (is.null(n_start))
        n_start <- 1000
    if (is.null(max_iter))
        max_iter <- 1000
    if (is.null(algorithm_name))
        algorithm_name <- "Lloyd"
    values <- matrix[["values"]]
    row_ids <- matrix[["row_ids"]]
    row_names <- c(1:length(row_ids))-1
    row.names(values) <- row_names
    values <- data.matrix(values)
    #col_ids <- matrix[["col_ids"]]
    if (!is.null(random_seed))
        set.seed(random_seed)
    km <- kmeans(values, k, iter.max = max_iter, nstart=n_start, algorithm=algorithm_name)
    clusters <- calc_cluster_props(values, km[["cluster"]], list(cluster_labels=km[["cluster"]]))
    out_list <- list()
    for (i in 1:max(clusters$cluster_labels)) {
        clust_ind <- which(clusters$cluster_labels == i)
        id_to_pos <- list()
        for (j in clust_ind) {
            row_id <- row_ids[j]
            id_to_pos[[row_id]] <- unbox(j - 1)
        }
        out_clust <- list(id_to_pos=id_to_pos)
        out_clust[['meancor']] <- unbox(clusters$meancor[[i]])
        out_clust[['msec']] <- unbox(clusters$msecs[[i]])
        out_list[[i]] <- out_clust
    }
    obj <- list(original_data=unbox(matrix_ref), feature_clusters=out_list)
    prov_act <- list(service=unbox("RKmeansClustering"),method=unbox("cluster_k_means"),
        service_ver=unbox("0.1"), input_ws_objects=list(unbox(matrix_ref)),
        description=unbox("K-Means clustering method"), method_params=list(params))
    prov <- list(prov_act)
    info <- ws_client$save_objects(list(workspace=unbox(out_workspace), objects=list(list(
        type=unbox('KBaseFeatureValues.FeatureClusters'), name=unbox(out_clusterset_id),
        data=obj, provenance=prov))))[[1]]
    ret <- paste(info[[7]],info[[1]],info[[5]],sep="/")
    return(unbox(ret))
    #END cluster_k_means
}


## --------------------
## --------------------
## --------------------
## This file contains functions mainly for cross validation of Adaptive Penalized Tensor Decomposition.
## Most function are only suitable for three dimension tensor. For higher-order tensor, codes should be modified adaptively.
## --------------------
## --------------------
## --------------------

## --------------------
## Initialization for cross validation.
## --------------------
prepare_adaptive_adj <- function(tnsr, num_components, Niter = 1500, tol = 1e-05, year = 5, trace = FALSE, ku, kv, kw, splits = 10) {
    original <- tnsr
    Test <- tnsr[, , (dim(tnsr)[3] - year + 1):dim(tnsr)[3]]
    V1 <- list()
    S1 <- list()
    In1 <- list()
    mean1 <- list()
    sd1 <- list()
    tnsr <- tnsr[, , 1:(dim(tnsr)[3] - year)]
    for (m in 1:splits) {
        message("Training on years: ", paste(1:(dim(tnsr)[3] - splits - year + m), collapse = "+"))
        message("Test on years: ", paste((dim(tnsr)[3] - splits - year + m + 1):((dim(tnsr)[3] - splits - year + m + 1) + year - 1), collapse = "+"))

        temp_s <- tnsr@data[, , 1:(dim(tnsr)[3] - splits - year + m)]
        S1[[m]] <- as.tensor((temp_s - array(mean(temp_s), dim = dim(temp_s))) / sd(temp_s))
        mean1[[m]] <- c(mean(temp_s))
        sd1[[m]] <- c(sd(temp_s))

        V1[[m]] <- as.tensor(tnsr@data[, , (dim(tnsr)[3] - splits - year + m + 1):((dim(tnsr)[3] - splits - year + m + 1) + year - 1)])

        make_init <- gen_startvals(num_components, S1[[m]])

        message("Fitting unpenalized tensor...")
        In1[[m]] <- multiple_tf_simple(
            tnsr = S1[[m]], d_hat = NULL, num_components = num_components,
            u_init = make_init$u, v_init = make_init$v, w_init = make_init$w,
            Niter = Niter, tol = tol,
            c1 = rep(0, num_components), c2 = rep(0, num_components), c3 = rep(0, num_components),
            ku = ku, kv = kv, kw = kw, trace = trace
        )
        message("Fitting completed.")
    }

    ## generate D
    Dut <- list()
    Dvt <- list()
    Dwt <- list()
    for (m in 1:splits) {
        Dut[[m]] <- create_D(In1[[m]]$u, ord = (ku + 1))
        Dvt[[m]] <- create_D(In1[[m]]$v, ord = (kv + 1))
        Dwt[[m]] <- create_D(In1[[m]]$w, ord = (kw + 1))
    }

    return(list(
        Dut = Dut, Dvt = Dvt, Dwt = Dwt, In1 = In1, S1 = S1, V1 = V1, year = year,
        num_components = num_components, mean1 = mean1, sd1 = sd1, Test = Test, original = original
    ))
}

## --------------------
## Function for cross validation.
## --------------------
multiple_cv_adaptive_adj <- function(init, grid, ku = NULL, kv = NULL, kw = NULL, tol = 5e-05, Niter_small = 1500, splits = 10) {

    # trian data
    # input tenor should be training +validation tensor
    # third dimension should be year dimension

    tstart <- Sys.time()
    S1 <- init$S1
    V1 <- init$V1
    Dut <- init$Dut
    Dvt <- init$Dvt
    Dwt <- init$Dwt
    num_components <- init$num_components
    year <- init$year
    In1 <- init$In1
    mean1 <- init$mean1
    sd1 <- init$sd1

    sfInit(parallel = TRUE, cpus = 6)
    # load
    sfLibrary(rTensor)
    sfLibrary(genlasso)
    sfLibrary(forecast)
    sfLibrary(mgcv) # gam
    sfLibrary(Hmisc)
    sfExport(
        "multiple_D_adaptive", "PTD_D", "In1", "tol", "product", "S1", "cal_pmse_gam_adj",
        "cal_pmse_arima_adj", "cal_pmse_linearextra_adj", "num_components", "V1", "year", "Niter_small", "Dut", "Dvt", "Dwt", "mean1", "sd1"
    )

    best <- 0
    meanPMSE_gam <- meanPMSE_linextrap <- meanPMSE_arima <- NULL # record each combination's mean of the prediction RMSEs (averge of 10 )
    allPMSE_gam <- allPMSE_linextrap <- allPMSE_arima <- NULL

    for (i in 1:nrow(grid)) {
        message("Tuning parameters: ", paste(grid[i, ], collapse = "/"))
        sfExport("i", "grid")

        parallel1 <- function(m, num_components, In1, grid, Niter_small, tol, Dut, Dvt, Dwt) {
            temp <- multiple_D_adaptive(
                tnsr = S1[[m]], num_components = num_components, d_hat = In1[[m]]$d,
                u_init = In1[[m]]$u, v_init = In1[[m]]$v, w_init = In1[[m]]$w,
                c1 = rep(grid[i, 1], num_components), c2 = rep(grid[i, 2], num_components), c3 = rep(grid[i, 3], num_components),
                Niter = Niter_small, tol = tol, Du = Dut[[m]], Dv = Dvt[[m]], Dw = Dwt[[m]], trace = FALSE
            )
        }

        tempresult <- sfLapply(1:splits, parallel1, num_components, In1, grid, Niter_small, tol, Dut, Dvt, Dwt)
        sfExport("tempresult")

        temprmse_gam <- as.numeric(sfLapply(1:splits, cal_pmse_gam_adj, year = year))
        temprmse_linextrap <- as.numeric(sfLapply(1:splits, cal_pmse_linearextra_adj, year = year))
        temprmse_arima <- as.numeric(sfLapply(1:splits, cal_pmse_arima_adj, year = year))
        allPMSE_gam <- rbind(allPMSE_gam, temprmse_gam)
        allPMSE_arima <- rbind(allPMSE_arima, temprmse_arima)
        allPMSE_linextrap <- rbind(allPMSE_linextrap, temprmse_linextrap)

        # bias and variance
        meanPMSE_gam <- c(meanPMSE_gam, mean(temprmse_gam))
        meanPMSE_linextrap <- c(meanPMSE_linextrap, mean(temprmse_linextrap))
        meanPMSE_arima <- c(meanPMSE_arima, mean(temprmse_arima))

        # print(meanPMSE_gam)
        # print(meanPMSE_arima)
        # print(meanPMSE_linextrap)
    }

    ## stop parallel
    sfStop()
    tend <- Sys.time()
    message("Fitting completed!")

    colnames(grid) <- c("U", "V", "W")
    performance <- data.frame(grid,
        meanPMSE_gam = meanPMSE_gam, meanPMSE_linextrap = meanPMSE_linextrap, meanPMSE_arima = meanPMSE_arima,
        mean_diffunpenPMSE_gam = meanPMSE_gam - meanPMSE_gam[1], mean_diffunpenPMSE_linextrap = meanPMSE_linextrap - meanPMSE_linextrap[1],
        mean_diffunpenPMSE_arima = meanPMSE_arima - meanPMSE_arima[1]
    )
    performance$sd_diffunpenPMSE_gam <- apply(t(t(allPMSE_gam) - allPMSE_gam[1, ]), 1, sd)
    performance$sd_diffunpenPMSE_arima <- apply(t(t(allPMSE_arima) - allPMSE_arima[1, ]), 1, sd)
    performance$sd_diffunpenPMSE_linextrap <- apply(t(t(allPMSE_linextrap) - allPMSE_linextrap[1, ]), 1, sd)

    out <- list(
        best_parameters_gam = grid[which.min(performance$meanPMSE_gam), ],
        best_parameters_linextrap = grid[which.min(performance$meanPMSE_linextrap), ],
        best_parameters_arima = grid[which.min(performance$meanPMSE_arima), ],
        performance = performance, init = init, time = tend - tstart
    )
    return(out)
}


world_records = read.csv('WorldRecords.csv')

world_records_mile = world_records[(world_records$Event == 'Mens Mile' | world_records$Event == 'Womens Mile'),]

mens_mile = world_records_mile[(world_records_mile$Event == 'Mens Mile'),]
womens_mile = world_records_mile[(world_records_mile$Event == 'Womens Mile'),]

mean(mens_mile$Record)
mean(womens_mile$Record)
mean(world_records_mile$Record)

mens_mile['avg'] = mens_mile$Record - mean(mens_mile$Record)
mean(mens_mile$avg)
lm(mens_mile ~ womens_mile)
mean(diff(mens_mile$Record))


library(shiny)
library(ggplot2)
library(RTop500)

bad_input_plot <- function()
{
  label <- "Bad input!"
  df <- data.frame(x=0, y=0, label=label, stringsAsFactors=FALSE)
  g <- ggplot(df, aes(x=x, y=y, label=label)) + geom_text(size=35) +
    theme(text = element_blank(), line = element_blank(), title = element_blank())

  return(g)
}

type_print <- c("Theoretical peak GFLOPs", "LINPACK GFLOPs", "Theoretical minus LINPACK", "Total number of cores")
type_actual <- c("theoretical", "linpack", "difference", "ncores")

shinyServer(function(input, output){
  output$plot <- renderPlot({
    val <- input$my.val
    if (val == "")
      val <- NULL
    else
      val <- as.numeric(val)

    if (!is.null(val) && is.na(val)) return(bad_input_plot())

    cols <- character(0)
    if (input$col_min) cols <- c(cols, "Min")
    if (input$col_mean) cols <- c(cols, "Mean")
    if (input$col_med) cols <- c(cols, "Median")
    if (input$col_max) cols <- c(cols, "Max")
    if (input$col_sum) cols <- c(cols, "Sum")

    type <- input$type
    type <- type_actual[which(type_print == type)]

    if (length(cols) == 0)
      g <- bad_input_plot()
    else
    {
      g <- plot_top500(columns=cols, my.val=val, type=type)
      g <- g + ggtitle(g$labels$y) + ylab("")
    }
    g
  })
})


seasonalize <- function(arr, maxes = TRUE){
  # this function finds the max or min by climatological season (DJF, MAM, JJA, SON), assuming a 3-d array with month as the second dimension

  if(maxes) FUN <- max else FUN <- min

  nSeas <- 4
  seasonIndices <- list(DJF = c(1, 2, 12), MAM = 3:5, JJA = 6:8, SON = 9:11)
  dec <- 12
  nYr <- dim(arr)[1]

  arr[2:nYr, dec, ] <- arr[1:(nYr - 1), dec, ]
  arr[1, dec, ] <- NA

  tmp <- array(NA, c(nYr, nSeas, dim(arr)[3]))
  for(j in 1:nSeas){
    tmp[ , j, ] <- apply(arr[, seasonIndices[[j]], , drop = FALSE], c(1, 3), FUN, na.rm = FALSE)
  }
  return(tmp)
}

is.wholenumber <- function(x, tol = .Machine$double.eps^0.5)  abs(x - round(x)) < tol

validateIndices <- function(model, nVar){
  if(min(model) < 0 | max(model) > nVar)
    return(FALSE)
  if(sum(is.wholenumber(model)) < length(model))
    return(FALSE)
  if(length(unique(model)) != length(model))
    return(FALSE)
  return(TRUE)
}

normalize <- function(vec, shift = NULL, lower = NULL, upper = NULL){
  if(is.null(shift))
    shift <- mean(vec)
  if(is.null(lower))
    lower <- min(vec)
  if(is.null(upper))
    upper <- max(vec)
  (vec - shift) / (upper - lower)
}

returnValue <- function(fit, rvInterval = 20, rvCovariates = NULL){

  if(!(class(fit) == 'gev.fit' | class(fit) == 'pp.fit'))
    stop('Function only handles gev.fit and pp.fit objects')

#  if(!identical(fit$link[[1]], identity) || !identical(shlink, identity) ||  == 'gev.fit' | class(fit) == 'pp.fit'))
  #  stop('Function only handles gev.fit and pp.fit objects')

  links = substring(fit$link, 3, nchar(fit$link) - 1)
  links = unlist(strsplit(links, ", "))

  if(links[1] != "identity" || links[3] != "identity" || !(links[2] %in% c("identity", "exp")))
    stop("Function only computes return values for identity link functions for location and shape and for identity or exponential link functions for scale")

  locationIndices <- 1:(length(fit$model[[1]]) + 1)
  pos = 1 + max(locationIndices)
  scaleIndices <- pos:(pos+length(fit$model[[2]]))
  pos = 1 + max(scaleIndices)
  shapeIndices <- pos:(pos+length(fit$model[[3]]))

  location <- eval(as.name(links[1]))(sum(c(1, rvCovariates[fit$model[[1]]]) * fit$mle[locationIndices]))
  scale <- eval(as.name(links[2]))(sum(c(1, rvCovariates[fit$model[[2]]]) * fit$mle[scaleIndices]))
  shape <- eval(as.name(links[3]))(sum(c(1, rvCovariates[fit$model[[3]]]) * fit$mle[shapeIndices]))

  yp <- -log(1 - 1/rvInterval)
  ypshape <- yp^(-shape)
  zp <- location - (scale/shape) * (1 - ypshape)

  if(links[2] == "identity"){
    scaleTerm = 1
  } else{  # exponential link
    scaleTerm = scale
  }

  grad <- c(c(1, rvCovariates[fit$model[[1]]]),
    -(scaleTerm/shape) * (1 - ypshape) * c(1, rvCovariates[fit$model[[2]]]),
    ((scale/shape^2) * (1 - ypshape) - (scale/shape) * ypshape * log(yp)) * c(1, rvCovariates[fit$model[[3]]]))

  se <- sqrt(t(grad) %*% fit$cov %*% grad)

  return(c(zp, se))
}

# difference in return values for single time series, different covariate values
returnValueDiff <- function(fit, rvInterval = 20, rvCovariates = NULL){
  if(!(class(fit) == 'gev.fit' || class(fit) == 'pp.fit'))
    stop('Function only handles gev.fit and pp.fit objects')

  links = substring(fit$link, 3, nchar(fit$link) - 1)
  links = unlist(strsplit(links, ", "))

  if(links[1] != "identity" || links[3] != "identity" || !(links[2] %in% c("identity", "exp")))
    stop("Function only computes return value differences for identity link functions for location and shape and for identity or exponential link functions for scale")

  locationIndices <- 1:(length(fit$model[[1]]) + 1)
  pos = 1 + max(locationIndices)
  scaleIndices <- pos:(pos+length(fit$model[[2]]))
  pos = 1 + max(scaleIndices)
  shapeIndices <- pos:(pos+length(fit$model[[3]]))

  location <- eval(as.name(links[1]))(cbind(rep(1, 2), rvCovariates[ , fit$model[[1]]]) %*% fit$mle[locationIndices])
  scale <- eval(as.name(links[2]))(cbind(rep(1, 2), rvCovariates[ , fit$model[[2]]]) %*% fit$mle[scaleIndices])
  shape <- eval(as.name(links[3]))(cbind(rep(1, 2), rvCovariates[ , fit$model[[3]]]) %*% fit$mle[shapeIndices])

  yp <- -log(1 - 1/rvInterval)
  ypshape <- yp^(-shape)
  zpDiff <- diff(location - (scale/shape) * (1 - ypshape))

  if(links[2] == "identity"){
    scaleTerm = rep(1, 2)
  } else{  # exponential link
    scaleTerm = rep(scale, 2)
  }

  grad <- c(0, rvCovariates[2, fit$model[[1]]] - rvCovariates[1, fit$model[[1]]],
    -(scaleTerm[2]/shape[2]) * (1 - ypshape[2]) * c(1, rvCovariates[2, fit$model[[2]]]) +
    (scaleTerm[1]/shape[1]) * (1 - ypshape[1]) * c(1, rvCovariates[1, fit$model[[2]]]),
    ((scale[2]/shape[2]^2) * (1 - ypshape[2]) - (scale[2]/shape[2]) * ypshape[2] * log(yp) ) * c(1, rvCovariates[2, fit$model[[3]]]) -
    ((scale[1]/shape[1]^2) * (1 - ypshape[1]) - (scale[1]/shape[1]) * ypshape[1] * log(yp) ) * c(1, rvCovariates[1, fit$model[[3]]]))

  se <- sqrt(t(grad) %*% fit$cov %*% grad)

  return(c(zpDiff, se))
}

removeRuns <- function(vals, days, maxes = TRUE){
  n <- length(vals)
  if(maxes) FUN <- max else FUN <- min
  if(n > 1){
    checkBack <- c(TRUE, days[2:n] - days[1:(n-1)] != 1)
    checkFwd <- c(days[1:(n-1)] - days[2:n] == -1, FALSE)
    seqStarts <- which(checkBack & checkFwd)
    for(start in seqStarts){
      pos = start
      while(pos < n && days[pos + 1] - days[start] == pos + 1 - start) pos <- pos + 1
      tmp <- vals[start:pos]
      jitter = rnorm(length(tmp), 0, 1e-12)  # amounts to randomly choosing a max when values are equal
      tmp[tmp + jitter < FUN(tmp + jitter)] <- NA
      vals[start:pos] <- tmp
    }
  }
  return(vals)
}

# alternative: function for removing multiple exceedances in blockLen-day windows; surprisingly this is much slower
withinBlockScreenAlt <- function(vals, days, blockLen = 10, maxes = TRUE){
  n <- length(vals)
  if(n > 1){
    jitter = rnorm(n, 0, 1e-12) # randomly choose which value in block to retain when there are ties
    if(maxes) FUN <- max else FUN <- min
    block <- data.frame(block = cut(days, seq(0, max(days)+blockLen, by = blockLen)))
    tmp <- tapply(vals + jitter, block, FUN)
    blockExtrema <- data.frame(block = names(tmp), extrema = tmp)
    comparators = merge(block, blockExtrema, all.x = TRUE, all.y = FALSE)
    vals[vals + jitter < comparators$extrema] = NA
  }
  return(vals)
}

withinBlockScreen <-  function(vals, days, blockLen = 10, maxes = TRUE){
  if(!identical(days, sort(days)))
    stop('data must be sorted by days in ascending order')
  n <- length(vals)
  if(n > 1){
    i <- 1
    while(i < length(vals)){
      start <- i
      while( (days[i+1]-1) %/% blockLen == (days[i]-1) %/% blockLen &&  i < length(vals)){
        i <- i + 1
      }
      if(i > start){
        jitter = rnorm(i - start + 1, 0, 1e-12)
        tmp = vals[start:i]
        tmp[tmp + jitter < max(tmp + jitter)] = NA
        vals[start:i] = tmp
      }
      i = i + 1
    }
  }
  return(vals)
}

lik.ratio.test = function(fit1, fit2){
  if(!(class(fit1) %in% c("gev.fit", "pp.fit")) ||
     !(class(fit2) %in% c("gev.fit", "pp.fit")))
    stop("Fit objects must be of class 'gev.fit' or 'pp.fit'")
  dev = 2 * abs(fit1$nllh - fit2$nllh)
  df = abs(length(unlist(fit1$model)) - length(unlist(fit2$model)))
  return(list(df = df, negLogLik = c(fit1$nllh, fit2$nllh), chisq = dev, p = 1 - pchisq(dev, df)))
}

#linkManip = function(mulink, siglink, shlink)
# return(deparse(substitute(c(mulink, siglink, shlink))))