#iv fastplm boot
ivfastplm.boot <- function(seed,
                           y = NULL,
                           x = NULL,
                           z = NULL,
                           ind = NULL,
                           sfe.index = NULL,
                           cfe.index = NULL,
                           cluster = NULL,
                           robust = FALSE,
                           parallel = FALSE,
                           wild = FALSE,
                           jackknife = FALSE,
                           refinement = FALSE,
                           pos = NULL,
                           test.value = NULL,
                           nboots = 200,
                           bootcluster = NULL, #2-way clusters in wild (refinement)
                           core.num = 1){
    p <- dim(x)[2]
    if(is.null(z)){
        stop("No exogenous variables.\n")
    }

    if(is.null(colnames(x))){
        colnames(x) <- paste0("x.",c(1:dim(x)[2]))
    }

    if(is.null(colnames(z))){
        colnames(z) <- paste0("z.",c(1:dim(z)[2]))
    }

    if(is.null(colnames(y))){
        colnames(y) <- 'y'
    }

    if (jackknife == 1) {
        wild <- 0
    }

    # get
    model.iv <- ivfastplm.core(y = y, x = x, z = z,
                               ind = ind, se = 1,
                               robust = robust,
                               sfe.index = sfe.index,
                               cfe.index = cfe.index,
                               cl = cluster,
                               core.num = core.num,
                               need.fe = TRUE,
                               iv.test = FALSE)

    dy <- model.iv$demeaned$dy
    dx <- model.iv$demeaned$dx
    dz <- model.iv$demeaned$dz

    y.fit <- fitted.y <- model.iv$fitted.values
    res <- residual.y <- model.iv$residuals

    iv.name <- model.iv$names
    en.var.x <- iv.name$en.var.x
    ex.var.x <- iv.name$ex.var.x
    include.iv <- iv.name$include.iv
    exclude.iv <- iv.name$exclude.iv

    iv.matrix <- model.iv$matrix
    inv.z <- iv.matrix$inv.z # inv(z'z)
    inv.xPzx <- iv.matrix$inv.xPzx

    #save df.original & df.cl for wild bootstrap(only)
    df.use <- df.original <- model.iv$df.original
    df.cl.use <- df.cl <- model.iv$df.cl

    ## function to get two-sided p-values
    get.pvalue <- function(vec,to_test=0) {
        if (NaN%in%vec|NA%in%vec) {
            nan.pos <- is.nan(vec)
            na.pos <- is.na(vec)
            pos <- c(which(nan.pos),which(na.pos))
            vec.a <- vec[-pos]
            a <- sum(vec.a >= to_test)/(length(vec)-sum(nan.pos|na.pos)) * 2
            b <- sum(vec.a <= to_test)/(length(vec)-sum(nan.pos|na.pos)) * 2
        } else {
            a <- sum(vec >= to_test)/length(vec) * 2
            b <- sum(vec <= to_test)/length(vec) * 2
        }
        return(min(as.numeric(min(a, b)),1))
    }

    if(parallel==TRUE){
        core.num <- 1
        requireNamespace("doParallel")
		## require(iterators)
		maxcores <- detectCores()
		cores <- min(maxcores, 4)
		pcl<-makeCluster(cores)
		doParallel::registerDoParallel(pcl)
	    cat("Parallel computing with", cores,"cores...\n")
        use.fun <- c("SEQ","name.fe.model","ivfastplm.core","get.dof","iv.cluster.se","fastplm.core")
    }

    if(wild==TRUE){
        raw.cluster <- level.cluster <- level.count <- NULL
        if (!is.null(cluster)) {
            if(dim(cluster)[2]==1){
                ## one-way cluster
                raw.cluster <- as.numeric(as.factor(cluster))
                level.cluster <- unique(raw.cluster)
                level.count <- table(raw.cluster)
            }
            if(dim(cluster)[2]==2){
                if(is.null(bootcluster)){
                    level.cluster.1 <- unique(as.numeric(as.factor(cluster[,1])))
                    level.cluster.2 <- unique(as.numeric(as.factor(cluster[,2])))
                    if(length(level.cluster.1)<=length(level.cluster.2)){
                        raw.cluster <- as.numeric(as.factor(cluster[,1]))
                        bootcluster <- colnames(cluster)[1]
                    }else{
                        raw.cluster <- as.numeric(as.factor(cluster[,2]))
                        bootcluster <- colnames(cluster)[2]
                    }
                    level.cluster <- unique(raw.cluster)
                    level.count <- table(raw.cluster)
                }else{
                    raw.cluster <- as.numeric(as.factor(cluster[,bootcluster]))
                    level.cluster <- unique(raw.cluster)
                    level.count <- table(raw.cluster)
                }
                cat(paste0("Mutiple Clustered Wild Bootstrap: (Boot)Clustered at ",bootcluster," level.\n"))
            }
        }

        if(length(en.var.x)>0){
           en.var.x.matrix <- matrix(dx[,en.var.x],ncol=length(en.var.x))
            sub.lm <- simpleols(Y=en.var.x.matrix,X=dz)
            en.var.x.coef <- sub.lm[['coef']]
            colnames(en.var.x.coef) <- en.var.x
            en.var.x.hat <- sub.lm[['Y_hat']]
            colnames(en.var.x.hat) <- en.var.x
            res.en.x <- en.var.x.res <- sub.lm[["u_hat"]]
            en.var.x.fitted <- matrix(x[,en.var.x],ncol=length(en.var.x)) - en.var.x.res
            colnames(en.var.x.fitted) <- colnames(en.var.x.res) <- colnames(en.var.x.hat) <- en.var.x
        }
        ####

        if (refinement == 0) {
                ## wild bootstrap
                cat("Wild Bootstrap without Percentile-t Refinement.\n")
                boot.coef <- matrix(NA, p, nboots)

                one.boot <- function(num = NULL) {
                    if (!is.null(cluster)) {
                        ## wild boot by cluster
                        res.p <- rep(0,dim(cluster)[1])
                        for (j in 1:length(level.cluster)) {
                            temp.level <- sample(c(-1,1), 1)
                            res.p[which(raw.cluster==level.cluster[j])] <- temp.level
                        }
                        res.p <- as.matrix(res.p)
                    } else {
                        res.p <- as.matrix(sample(c(-1, 1), dim(y)[1], replace = TRUE))
                    }

                    y.boot <- y.fit + res.p * res

                    if(length(en.var.x)>0){
                       x.boot.en <- matrix(en.var.x.fitted + sweep(en.var.x.res, MARGIN=1, res.p, `*`),ncol=length(en.var.x))
                       colnames(x.boot.en) <- en.var.x
                    }else{
                        x.boot.en <- matrix(NA,ncol=0,nrow=dim(dy)[1])
                    }

                    if(length(ex.var.x)>0){
                        x.boot.ex <- matrix(x[,ex.var.x],ncol=length(ex.var.x))
                        colnames(x.boot.ex) <- ex.var.x
                    }else{
                        x.boot.ex <- matrix(NA,ncol=0,nrow=dim(dy)[1])
                    }

                    x.boot <- cbind(x.boot.en,x.boot.ex)
                    x.boot <- x.boot[,colnames(x)]
                    #only need coefficients, don't need se
                    boot.model.iv <- try(ivfastplm.core(y = y.boot, x = x.boot,z=z, ind = ind,
                                                   sfe.index = sfe.index, cfe.index = cfe.index,
                                                   se = 0, cl = NULL, core.num = core.num,
                                                   df.use = df.use, df.cl.use = df.cl.use, need.fe = FALSE, iv.test = FALSE
                                                   ))

                    if ('try-error' %in% class(boot.model.iv)) {
                        return(rep(NA, p))
                    } else {
                        return(c(boot.model.iv$coefficients))
                    }
                }

                if (parallel == TRUE) {
                    boot.out <- foreach(j = 1:nboots,
                                    .inorder = FALSE,
                                    .export = use.fun,
                                    .packages = c("fastplm")
                                    ) %dopar% {
                                        return(one.boot())
                                    }
                    for (j in 1:nboots) {
                        boot.coef[, j] <- c(boot.out[[j]])
                    }
                } else {
                    for (i in 1:nboots) {
                        boot.coef[, i] <- one.boot()
                        if (i%%50==0) cat(i) else cat(".")
                    }
                }

                P_x <- as.matrix(apply(boot.coef, 1, get.pvalue))
                stderror <- as.matrix(apply(boot.coef, 1, sd, na.rm = TRUE))

                CI <- t(apply(boot.coef, 1, quantile, c(0.025, 0.975), na.rm = TRUE))
                ## rewrite uncertainty estimates
                est.coefficients <- cbind(model.iv$coefficients, stderror,model.iv$coefficients/stderror, P_x, CI)
                colnames(est.coefficients) <- c("Coef", "Std. Error","Z Value", "P Value", "CI_lower", "CI_upper")
                rownames(est.coefficients) <- colnames(dx)
                model.iv$est.coefficients <- est.coefficients

                vcov <- as.matrix(cov(t(boot.coef),use="na.or.complete"))
                colnames(vcov) <- colnames(dx)
                rownames(vcov) <- colnames(dx)
                model.iv$vcov <- vcov
        }

        if(refinement==1){
            if(is.null(pos)==TRUE){
                cat("Unrestricted Wild Bootstrap with Percentile-t Refinement.\n")
                boot.coef <- matrix(NA, p, nboots)
                boot.wald <- rep(NA, nboots)
                one.boot <- function(num = NULL) {
                    if (!is.null(cluster)) {
                        ## wild boot by cluster
                        res.p <- rep(0,dim(cluster)[1])
                        for (j in 1:length(level.cluster)) {
                            temp.level <- sample(c(-1,1), 1)
                            res.p[which(raw.cluster==level.cluster[j])] <- temp.level
                        }
                        res.p <- as.matrix(res.p)
                    } else {
                        res.p <- as.matrix(sample(c(-1, 1), dim(y)[1], replace = TRUE))
                    }
                    y.boot <- y.fit + res.p * res

                    if(length(en.var.x)>0){
                       x.boot.en <- matrix(en.var.x.fitted + sweep(en.var.x.res, MARGIN=1, res.p, `*`),ncol=length(en.var.x))
                       colnames(x.boot.en) <- en.var.x
                    }else{
                        x.boot.en <- matrix(NA,ncol=0,nrow=dim(dy)[1])
                    }

                    if(length(ex.var.x)>0){
                        x.boot.ex <- matrix(x[,ex.var.x],ncol=length(ex.var.x))
                        colnames(x.boot.ex) <- ex.var.x
                    }else{
                        x.boot.ex <- matrix(NA,ncol=0,nrow=dim(dy)[1])
                    }
                    x.boot <- cbind(x.boot.en,x.boot.ex)
                    x.boot <- x.boot[,colnames(x)]

                    boot.model <- try(ivfastplm.core(y = y.boot, x = x.boot, z = z, ind = ind, robust = robust,
                                                sfe.index = sfe.index, cfe.index = cfe.index,
                                                se = 1, cl = cluster, core.num = core.num,
                                                df.use = df.use,
                                                df.cl.use = df.cl.use))
                    if ('try-error' %in% class(boot.model)) {
                        return(NA)
                    } else {
                        boot.use <- (boot.model$est.coefficients[, "Coef"]-model.iv$est.coefficients[, "Coef"])/boot.model$est.coefficients[, "Std. Error"]
                        return(c(boot.use))
                    }
                }
                if (parallel == TRUE) {
                    boot.out <- foreach(j = 1:nboots,
                                        .inorder = FALSE,
                                        .export = use.fun,
                                        .packages = c("fastplm")
                                        ) %dopar% {
                                            return(one.boot())
                                        }
                    for (j in 1:nboots) {
                        boot.coef[, j] <- c(boot.out[[j]])
                    }
                } else {
                    for (i in 1:nboots) {
                        boot.coef[, i] <- one.boot()
                        if (i%%50==0) cat(i) else cat(".")
                    }
                }
                wald.refinement <- matrix(NA,nrow=0,ncol=6)
                null.totest <- model.iv$est.coefficients[,'t value']
                for(k in 1:length(null.totest)){
                    p.refine <- get.pvalue(boot.coef[k,],to_test=null.totest[k])
                    CI.refine <- quantile(boot.coef[k,], probs = c(0.025,0.975), na.rm = TRUE)*model.iv$est.coefficients[k,'Std. Error'] + model.iv$est.coefficients[k,'Coef']
                    refine.sub <- c(model.iv$est.coefficients[k,'Coef'],
                                    model.iv$est.coefficients[k,'Std. Error'],
                                    model.iv$est.coefficients[k,'t value'],
                                    p.refine,
                                    CI.refine[1],
                                    CI.refine[2])
                    wald.refinement <- rbind(wald.refinement,refine.sub)
                }
                colnames(wald.refinement) <- c("Coef","Std Error","t value",
                                            "Refined P value","Refined CI_lower",
                                            "Refined CI_upper")
                rownames(wald.refinement) <- colnames(dx)
                model.iv$refinement <- list(wald.refinement = wald.refinement, boot.wald = boot.coef)
            }

            if(is.null(pos)==FALSE){

                if(is.null(test.value)==TRUE){
                    test.value <- 0
                }

                if(pos %in% en.var.x){
                    cat("Restricted Wild Efficient Residual Bootstrap with Percentile-t Refinement.\n")
                    if(length(en.var.x)==1){
                        dy.restricted <- dy - test.value*dx[,en.var.x]
                        dx1 <- matrix(dx[,ex.var.x],ncol=length(ex.var.x))
                        inv.dx1 <- solve(t(dx1)%*%dx1)
                        reg1.coef <- inv.dx1%*%t(dx1)%*%dy.restricted
                        u.hat1 <- dy.restricted - dx1%*%reg1.coef

                        dy2 <- dx[,en.var.x]
                        dx2 <- cbind(dz,u.hat1)
                        inv.dx2 <- solve(t(dx2)%*%dx2)
                        reg2.coef <- inv.dx2%*%t(dx2)%*%dy2
                        u.hat2 <- dy2 - dx2%*%reg2.coef + reg2.coef[dim(dz)[2]+1,1]*u.hat1

                        one.boot <- function(num = NULL) {
                            if (!is.null(cluster)) {
                                ## wild boot by cluster
                                res.p <- rep(0,dim(cluster)[1])
                                for (j in 1:length(level.cluster)) {
                                    temp.level <- sample(c(-1,1), 1)
                                    res.p[which(raw.cluster==level.cluster[j])] <- temp.level
                                }
                                res.p <- as.matrix(res.p)
                            } else {
                                res.p <- as.matrix(sample(c(-1, 1), dim(y)[1], replace = TRUE))
                            }

                            y.boot <- y-u.hat1+res.p * u.hat1
                            en.x.boot <- x[,en.var.x] - u.hat2 + res.p * u.hat2

                            if(length(ex.var.x)>0){
                                x.boot.ex <- matrix(x[,ex.var.x],ncol=length(ex.var.x))
                                colnames(x.boot.ex) <- ex.var.x
                            }else{
                                x.boot.ex <- matrix(NA,ncol=0,nrow=dim(dy)[1])
                            }

                            x.boot <- cbind(en.x.boot,x.boot.ex)
                            colnames(x.boot) <- c(en.var.x,ex.var.x)
                            x.boot <- x.boot[,colnames(x)]

                            boot.model <- try(ivfastplm.core(y = y.boot, x = x.boot, z = z, ind = ind, robust = robust,
                                                             sfe.index = sfe.index, cfe.index = cfe.index,
                                                             se = 1, cl = cluster, core.num = core.num,
                                                             df.use = df.use,
                                                             df.cl.use = df.cl.use))
                            if ('try-error' %in% class(boot.model)) {
                                return(NA)
                            } else {
                                boot.use <- (boot.model$est.coefficients[pos, "Coef"]-test.value)/boot.model$est.coefficients[pos, "Std. Error"]
                                return(c(boot.use))
                            }
                        }
                    }

                    if(length(en.var.x)>1){
                        dy.restricted <- dy - test.value*dx[,pos]
                        en.dx <- dx[,en.var.x]
                        pos.index <- which(colnames(en.dx)==pos)
                        en.dx.other <- matrix(en.dx[,-pos.index],ncol=dim(en.dx)[2]-1)

                        #a simple 2sls
                        dx1 <- cbind(en.dx.other,dx[,ex.var.x])
                        inv.dx1 <- solve(t(dx1)%*%dx1)
                        dz1 <- dz
                        inv.dz1 <- inv.z
                        Pdz1 <- dz1%*%inv.dz1%*%t(dz1)
                        inv.dxPzdx1 <- solve(t(dx1)%*%Pdz1%*%dx1)
                        reg1.coef <- matrix(inv.dxPzdx1%*%t(dx1)%*%Pdz1%*%dy.restricted,ncol=1)
                        u.hat1 <- matrix(dy.restricted-dx1%*%reg1.coef,ncol=1)

                        dy2 <- dx[,en.var.x]
                        dx2 <- cbind(dz,u.hat1)
                        inv.dx2 <- solve(t(dx2)%*%dx2)
                        reg2.coef <- inv.dx2%*%t(dx2)%*%dy2

                        reg2.coef.slice <- matrix(reg2.coef[(dim(dz)[2]+1),],ncol=dim(reg2.coef)[2])
                        u.hat2 <- dy2 - dx2%*%reg2.coef + kronecker(reg2.coef.slice,u.hat1)

                        one.boot <- function(num = NULL) {
                            if (!is.null(cluster)) {
                                ## wild boot by cluster
                                res.p <- rep(0,dim(cluster)[1])
                                for (j in 1:length(level.cluster)) {
                                    temp.level <- sample(c(-1,1), 1)
                                    res.p[which(raw.cluster==level.cluster[j])] <- temp.level
                                }
                                res.p <- as.matrix(res.p)
                            } else {
                                res.p <- as.matrix(sample(c(-1, 1), dim(y)[1], replace = TRUE))
                            }

                            y.boot <- y-u.hat1+res.p * u.hat1
                            en.x.boot <- matrix(x[,en.var.x] - u.hat2 + sweep(u.hat2, MARGIN=1, res.p, `*`),ncol=length(en.var.x))
                            if(length(ex.var.x)>0){
                                x.boot.ex <- matrix(x[,ex.var.x],ncol=length(ex.var.x))
                                colnames(x.boot.ex) <- ex.var.x
                            }else{
                                x.boot.ex <- matrix(NA,ncol=0,nrow=dim(dy)[1])
                            }

                            x.boot <- cbind(en.x.boot,x.boot.ex)
                            colnames(x.boot) <- c(en.var.x,ex.var.x)
                            x.boot <- x.boot[,colnames(x)]

                            boot.model <- try(ivfastplm.core(y = y.boot, x = x.boot, z = z, ind = ind, robust = robust,
                                                             sfe.index = sfe.index, cfe.index = cfe.index,
                                                             se = 1, cl = cluster, core.num = core.num,
                                                             df.use = df.use,
                                                             df.cl.use = df.cl.use))
                            if ('try-error' %in% class(boot.model)) {
                                return(NA)
                            } else {
                                boot.use <- (boot.model$est.coefficients[pos, "Coef"]-test.value)/boot.model$est.coefficients[pos, "Std. Error"]
                                return(c(boot.use))
                            }
                        }
                    }

                    boot.wald <- rep(NA, nboots)
                    if (parallel == TRUE) {
                        boot.out <- foreach(j = 1:nboots,
                                            .inorder = FALSE,
                                            .export = use.fun,
                                            .packages = c("fastplm")
                                            ) %dopar% {
                                                return(one.boot())
                                            }
                        boot.wald <- c(unlist(boot.out))
                    } else {
                        for (i in 1:nboots) {
                            boot.wald[i] <- one.boot()
                            if (i%%50==0) cat(i) else cat(".")
                        }
                    }

                    p.refine <- get.pvalue(boot.wald,to_test=(model.iv$est.coefficients[pos, "Coef"]-test.value)/model.iv$est.coefficients[pos, "Std. Error"])
                    CI.refine <- quantile(boot.wald, probs = c(0.025,0.975), na.rm = TRUE)*model.iv$est.coefficients[pos,'Std. Error'] + model.iv$est.coefficients[pos, "Coef"]

                    refine.sub <- c(model.iv$est.coefficients[pos,'Coef'],
                                    model.iv$est.coefficients[pos,'Std. Error'],
                                    (model.iv$est.coefficients[pos, "Coef"]-test.value)/model.iv$est.coefficients[pos, "Std. Error"],
                                    p.refine,
                                    #paste0(pos,"=",test.value),
                                    CI.refine[1],
                                    CI.refine[2])

                    refine.sub <- matrix(refine.sub,nrow=1)
                    #refine.sub <- as.data.frame(refine.sub)
                    rownames(refine.sub) <- pos
                    colnames(refine.sub) <- c("Coef","Std Error","t value(H0)",
                                              "Refined P value","Refined CI_lower","Refined CI_upper")
                    model.iv$refinement <- list(wald.refinement = refine.sub, boot.wald = boot.wald)
                }

                if(pos %in% ex.var.x){
                    # wild restricted residual bootstrap
                    cat("Wild Restricted Bootstrap with Percentile-t Refinement.\n")
                    boot.wald <- rep(NA, nboots)

                    dy.restricted <- dy - test.value*dx[,pos]
                    pos.index <- which(colnames(dx)==pos)
                    dx.other <- matrix(dx[,-pos.index],ncol=dim(dx)[2]-1)

                    #a simple 2sls
                    dx1 <- dx.other
                    inv.dx1 <- solve(t(dx1)%*%dx1)
                    dz1 <- dz
                    inv.dz1 <- inv.z
                    Pdz1 <- dz1%*%inv.dz1%*%t(dz1)
                    inv.dxPzdx1 <- solve(t(dx1)%*%Pdz1%*%dx1)
                    reg1.coef <- matrix(inv.dxPzdx1%*%t(dx1)%*%Pdz1%*%dy.restricted,ncol=1)
                    u.hat1 <- matrix(dy.restricted-dx1%*%reg1.coef,ncol=1)

                    boot.wald <- rep(NA, nboots)
                    one.boot <- function(num = NULL) {
                        if (!is.null(cluster)) {
                            ## wild boot by cluster
                            res.p <- rep(0,dim(cluster)[1])
                            for (j in 1:length(level.cluster)) {
                                temp.level <- sample(c(-1,1), 1)
                                res.p[which(raw.cluster==level.cluster[j])] <- temp.level
                            }
                            res.p <- as.matrix(res.p)
                        } else {
                            res.p <- as.matrix(sample(c(-1, 1), dim(y)[1], replace = TRUE))
                        }
                        y.boot <- y - u.hat1 + res.p * u.hat1
                        x.boot.en <- matrix(en.var.x.fitted + sweep(en.var.x.res, MARGIN=1, res.p, `*`),ncol=length(en.var.x))
                        colnames(x.boot.en) <- en.var.x

                        if(length(ex.var.x)>0){
                            x.boot.ex <- matrix(x[,ex.var.x],ncol=length(ex.var.x))
                            colnames(x.boot.ex) <- ex.var.x
                        }else{
                            x.boot.ex <- matrix(NA,ncol=0,nrow=dim(dy)[1])
                        }

                        x.boot <- cbind(x.boot.en,x.boot.ex)
                        colnames(x.boot) <- c(en.var.x,ex.var.x)
                        x.boot <- x.boot[,colnames(x)]

                        boot.model <- try(ivfastplm.core(y = y.boot, x = x.boot, z = z, ind = ind, robust = robust,
                                                         sfe.index = sfe.index, cfe.index = cfe.index,
                                                         se = 1, cl = cluster, core.num = core.num,
                                                         df.use = df.use,
                                                         df.cl.use = df.cl.use))
                        if ('try-error' %in% class(boot.model)) {
                            return(NA)
                        } else {
                            boot.use <- (boot.model$est.coefficients[pos, "Coef"]-test.value)/boot.model$est.coefficients[pos, "Std. Error"]
                            return(c(boot.use))
                        }
                    }

                    if (parallel == TRUE) {
                        boot.out <- foreach(j = 1:nboots,
                                            .inorder = FALSE,
                                            .export = use.fun,
                                            .packages = c("fastplm")
                                            ) %dopar% {
                                                return(one.boot())
                                            }
                        for (j in 1:nboots) {
                            boot.wald[j] <- c(unlist(boot.out[[j]]))
                        }
                    } else {
                        for (i in 1:nboots) {
                            boot.wald[i] <- one.boot()
                            if (i%%50==0) cat(i) else cat(".")
                        }
                    }

                    p.refine <- get.pvalue(boot.wald,to_test=(model.iv$est.coefficients[pos, "Coef"]-test.value)/model.iv$est.coefficients[pos, "Std. Error"])
                    CI.refine <- quantile(boot.wald, probs = c(0.025,0.975), na.rm = TRUE)*model.iv$est.coefficients[pos,'Std. Error'] + model.iv$est.coefficients[pos, "Coef"]

                   refine.sub <- c(model.iv$est.coefficients[pos,'Coef'],
                                    model.iv$est.coefficients[pos,'Std. Error'],
                                    (model.iv$est.coefficients[pos, "Coef"]-test.value)/model.iv$est.coefficients[pos, "Std. Error"],
                                    p.refine,
                                    #paste0(pos,"=",test.value),
                                    CI.refine[1],
                                    CI.refine[2])

                    refine.sub <- matrix(refine.sub,nrow=1)
                    #refine.sub <- as.data.frame(refine.sub)
                    rownames(refine.sub) <- pos
                    colnames(refine.sub) <- c("Coef","Std Error","t value(H0)",
                                              "Refined P value","Refined CI_lower","Refined CI_upper")
                    model.iv$refinement <- list(wald.refinement = refine.sub, boot.wald = boot.wald)
                }
            }
        }
    }
    else{

        if (jackknife ==1 || is.null(cluster)) {
                jack.pos <- 1
                if (jackknife == 1) {
                    nboots <- length(unique(ind[,1]))
                    jack.pos <- as.numeric(as.factor(ind[,1]))
                }
                boot.coef <- matrix(NA, p, nboots)

        if(refinement==0){
            if (jackknife == 1){
                cat("Jackknife without Percentile-t Refinement.\n")
            }else{
                cat("Pairs Bootstrap without Percentile-t Refinement.\n")
            }

            one.boot <- function(num = NULL) {
                if (is.null(num)) {
                    boot.id <- sample(1:dim(y)[1], dim(y)[1], replace = TRUE)
                } else {
                    boot.id <- (1:dim(y)[1])[which(jack.pos != num)]
                }

                boot.model <- try(ivfastplm.core(y = as.matrix(y[boot.id,]),
                                                 x = as.matrix(x[boot.id,]),
                                                 z = as.matrix(z[boot.id,]),
                                                 ind = as.matrix(ind[boot.id,]),
                                                 sfe.index = sfe.index, cfe.index = cfe.index,
                                                 se = 0, cl = NULL, core.num = core.num))

                if ('try-error' %in% class(boot.model)) {
                    return(rep(NA, p))
                } else {
                    return(c(boot.model$coefficients))
                }
            }

            boot.seq <- NULL
            if (jackknife == 1) {
                boot.seq <- unique(jack.pos)
            }

            if (parallel == TRUE) {
                boot.out <- foreach(j = 1:nboots,
                                    .inorder = FALSE,
                                    .export = use.fun,
                                    .packages = c("fastplm")
                                    ) %dopar% {
                                        return(one.boot(boot.seq[j]))
                                    }
                for (j in 1:nboots) {
                    boot.coef[, j] <- c(boot.out[[j]])
                }
            } else {
                for (i in 1:nboots) {
                    boot.coef[, i] <- one.boot(boot.seq[i])
                    if (i%%50==0) cat(i) else cat(".")
                }
            }

            if (jackknife == 0) {
                P_x <- as.matrix(apply(boot.coef, 1, get.pvalue))
                stderror <- as.matrix(apply(boot.coef, 1, sd, na.rm = TRUE))
                CI <- t(apply(boot.coef, 1, quantile, c(0.025, 0.975), na.rm = TRUE))
                ## rewrite uncertainty estimates
                est.coefficients <- cbind(model.iv$coefficients, stderror,model.iv$coefficients/stderror, P_x, CI)
                vcov <- as.matrix(cov(t(boot.coef),use="na.or.complete"))
            } else {
                beta.j <- jackknifed(model.iv$coefficients, boot.coef, 0.05)
                est.coefficients <- cbind(model.iv$coefficients, beta.j$se,model.iv$coefficients/beta.j$se, beta.j$P, beta.j$CI.l, beta.j$CI.u)
                vcov <- beta.j$Yvcov
            }
            colnames(est.coefficients) <- c("Coef", "Std. Error","Z Value", "P Value", "CI_lower", "CI_upper")
            rownames(est.coefficients) <- colnames(dx)
            model.iv$est.coefficients <- est.coefficients

            colnames(vcov) <- colnames(dx)
            rownames(vcov) <- colnames(dx)
            model.iv$vcov <- vcov
        }

        if(refinement==1){
            if (jackknife == 1){
                stop("Can't refine a Jackknife P-Value,\n")
                #cat("Jackknife with Percentile-t Refinement.\n")
            }else{
                cat("Pairs Bootstrap with Percentile-t Refinement.\n")
            }

            one.boot <- function(num = NULL) {
                boot.id <- sample(1:dim(y)[1], dim(y)[1], replace = TRUE)
                boot.model <- try(ivfastplm.core(y = as.matrix(y[boot.id,]),
                                               x = as.matrix(x[boot.id,]),
                                               z = as.matrix(z[boot.id,]),
                                               ind = as.matrix(ind[boot.id,]),
                                               robust = robust,
                                               sfe.index = sfe.index, cfe.index = cfe.index,
                                               se = 1, cl = NULL, core.num = core.num))

                if ('try-error' %in% class(boot.model)) {
                    return(rep(NA, p))
                } else {
                    boot.use <- (boot.model$est.coefficients[, "Coef"]-model.iv$est.coefficients[, "Coef"])/boot.model$est.coefficients[, "Std. Error"]
                    return(c(boot.use))
                }
            }

            if (parallel == TRUE) {
                boot.out <- foreach(j = 1:nboots,
                                        .inorder = FALSE,
                                        .export = use.fun,
                                        .packages = c("fastplm")
                                        ) %dopar% {
                                            return(one.boot())
                                        }
                for (j in 1:nboots) {
                    boot.coef[, j] <- c(boot.out[[j]])
                }
            } else {
                for (i in 1:nboots) {
                    boot.coef[, i] <- one.boot()
                    if (i%%50==0) cat(i) else cat(".")
                }
            }

            wald.refinement <- matrix(NA,nrow=0,ncol=6)
            null.totest <- model.iv$est.coefficients[,'t value']
            for(k in 1:length(null.totest)){
                p.refine <- get.pvalue(boot.coef[k,],to_test=null.totest[k])
                CI.refine <- quantile(boot.coef[k,], probs = c(0.025,0.975), na.rm = TRUE)*model.iv$est.coefficients[k,'Std. Error'] + model.iv$est.coefficients[k,'Coef']
                refine.sub <- c(model.iv$est.coefficients[k,'Coef'],
                                model.iv$est.coefficients[k,'Std. Error'],
                                model.iv$est.coefficients[k,'t value'],
                                p.refine,
                                CI.refine[1],
                                CI.refine[2])
                wald.refinement <- rbind(wald.refinement,refine.sub)
            }
            colnames(wald.refinement) <- c("Coef","Std Error","t value",
                                               "Refined P value","Refined CI_lower",
                                               "Refined CI_upper")
            rownames(wald.refinement) <- colnames(dx)
            model.iv$refinement <- list(wald.refinement = wald.refinement, boot.wald = boot.coef)
        }
        }
        else{ #clustered
            if (refinement == 0) {
                cat("Pairs Bootstrap without Percentile-t Refinement.\n")
                boot.coef <- matrix(NA, p, nboots)
                if (dim(cluster)[2] == 1) {
                    ## one-way cluster
                    raw.cluster <- as.numeric(as.factor(cluster))
                    level.cluster <- unique(raw.cluster)
                    ## level.count <- table(raw.cluster)
                    split.id <- split(1:dim(y)[1], raw.cluster)
                    one.boot <- function(num = NULL) {
                        level.id <- sample(level.cluster, length(level.cluster), replace = TRUE)
                        boot.id <- c()
                        for (j in 1:length(level.id)) {
                            boot.id <- c(boot.id, split.id[[level.id[j]]])
                        }
                        boot.model <- try(ivfastplm.core(y = as.matrix(y[boot.id,]),
                                                         x = as.matrix(x[boot.id,]),
                                                         z = as.matrix(z[boot.id,]),
                                                         ind = as.matrix(ind[boot.id,]),
                                                         sfe.index = sfe.index, cfe.index = cfe.index,
                                                         se = 0, cl = NULL, core.num = core.num))
                        if ('try-error' %in% class(boot.model)) {
                            return(rep(NA, p))
                        } else {
                            return(c(boot.model$coefficients))
                        }
                    }

                    if (parallel == TRUE) {
                        boot.out <- foreach(j = 1:nboots,
                                            .inorder = FALSE,
                                            .export = use.fun,
                                            .packages = c("fastplm")
                                            ) %dopar% {
                                                return(one.boot())
                                            }
                        for (j in 1:nboots) {
                            boot.coef[, j] <- c(boot.out[[j]])
                        }
                    } else {
                        for (i in 1:nboots) {
                            boot.coef[, i] <- one.boot()
                            if (i%%50==0) cat(i) else cat(".")
                        }
                    }

                    P_x <- as.matrix(apply(boot.coef, 1, get.pvalue))
                    stderror <- as.matrix(apply(boot.coef, 1, sd, na.rm = TRUE))
                    CI <- t(apply(boot.coef, 1, quantile, c(0.025, 0.975), na.rm = TRUE))
                    ## rewrite uncertainty estimates
                    est.coefficients <- cbind(model.iv$coefficients, stderror,model.iv$coefficients/stderror, P_x, CI)
                    colnames(est.coefficients) <- c("Coef", "Std. Error","Z Value", "P Value", "CI_lower", "CI_upper")
                    rownames(est.coefficients) <- colnames(dx)
                    model.iv$est.coefficients <- est.coefficients

                    vcov <- as.matrix(cov(t(boot.coef),use="na.or.complete"))
                    colnames(vcov) <- colnames(dx)
                    rownames(vcov) <- colnames(dx)
                    model.iv$vcov <- vcov
                }
                else if (dim(cluster)[2] == 2) {
                    ## two-way cluster
                    boot.coef1 <- boot.coef2 <- boot.coef3 <- matrix(NA, p, nboots)
                    ## level 1
                    raw.cluster1 <- as.numeric(as.factor(cluster[,1]))
                    level.cluster1 <- unique(raw.cluster1)
                    ## level 2
                    raw.cluster2 <- as.numeric(as.factor(cluster[,2]))
                    level.cluster2 <- unique(raw.cluster2)
                    ## intersection
                    raw.cluster3 <- as.numeric(as.factor(paste(cluster[,1], "-:-", cluster[,2], sep = "")))
                    level.cluster3 <- unique(raw.cluster3)

                    split.id1 <- split(1:dim(y)[1], raw.cluster1)
                    split.id2 <- split(1:dim(y)[1], raw.cluster2)
                    split.id3 <- split(1:dim(y)[1], raw.cluster3)

                    one.boot <- function(num = NULL) {
                        ## level 1
                        level.id1 <- sample(level.cluster1, length(level.cluster1), replace = TRUE)
                        boot.id1 <- c()
                        for (j in 1:length(level.id1)) {
                            boot.id1 <- c(boot.id1, split.id1[[level.id1[j]]])
                        }

                        ## level 2
                        level.id2 <- sample(level.cluster2, length(level.cluster2), replace = TRUE)
                        boot.id2 <- c()
                        for (j in 1:length(level.id2)) {
                            boot.id2 <- c(boot.id2, split.id2[[level.id2[j]]])
                        }

                        ## intersection
                        level.id3 <- sample(level.cluster3, length(level.cluster3), replace = TRUE)
                        boot.id3 <- c()
                        for (j in 1:length(level.id3)) {
                            boot.id3 <- c(boot.id3, split.id3[[level.id3[j]]])
                        }

                        ## level 1
                        boot.model1 <- try(ivfastplm.core(y = as.matrix(y[boot.id1,]),
                                                         x = as.matrix(x[boot.id1,]),
                                                         z = as.matrix(z[boot.id1,]),
                                                         ind = as.matrix(ind[boot.id1,]),
                                                         sfe.index = sfe.index, cfe.index = cfe.index,
                                                         se = 0, cl = NULL, core.num = core.num))
                        if ('try-error' %in% class(boot.model1)) {
                            oneboot.coef1 <- rep(NA, p)
                        } else {
                            oneboot.coef1 <- c(boot.model1$coefficients)
                        }

                        ## level 2
                        boot.model2 <- try(ivfastplm.core (y = as.matrix(y[boot.id2,]),
                                                         x = as.matrix(x[boot.id2,]),
                                                         z = as.matrix(z[boot.id2,]),
                                                         ind = as.matrix(ind[boot.id2,]),
                                                         sfe.index = sfe.index, cfe.index = cfe.index,
                                                         se = 0, cl = NULL, core.num = core.num))
                        if ('try-error' %in% class(boot.model2)) {
                            oneboot.coef2 <- rep(NA, p)
                        } else {
                            oneboot.coef2 <- c(boot.model2$coefficients)
                        }

                        ## intersection
                        boot.model3 <- try(ivfastplm.core (y = as.matrix(y[boot.id3,]),
                                                         x = as.matrix(x[boot.id3,]),
                                                         z = as.matrix(z[boot.id3,]),
                                                         ind = as.matrix(ind[boot.id3,]),
                                                         sfe.index = sfe.index, cfe.index = cfe.index,
                                                         se = 0, cl = NULL, core.num = core.num))
                        if ('try-error' %in% class(boot.model3)) {
                            oneboot.coef3 <- rep(NA, p)
                        } else {
                            oneboot.coef3 <- c(boot.model3$coefficients)
                        }

                        return(list(oneboot.coef1 = oneboot.coef1,
                                    oneboot.coef2 = oneboot.coef2,
                                    oneboot.coef3 = oneboot.coef3))

                    }

                    if (parallel == TRUE) {
                        boot.out <- foreach(j = 1:nboots,
                                            .inorder = FALSE,
                                            .export = use.fun,
                                            .packages = c("fastplm")
                                            ) %dopar% {
                                                return(one.boot())
                                            }
                        for (j in 1:nboots) {
                            boot.coef1[, j] <- c(boot.out[[j]]$oneboot.coef1)
                            boot.coef2[, j] <- c(boot.out[[j]]$oneboot.coef2)
                            boot.coef3[, j] <- c(boot.out[[j]]$oneboot.coef3)
                        }
                    } else {
                        for (i in 1:nboots) {
                            boot.sub <- one.boot()
                            boot.coef1[, i] <- c(boot.sub$oneboot.coef1)
                            boot.coef2[, i] <- c(boot.sub$oneboot.coef2)
                            boot.coef3[, i] <- c(boot.sub$oneboot.coef3)
                            if (i%%50==0) cat(i) else cat(".")
                        }
                    }

                    stderror1 <- as.matrix(apply(boot.coef1, 1, sd, na.rm = TRUE))
                    stderror2 <- as.matrix(apply(boot.coef2, 1, sd, na.rm = TRUE))
                    stderror3 <- as.matrix(apply(boot.coef3, 1, sd, na.rm = TRUE))
                    stderror <- stderror1 + stderror2 - stderror3

                    vcov1 <- as.matrix(cov(t(boot.coef1),use="na.or.complete"))
                    vcov2 <- as.matrix(cov(t(boot.coef2),use="na.or.complete"))
                    vcov3 <- as.matrix(cov(t(boot.coef3),use="na.or.complete"))
                    vcov <- vcov1 + vcov2 - vcov3
                    colnames(vcov) <- colnames(dx)
                    rownames(vcov) <- colnames(dx)
                    model.iv$vcov <- vcov

                    CI <- cbind(c(model.iv$coefficients) - qnorm(0.975)*c(stderror), c(model.iv$coefficients) + qnorm(0.975)*c(stderror))
                    Zx <- c(model.iv$coefficients)/c(stderror)
                    P_z <- 2 * min(1 - pnorm(Zx), pnorm(Zx))
                    ## rewrite uncertainty estimates
                    est.coefficients <- cbind(model.iv$coefficients, stderror, Zx, P_z, CI)
                    colnames(est.coefficients) <- c("Coef", "Std. Error", "Z value", "Pr(>|Z|)", "CI_lower", "CI_upper")
                    rownames(est.coefficients) <- colnames(dx)
                    model.iv$est.coefficients <- est.coefficients
                }
            }

            if(refinement==1){
                cat("Pairs Bootstrap with Percentile-t Refinement.\n")
                ## bootstrap refinement
                boot.coef <- matrix(NA, p, nboots)

                if(dim(cluster)[2]==1){
                    ## one-way cluster
                    raw.cluster <- as.numeric(as.factor(cluster))
                    level.cluster <- unique(raw.cluster)
                    level.count <- table(raw.cluster)
                }
                if(dim(cluster)[2]==2){
                    stop("For pairs bootstrap with refinement, please only specify one cluster variable.\n")
                    if(is.null(bootcluster)){
                        level.cluster.1 <- unique(as.numeric(as.factor(cluster[,1])))
                        level.cluster.2 <- unique(as.numeric(as.factor(cluster[,2])))
                        if(length(level.cluster.1)<=length(level.cluster.2)){
                            raw.cluster <- as.numeric(as.factor(cluster[,1]))
                            bootcluster <- colnames(cluster)[1]
                        }else{
                            raw.cluster <- as.numeric(as.factor(cluster[,2]))
                            bootcluster <- colnames(cluster)[2]
                        }
                        level.cluster <- unique(raw.cluster)
                        level.count <- table(raw.cluster)
                    }else{
                        raw.cluster <- as.numeric(as.factor(cluster[,bootcluster]))
                        level.cluster <- unique(raw.cluster)
                        level.count <- table(raw.cluster)
                    }
                    cat(paste0("Mutiple Clustered Pairs Bootstrap with Refinement: (Boot)Clustered at ",bootcluster," level.\n"))
                }

                split.id <- split(1:dim(y)[1], raw.cluster)

                one.boot <- function(num = NULL) {
                    level.id <- sample(level.cluster, length(level.cluster), replace = TRUE)
                    boot.id <- c()
                    boot.cluster <- c()
                    for (j in 1:length(level.id)) {
                        boot.id <- c(boot.id, split.id[[level.id[j]]])
                        boot.cluster <- c(boot.cluster, rep(j, level.count[level.id[j]]))
                    }
                    boot.cluster <- as.matrix(boot.cluster)

                    boot.model <- try(ivfastplm.core (y = as.matrix(y[boot.id,]),
                                                    x = as.matrix(x[boot.id,]),
                                                    z = as.matrix(z[boot.id,]),
                                                    ind = as.matrix(ind[boot.id,]), robust = robust,
                                                    sfe.index = sfe.index, cfe.index = cfe.index,
                                                    se = 1, cl = boot.cluster, core.num = core.num))
                    if ('try-error' %in% class(boot.model)) {
                        return(rep(NA, p))
                    } else {
                        return(c(boot.model$coefficients - model.iv$coefficients)/c(boot.model$est.coefficients[, "Std. Error"]))
                    }
                }

                if (parallel == TRUE) {
                    boot.out <- foreach(j = 1:nboots,
                                        .inorder = FALSE,
                                        .export = use.fun,
                                        .packages = c("fastplm")
                                        ) %dopar% {
                                            return(one.boot())
                                        }
                    for (j in 1:nboots) {
                        boot.coef[, j] <- c(boot.out[[j]])
                    }
                } else {
                    for (i in 1:nboots) {
                        boot.coef[, i] <- one.boot()
                        if (i%%50==0) cat(i) else cat(".")
                    }
                }

                wald.refinement <- matrix(NA,nrow=0,ncol=6)
                null.totest <- model.iv$est.coefficients[,'t value']
                for(k in 1:length(null.totest)){
                    p.refine <- get.pvalue(boot.coef[k,],to_test=null.totest[k])
                    CI.refine <- quantile(boot.coef[k,], probs = c(0.025,0.975), na.rm = TRUE)*model.iv$est.coefficients[k,'Std. Error'] + model.iv$est.coefficients[k,'Coef']
                    refine.sub <- c(model.iv$est.coefficients[k,'Coef'],
                                    model.iv$est.coefficients[k,'Std. Error'],
                                    model.iv$est.coefficients[k,'t value'],
                                    p.refine,
                                    CI.refine[1],
                                    CI.refine[2])
                    wald.refinement <- rbind(wald.refinement,refine.sub)
                }
                colnames(wald.refinement) <- c("Coef","Std Error","t value",
                                               "Refined P value","Refined CI_lower",
                                               "Refined CI_upper")
                rownames(wald.refinement) <- colnames(dx)
                model.iv$refinement <- list(wald.refinement = wald.refinement, boot.wald = boot.coef)
            }
        }
    }
    if(parallel==TRUE){
        suppressWarnings(stopCluster(pcl))
    }

    return(model.iv)

}


# 4. faza: Napredna analiza podatkov
setwd("/Users/blazpovh/Documents/R_projektna_naloga/APPR-2021-22-Blaz-Povh/")
Tabela_porabe1 <- read.csv("~/Documents/R_projektna_naloga/APPR-2021-22-Blaz-Povh/podatki/zdruzeni_podatki/Tabela_porabe.csv", sep="")

dnevna_poraba <-rowSums(Tabela_porabe1[ ,3:98],is.na(Tabela_porabe1) == FALSE)
length(dnevna_poraba)
porabniki  <-  labels(table(Tabela_porabe1$porabnik))[[1]]

povpr_poraba=c()
for (i in 1:length(porabniki)){
  print(i)
  poraba=dnevna_poraba[Tabela_porabe1$porabnik==porabniki[i]]
  povpr_poraba[i]=mean(poraba)
}
frekvenca <- c(1:51)
data_povpr_poraba <- data.frame(povpr_poraba,frekvenca)

jpeg("slike/prikaz_skupne_povprecne_porabe_za_razlicne_porabnike.jpg")
chol <- data_povpr_poraba
qplot(chol$povpr_poraba,
      geom = "histogram",
      binwidth= 40,
      main = "Povprečna poraba el. energije za različne porabnike",
      xlab = "Povprečna poraba",
      ylab = "Frekvenca",
      ylim = c(0,10))
dev.off()
jpeg("slike/prikaz_skupne_povprecne_porabe_za_razlicne_meritve.jpg")
Tabela_delovnih_dni <- filter(Tabela_porabe1, Prosti_dan == "FALSE")
meritev3 <- colMeans(Tabela_delovnih_dni[ , 3:98 ],is.na(Tabela_porabe1)== FALSE)
p3 <-plot(meritev3, type = "o",pch = 20, xlab="čas",ylab = "povprečna poraba",main = "Graf povprečne poraba el. energije za različne tipe dni",xaxt='n')
meritev1 <- colMeans(Tabela_porabe1[ , 3:98 ],is.na(Tabela_porabe1)== FALSE)
p1 <-points(meritev1, type = "o",pch = 20, xlab="čas",ylab = "povprečna poraba",main = "Graf povprečne poraba el. energije za razl. meritve",xaxt='n',col="blue")
Tabela_prostih_dni <- filter(Tabela_porabe1, Prosti_dan == "TRUE")
meritev2 <- colMeans(Tabela_prostih_dni[ , 3:98 ],is.na(Tabela_porabe1)== FALSE)
p2 <-points(meritev2, type = "o",pch = 20, xlab="čas",ylab = "povprečna poraba",main = "Graf povprečne poraba el. energije za proste dni",xaxt='n',col="red")
Tabela_delovnih_dni <- filter(Tabela_porabe1, Prosti_dan == "FALSE")
meritev3 <- colMeans(Tabela_delovnih_dni[ , 3:98 ],is.na(Tabela_porabe1)== FALSE)
p3 <-points(meritev3, type = "o",pch = 20, xlab="čas",ylab = "povprečna poraba",main = "Graf povprečne poraba el. energije za delavne dni",xaxt='n',col="green")
xlabels=c("3h","6h","9h","12h","15h","18h","21h","24h")
axis(side=1, at=c(12,24,36,48,60,72,84,96),labels=xlabels)
legend(title = "Legenda", legend = c("vsi dnevi","prosti dnevi","delovni dnevi"),"topright",col = c("blue","red","green"),lty = 1)
dev.off()

jpeg("slike/prikaz_skupne_povprecne_porabe_za_proste_dni.jpg")
Tabela_prostih_dni <- filter(Tabela_porabe1, Prosti_dan == "TRUE")
meritev2 <- colMeans(Tabela_prostih_dni[ , 3:98 ],is.na(Tabela_porabe1)== FALSE)
p2 <-plot(meritev2, type = "o",pch = 20, xlab="čas",ylab = "povprečna poraba",main = "Graf povprečne poraba el. energije za proste dni",xaxt='n')
xlabels=c("3h","6h","9h","12h","15h","18h","21h","24h")
axis(side=1, at=c(12,24,36,48,60,72,84,96),labels=xlabels)
dev.off()

jpeg("slike/prikaz_skupne_povprecne_porabe_za_delovne_dni.jpg")
Tabela_delovnih_dni <- filter(Tabela_porabe1, Prosti_dan == "FALSE")
meritev3 <- colMeans(Tabela_delovnih_dni[ , 3:98 ],is.na(Tabela_porabe1)== FALSE)
p3 <-plot(meritev3, type = "o",pch = 20, xlab="čas",ylab = "povprečna poraba",main = "Graf povprečne poraba el. energije za delavne dni",xaxt='n')
xlabels=c("3h","6h","9h","12h","15h","18h","21h","24h")
axis(side=1, at=c(12,24,36,48,60,72,84,96),labels=xlabels)
dev.off()

jpeg("slike/prikaz_skupne_povprecne_porabe_za_razlicne_dneve.jpg")
par(mar=c(5,6,4,1)+.0001)
plot(c(0,97),c(0.5,4),main="Povprečna poraba za dneve v tednu",type = "n",pch=20, xlab = "čas", ylab = "povprečna poraba",xaxt='n')
povpr_poraba_ponedeljek <- colMeans(filter(Tabela_porabe1, Ime_dneva =="Monday")[ ,3:98])
graf_ponedeljek <- points(povpr_poraba_ponedeljek,type = "o",pch=20,xaxt='n',col="black")
povpr_poraba_torek <- colMeans(filter(Tabela_porabe1, Ime_dneva =="Tuesday")[ ,3:98])
graf_torek <- points(povpr_poraba_torek, type = "o",pch=20,xaxt='n',col="red")
povpr_poraba_sreda <- colMeans(filter(Tabela_porabe1, Ime_dneva =="Wednesday")[ ,3:98])
graf_sreda <- points(povpr_poraba_sreda, type = "o",pch=20,xaxt='n',col="blue")
povpr_poraba_cetrtek <- colMeans(filter(Tabela_porabe1, Ime_dneva =="Thursday")[ ,3:98])
graf_cetrtek <- points(povpr_poraba_cetrtek, type = "o",pch=20,xaxt='n',col="green")
povpr_poraba_petek <- colMeans(filter(Tabela_porabe1, Ime_dneva =="Friday")[ ,3:98])
graf_petek <- points(povpr_poraba_petek, type = "o",pch=20,xaxt='n',col="orange")
povpr_poraba_sobota <- colMeans(filter(Tabela_porabe1, Ime_dneva =="Saturday")[ ,3:98])
graf_sobota <- points(povpr_poraba_sobota, type = "o",pch=20,xaxt='n',col="yellow")
povpr_poraba_nedelja <- colMeans(filter(Tabela_porabe1, Ime_dneva =="Sunday")[ ,3:98])
graf_nedelja <- points(povpr_poraba_nedelja, type = "o",pch=20,xaxt='n',col="purple")
xlabels=c("3h","6h","9h","12h","15h","18h","21h","24h")
axis(side=1, at=c(12,24,36,48,60,72,84,96),labels=xlabels)
legend(title = "Legenda", legend = c("ponedeljek","torek","sreda","cetrtek","petek","sobota","nedelja"),"topright",col = c("black","red","blue","green","orange","yellow","purple"),lty=1)
dev.off()

# ***********************************************
# od tu naprej imam analizo za vremenske podatke
# **********************************************
data_vreme2_tidy <- read.table("podatki/zdruzeni_podatki/data_vreme2_tidy.txt",sep=" ")
datumi <- (data_vreme2_tidy$datum)
padavine_po_dnevih <- data.frame(rowSums(data_vreme2_tidy[ ,4:51], is.na(data_vreme2_tidy) == FALSE))
colnames(padavine_po_dnevih) <- c('Kolicina padavin za dan')
rownames(padavine_po_dnevih) <-c(datumi)
write.table(padavine_po_dnevih,"podatki/zdruzeni_podatki/padavine_po_dnevih.txt",sep=" ")

temperature_po_dnevih <- data.frame(rowMeans(data_vreme2_tidy[ ,52:99], is.na(data_vreme2_tidy) == FALSE))
colnames(temperature_po_dnevih) <- c('Skupna temperatura za dan')
rownames(temperature_po_dnevih) <-c(datumi)
write.table(temperature_po_dnevih,"podatki/zdruzeni_podatki/temperature_po_dnevih.txt",sep=" ")

padavine_po_urah <- data.frame(colSums(data_vreme2_tidy[ ,4:51]))
colnames(padavine_po_urah) <- c('Povprecna kol padavina za to uro')
write.table(padavine_po_urah,"podatki/zdruzeni_podatki/padavine_po_urah.txt",sep=" ")

temperature_po_urah <- data.frame(colMeans(data_vreme2_tidy[ ,52:99], is.na(data_vreme2_tidy) == FALSE))
colnames(temperature_po_urah) <- c('Povprecna temperatura za vsako casovno obdobje')
write.table(temperature_po_urah,"podatki/zdruzeni_podatki/temperature_po_urah.txt",sep=" ")

# *************************************************
# Korelacije
# *************************************************
povpr_poraba_za_vsak_dan <-rowMeans(Tabela_porabe1[ ,3:98])
povpr_poraba_matrika <- t(matrix(povpr_poraba_za_vsak_dan,198,51))
povpr_poraba_za_vsak_dan1 <- as.vector(colSums(povpr_poraba_matrika))
povpr_poraba_za_vsak_dan1<-povpr_poraba_za_vsak_dan1[-198]
povprecna_T_za_vsak_dan <- temperature_po_dnevih$`Skupna temperatura za dan`
skupne_padavine_za_vsak_dan <- padavine_po_dnevih$`Kolicina padavin za dan`
r12=cor(povpr_poraba_za_vsak_dan1,povprecna_T_za_vsak_dan[1:197]) #brisem zato ker za porabo na koncu 0
r13=cor(povpr_poraba_za_vsak_dan1,skupne_padavine_za_vsak_dan[1:197])

# ***************************************************
# Napovedni model s časovnimi vrstami
# ***************************************************
povpr_poraba_za_vsak_dan_ts <- ts(povpr_poraba_za_vsak_dan1, frequency = 365, start = c(2021,1))
arima_model <- auto.arima(povpr_poraba_za_vsak_dan_ts)
summary(arima_model)
holt_model <- holt(povpr_poraba_za_vsak_dan_ts, h=1)
summary(holt_model)
se_model <- ses(povpr_poraba_za_vsak_dan_ts, h = 1)
summary(se_model)
naive_mod <- naive(povpr_poraba_za_vsak_dan_ts, h = 1)
summary(naive_mod, "NA"= 0)

jpeg("slike/prikaz_natancnosti_razlicnih_napovednih_modelov.jpg")
mar.default <- c(5,2,4,2) + 0.1
par(mar = mar.default + c(0, 4, 0, 0),family="serif") #axis(side, at=, labels=, pos=, lty=, col=, las=, tck=, ...)
title="Povprečna poraba in njene  napovedi"
plot(c(2021,2021.6), c(0,170),yaxt='n',xaxt='n',main=title, type = "n", pch=19,cex.lab=1.2, cex.axis=1.3, cex.main=1.5,xlab = "Čas",ylab = "Povprečna poraba")  # setting up coord. system
xlabels = c(2021,2021.1, 2021.2, 2021.3, 2021.4, 2021.5, 2021.6)
ylabels = c(1:10)*17
axis(side=1,at=xlabels)
axis(side=2,at=ylabels)
lines(arima_model$fitted, type = "l", col = "blue",lwd=1,cex = 1,pch=16)
lines(holt_model$fitted, type = "l", col = "green",lwd=1,cex = 1,pch=16)
lines(se_model$fitted, type = "l", col = "red",lwd=1,cex = 1,pch=16)
lines(naive_mod$fitted, type = "l", col = "purple",lwd=1,cex = 1,pch=16)
lines(povpr_poraba_za_vsak_dan_ts, type = "l", col = "orange",lwd=2,cex = 1,pch=16)
legend("top", legend=(c("Dejanska poraba","Arima model", "Holt model", "Se model", "Naive mod")), pch=c(16,16),cex=c(1.2,1.2),col=c("orange","blue", "green", "red", "purple"),y.intersp=0.8)
dev.off()
# ***************************************************
# Grupiranje rezultatov
# ***************************************************
povpr_poraba_za_vsak_dan <-rowMeans(Tabela_porabe1[ ,3:98])
povpr_poraba_matrika <- t(matrix(povpr_poraba_za_vsak_dan,198,51))
set.seed(123)

# *************************************************************
# Ugotavljanje optimalnega števila skupin s silhuetnim diagramom
# *************************************************************
obrisi = function(podatki, hc = TRUE, od = 2, do = NULL) {
  n = nrow(podatki)
  if (is.null(do)) {
    do = n - 1
  }

  razdalje = dist(podatki)

  k.obrisi = tibble()
  for (k in od:do) {
    if (hc) {
      o.k = hclust(razdalje) %>%
        cutree(k) %>%
        silhouette(razdalje)
    } else {
      set.seed(42) # zato, da so rezultati ponovljivi
      o.k = kmeans(podatki, k)$cluster %>%
        silhouette(razdalje)
    }
    k.obrisi = k.obrisi %>% bind_rows(
      tibble(
        k = rep(k, n),
        obrisi = o.k[, "sil_width"]
      )
    )
  }
  k.obrisi$k = as.ordered(k.obrisi$k)

  k.obrisi
}

obrisi.povprecje = function(k.obrisi) {
  k.obrisi.povprecje = k.obrisi %>%
    group_by(k) %>%
    summarize(obrisi = mean(obrisi))
}

obrisi.k = function(k.obrisi) {
  obrisi.povprecje(k.obrisi) %>%
    filter(obrisi == max(obrisi)) %>%
    summarize(k = min(k)) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

r.hc = povpr_poraba_matrika[c(1:9,11:43,45:51),] %>% obrisi(hc = TRUE, od=2, do=20)
r.km = povpr_poraba_matrika[c(1:9,11:43,45:51),]  %>% obrisi(hc = FALSE,od=2, do=20)

diagram.obrisi = function(k.obrisi) {
  ggplot() +
    geom_boxplot(
      data = k.obrisi,
      mapping = aes(x = k, y = obrisi)
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = k, y = obrisi),
      color = "red"
    ) +
    geom_line(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = as.integer(k), y = obrisi),
      color = "red"
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi) %>%
        filter(obrisi == max(obrisi)) %>%
        filter(k == min(k)),
      mapping = aes(x = k, y = obrisi),
      color = "blue"
    ) +
    xlab("število skupin (k)") +
    ylab("obrisi (povprečje obrisov)") +
    ggtitle(paste("Maksimalno povprečje obrisov pri k =", obrisi.k(k.obrisi))) +
    theme_classic()
}
jpeg("slike/hirarhicni_model.jpg")
diagram.obrisi(r.hc)
dev.off()

jpeg("slike/model_k_tih_voditeljev.jpg")
diagram.obrisi(r.km)
dev.off()
# ***************************************************
# Generiranje skupin
# ***************************************************
klas <- kmeans(povpr_poraba_matrika,2)
klasifikacija <- klas$cluster
povpr_poraba_matrika1 <- cbind(povpr_poraba_matrika, klasifikacija)

M=max(max(povpr_poraba_matrika1[,1:198]))
m=min(min(povpr_poraba_matrika1[,1:198]))

Tabela_razred1 <- povpr_poraba_matrika1[povpr_poraba_matrika1[,199] == "1",1:198]
Tabela_razred2 <- povpr_poraba_matrika1[povpr_poraba_matrika1[,199] == "2",1:198]

jpeg("slike/prikaz_povprecne_porabe_za_razlicne_razrede.jpg")
mar.default <- c(5,2,4,2) + 0.1
par(mar = mar.default + c(0, 4, 0, 0),family="serif") #axis(side, at=, labels=, pos=, lty=, col=, las=, tck=, ...)
title="Povprečna poraba za različne razrede porabnikov"
plot(c(0,199), c(0,100),yaxt='n',xaxt='n',main=title, type = "n", pch=19,cex.lab=1.2, cex.axis=1.3, cex.main=1.5,xlab = "Dnevi",ylab = "Povprečna poraba")  # setting up coord. system
xlabels=c(1:19)*10
axis(side=1,at=xlabels,labels=xlabels)
axis(side=2,at=c(0:6)*20,labels=as.factor(c(0:6)*20))
lines(Tabela_razred1, type = "l", col = "black",lwd=2,cex = 1,pch=16)
lines(colSums(Tabela_razred2), type = "l", col = "red",lwd=2,cex = 1,pch=16)
legend("top", legend=(c("Sk1","Sk2")), pch=c(16,16),cex=c(1,1),col=c("black","red"),y.intersp=1.5,horiz=T)
dev.off()


#UPDATED August 5, 2021

number_of_threads <- as.numeric(readLines("THREADS"))

alleles = list()
frequencies = list()

for (j in 1:nloci) {
	locicolumns = grepl(paste(locinames[j],"",sep=""),colnames(data))
	raw_alleles = c(as.matrix(data[,locicolumns]))
	raw_alleles[raw_alleles == "NA"] = NA
	raw_alleles[raw_alleles == 0] = NA
	alleles[[j]] = unique(raw_alleles[!is.na(raw_alleles)])
	frequencies[[j]] = sapply(alleles[[j]], function(x) sum(raw_alleles == x,na.rm=TRUE))
	frequencies[[j]] = frequencies[[j]] / sum(frequencies[[j]])
}

observeddatamatrix = list()
for (j in 1:nloci) {
	locus = locinames[j]
	locicolumns = grepl(paste(locus,"",sep=""),colnames(data))
	oldalleles = as.vector(data[,locicolumns])
	oldalleles [oldalleles == "NA"] = NA
	oldalleles [oldalleles == 0] = NA
	if (length(dim(oldalleles)[2]) == 0) {
		oldalleles = matrix(oldalleles,length(oldalleles),1)
	}
	observeddatamatrix[[j]] = oldalleles
}

m <<- rep(1,nloci)

H_nu = sapply(1:nloci, function (j) -sum(frequencies[[j]] * logb(frequencies[[j]],2)))

sub_per_locus = function(isolate1,isolate2,j) {
		v1 = observeddatamatrix[[j]][isolate1,]
		v1 = v1[!is.na(v1)]
		p1 = frequencies[[j]][match(v1,alleles[[j]])]
		v2 = observeddatamatrix[[j]][isolate2,]
		v2 = v2[!is.na(v2)]
		p2 = frequencies[[j]][match(v2,alleles[[j]])]

		if (ploidy[j] > 1) {
			x = length(unique(v1)) + length(unique(v2))
			n = min(length(unique(v1)),length(unique(v2)))
			w = x * (n > 1) + 4 * (n == 1) * (x == 2) + (1+x) * (n== 1) *  (x > 2)
			jj = 2 * (m[j] == 1) + m[j] * (m[j] > 1)
			y = length(intersect(v1,v2))
			z = 3 * (((2*(n == 1) + 1 * (y == 1) * (x > 2)))==3) + 2 * (y *(n>1)*(jj>=y)+jj*(n > 1)* (y > jj) + jj * (n==1) * (x==2) * (y==1))
			delta_nu_raw = w * (y == 0) + 2 * jj * (y > 0) + sum(sapply(jj:(2*jj), function (ii) -ii*(z == ii)))

			shared_alleles = intersect(v1 , v2)
			if (length(shared_alleles) > 0) {
				temp_shared = sapply(1:nids, function (x) sum(shared_alleles %in% as.matrix(observeddatamatrix[[j]][x,])))
				notmissing = sapply(1:nids, function (x) sum(!is.na(observeddatamatrix[[j]][x,])))

				P_nu = (sum(temp_shared == length(shared_alleles)) / sum(notmissing != 0))^2
			} else {
				P_nu = 1
			}
			k = 1 * (y == 0) + P_nu * (y > 0)
			delta_nu = H_nu[j] * ( delta_nu_raw * (delta_nu_raw > 0) + P_nu * (delta_nu_raw == 0))*k
			delta = delta_nu
		} else {
			delta_ex_raw = 0
			x = length(unique(v1)) + length(unique(v2))
			y = length(intersect(v1,v2))
			delta_ex_raw = 2*x*(y == 0)
			shared_alleles = intersect(v1 , v2)
			if (length(shared_alleles) > 0) {
				temp_shared = sapply(1:nids, function (x) sum(shared_alleles %in% as.matrix(observeddatamatrix[[j]][x,])))
				notmissing = sapply(1:nids, function (x) sum(!is.na(observeddatamatrix[[j]][x,])))
				P_ex = (sum(temp_shared == length(shared_alleles)) / sum(notmissing != 0))^2
			} else {
				P_ex = 1
			}
			k = 1 * (y == 0) + P_ex * (y > 0)
			delta_ex = H_nu[j] * ( delta_ex_raw * (delta_ex_raw > 0) + P_ex * (delta_ex_raw == 0))*k
			delta = delta_ex
		}
		if (sum(!is.na(v1)) == 0 | sum(!is.na(v2)) == 0) { delta = NA }
		delta
}

pairwisedistance_heuristic = function(isolate1,isolate2){
	print(((isolate2-1)*nids+isolate1)/ (nids*nids))
	delta = sapply(1:nloci, function (x) sub_per_locus(isolate1,isolate2,x))
	c(delta,sum(delta))
}

allpossiblepairs = expand.grid(1:nids,1:nids)
allpossiblepairs = unique(allpossiblepairs[allpossiblepairs[,1] <= allpossiblepairs[,2],])
pairwisedistancevector = do.call(cbind,mclapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistance_heuristic(allpossiblepairs[x,1],allpossiblepairs[x,2]),mc.cores=number_of_threads))

pairwisedistancematrix_components = list()
for (j in 1:(nloci+1)) {
	pairwisedistancematrix_temp = matrix(NA,nids,nids)
	sapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistancematrix_temp[allpossiblepairs[x,1],allpossiblepairs[x,2]] <<- pairwisedistancevector[j,x])
	sapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistancematrix_temp[allpossiblepairs[x,2],allpossiblepairs[x,1]] <<- pairwisedistancevector[j,x])
	pairwisedistancematrix_components[[j]] = pairwisedistancematrix_temp
}

#### impute missing values
pairwisedistancematrix_components_imputed = pairwisedistancematrix_components
whichna = which(rowSums(is.na(pairwisedistancematrix_components[[nloci+1]])) == nids)

imputemissing = function(isolate1) {
	missingloci = which(sapply(1:nloci, function (j) sum(!is.na(observeddatamatrix[[j]][isolate1,]))) == 0)
	nonmissingloci = (1:nloci)[-missingloci]
	matchingsamples = which(rowSums(rbind(sapply(nonmissingloci, function (j) sapply(1:nids, function (x) (setequal(observeddatamatrix[[j]][x,],observeddatamatrix[[j]][isolate1,]))))))==length(nonmissingloci))
	matchingsamples = setdiff( matchingsamples , whichna)
	for (j in missingloci ) {
		if (length(matchingsamples) > 0) {
			sapply(1:nids, function (x) pairwisedistancematrix_components_imputed[[j]][isolate1,x] <<- mean(pairwisedistancematrix_components[[j]][x,matchingsamples],na.rm=TRUE))
			sapply(1:nids, function (x) pairwisedistancematrix_components_imputed[[j]][x,isolate1] <<- mean(pairwisedistancematrix_components[[j]][x,matchingsamples],na.rm=TRUE))
			pairwisedistancematrix_components_imputed[[j]][isolate1,isolate1] <<- mean(diag(pairwisedistancematrix_components_imputed[[j]])[matchingsamples],na.rm=TRUE)
		} else {
			pairwisedistancematrix_components_imputed[[j]][isolate1,] <<-mean(pairwisedistancematrix_components[[j]],na.rm=TRUE)
			pairwisedistancematrix_components_imputed[[j]][,isolate1] <<-mean(pairwisedistancematrix_components[[j]],na.rm=TRUE)
			pairwisedistancematrix_components_imputed[[j]][isolate1,isolate1] <<-mean(diag(pairwisedistancematrix_components_imputed[[j]]),na.rm=TRUE)
		}
	}
}
sapply(whichna, imputemissing)

temppairwisedistancematrix = matrix(0,nids,nids)
for (j in 1:(nloci)) {
	temppairwisedistancematrix = temppairwisedistancematrix + pairwisedistancematrix_components_imputed[[j]]
}
whichna2 = which(rowSums(is.na(temppairwisedistancematrix )) != 0)

pairwisedistancematrix_components_imputed_secondpass = pairwisedistancematrix_components_imputed

imputemissing_secondpass = function(isolate1) {
	missingloci = which(sapply(1:nloci, function (j) sum(!is.na(observeddatamatrix[[j]][isolate1,]))) == 0)
	nonmissingloci = (1:nloci)[-missingloci]
	matchingsamples = which(rowSums(rbind(sapply(nonmissingloci, function (j) sapply(1:nids, function (x) (setequal(observeddatamatrix[[j]][x,],observeddatamatrix[[j]][isolate1,]))))))==length(nonmissingloci))
	matchingsamples = setdiff( matchingsamples , whichna)
	for (j in missingloci ) {
		if (length(matchingsamples) > 0) {
			sapply(1:nids, function (x) pairwisedistancematrix_components_imputed_secondpass[[j]][isolate1,x] <<- mean(pairwisedistancematrix_components_imputed[[j]][x,matchingsamples],na.rm=TRUE))
			sapply(1:nids, function (x) pairwisedistancematrix_components_imputed_secondpass[[j]][x,isolate1] <<- mean(pairwisedistancematrix_components_imputed[[j]][x,matchingsamples],na.rm=TRUE))
			pairwisedistancematrix_components_imputed_secondpass[[j]][isolate1,isolate1] <<- mean(diag(pairwisedistancematrix_components_imputed[[j]])[matchingsamples],na.rm=TRUE)
		} else {
			pairwisedistancematrix_components_imputed_secondpass[[j]][isolate1,] <<-mean(pairwisedistancematrix_components_imputed[[j]],na.rm=TRUE)
			pairwisedistancematrix_components_imputed_secondpass[[j]][,isolate1] <<-mean(pairwisedistancematrix_components_imputed[[j]],na.rm=TRUE)
			pairwisedistancematrix_components_imputed_secondpass[[j]][isolate1,isolate1] <<-mean(diag(pairwisedistancematrix_components_imputed[[j]]),na.rm=TRUE)
		}
	}
}

sapply(whichna2, imputemissing_secondpass)

# calculate final
finalpairwisedistancematrix = matrix(0,nids,nids)
for (j in 1:(nloci)) {
	finalpairwisedistancematrix = finalpairwisedistancematrix + pairwisedistancematrix_components_imputed_secondpass[[j]]
}

colnames(pairwisedistancematrix) = ids
rownames(pairwisedistancematrix) = ids

Heuristic_pairwisedistancematrix = finalpairwisedistancematrix


#!/usr/bin/env Rscript

#########################################
# Author: [Ivan Juric](https://github.com/ijuric)
# File: MAPS_regression_and_peak_caller.r
# Source: https://github.com/ijuric/MAPS/blob/master/bin/MAPS/MAPS_regression_and_peak_caller.r
# Source+commit: https://github.com/ijuric/MAPS/blob/e6d5fdee7241b8f9a466cc778be6d0769b984e81/bin/MAPS/MAPS_regression_and_peak_caller.r
# Data: 11/08/2021, commit: e6d5fde
# modified by Jianhong:
# ## 1. set the Rscript environment.
# ## 2. export the COUNT_CUTOFF, RATIO_CUTOFF and FDR parameters
# ## 3. Automatic detect the chromosome names
# ## 4. Handle the error if the input count table is empty
# ## 5. Prefilter the data before fit to vglm to handle the NA error by replace the loglikelihood function.
# ## 6. Handle the error if output is empty
# ## 7. Handle the error if AND or XOR table is empty
# ## 8. clean unused code
# ## 9. fix the indent space
#########################################

## run example:
##  Rscript MAPS_regression_and_peak_caller.r /home/jurici/work/PLACseq/MAPS_pipe/results/mESC_test/ MY_115.5k 5000 1 None pospoisson NA
##
## arguments:
## INFDIR - dir with reg files
## SET - dataset name
## RESOLUTION - resolution (for example 5000 or 10000)
## COUNT_CUTOFF - count cutoff, default 12
## RATIO_CUTOFF - ratio cutoff, default 2.0
## FDR - -log10(fdr) cutoff, default 2
## FILTER - file containing bins that need to be filtered out. Format: two columns "chrom", "bin". "chrom" contains 'chr1','chr2',.. "bin" is bin label
## regresison_type - pospoisson for positive poisson regression, negbinom for negative binomial. default is pospoisson

library(VGAM)
library(MASS)
options(warn=-1)

### constants
chroms = NULL
runs = c(1)
RESOLUTION = NULL

COUNT_CUTOFF = 12
RATIO_CUTOFF = 2.0
GAP = 15000
FDR = 2

REG_TYPE = 'pospoisson'
###

args <- commandArgs(trailingOnly=TRUE)
fltr = data.frame(chr='chrNONE',bin=-1)

if (length(args) < 3 || length(args) > 8) {
    print('Wrong number of arguments. Stopping.')
    print('Arguments needed (in this order): INFDIR, SET, RESOLUTION, COUNT_CUTOFF, RATIO_CUTOFF, FDR, FILTER, regression_type.')
    print('FILTER is optional argument. Omitt it if no filtering required.')
    print(paste('Number of arguments entered:',length(args)))
    print('Arguments entered:')
    print(args)
    quit()
} else {
    print(args)
    INFDIR = args[1]
    SET = args[2]
    RESOLUTION = as.integer(args[3])
    SET <- paste0(SET, ".", ceiling(RESOLUTION/1e3), "k")
    chroms <- dir(INFDIR, "reg_raw.*")
    chroms <- unique(sub("reg_raw\\.(.*?)\\..*$", "\\1", chroms))
    if(length(args)>3){
        COUNT_CUTOFF = as.numeric(args[4])
        RATIO_CUTOFF = as.numeric(args[5])
        FDR = as.numeric(args[6])
        print('filter used (if any):')
        if (length(args) > 6) {
            if (args[7] != 'None') {
                FILTER = args[7]
                fltr = read.table(FILTER,header=T)
                print(fltr)
            } else {
                print('None')
            }
            ## this done so that the script is compatible with previous run_pipeline scripts
            if (length(args) > 7) {
                if (args[8] != 'pospoisson' && args[8] != 'negbinom') {
                    print(paste('wrong regression choice. Your choice:', args[8], '. Avaiable choices: pospoisson or negbinom'),sep = ' ')
                    quit()
                }
                REG_TYPE = args[8]
            }
        } else {
            print('None')
        }
    }
}

## loading data
mm_combined_and = data.frame()
mm_combined_xor = data.frame()
outf_names = c()
for (i in chroms) {
    for (j in c('.and','.xor')) {
        print(paste('loading chromosome ',i,' ',j,sep=''))
        inf_name = paste(INFDIR,'reg_raw.',i,'.',SET,sep='')
        if(file.exists(paste(inf_name,j,sep=''))){
            outf_names = c(outf_names, paste(inf_name,j,'.MAPS2_',REG_TYPE,sep = ''))
            mm = read.table(paste(inf_name,j,sep=''),header=T)
            mm$chr = rep(i, nrow(mm))
            mm = subset( mm, dist > 1) # removing adjacent bins
            mm = subset(mm, !(mm$chr %in% fltr$chr & (mm$bin1_mid %in% fltr$bin | mm$bin2_mid %in% fltr$bin ))) ## filtering out bad bins
            if (j == '.and') {
                mm_combined_and = rbind(mm_combined_and, mm)
            } else if (j == '.xor') {
                mm_combined_xor = rbind(mm_combined_xor, mm)
            }
        }
    }
}

dataset_length_and = length(mm_combined_and$bin1_mid)
dataset_length_xor = length(mm_combined_xor$bin1_mid)
dataset_length = dataset_length_and + dataset_length_xor

## doing statistics and resampling
loglikelihood <- function (mu, y, w, residuals = FALSE, eta, extra = NULL, summation = TRUE) {
    lambda <- eta2theta(eta, "loglink", earg = list(bvalue = NULL, inverse = FALSE, deriv = 0, short = TRUE,
        tag = FALSE))
    if (residuals) {
        stop("loglikelihood residuals not implemented yet")
    }
    else {
        ll.elts <- c(w) * dgaitpois(y, lambda, truncate = 0,
            log = TRUE)
        if (summation) {
            sum(ll.elts[!is.infinite(ll.elts)])
        }
        else {
            ll.elts
        }
    }
}
pospoisson_regression <- function(mm, dataset_length) {
    family <- pospoisson()
    family@loglikelihood <- loglikelihood
    # fit <- vglm(count ~ logl + loggc + logm + logdist + logShortCount, family = pospoisson(), data = mm)
    fit <- vglm(count ~ loggc + logm + logdist + logShortCount, family = family, data = mm)
    mm$expected = fitted(fit)
    mm$p_val = ppois(mm$count, mm$expected, lower.tail = FALSE, log.p = FALSE) / ppois(0, mm$expected, lower.tail = FALSE, log.p = FALSE)
    m1 = mm[ mm$p_val > 1/length(mm$p_val),]
    # fit <- vglm(count ~ logl + loggc + logm + logdist + logShortCount, family = pospoisson(), data = m1)
    fit <- vglm(count ~  loggc + logm + logdist + logShortCount, family = family, data = m1)
    coeff<-round(coef(fit),10)
    # mm$expected2 <- round(exp(coeff[1] + coeff[2]*mm$logl + coeff[3]*mm$loggc + coeff[4]*mm$logm + coeff[5]*mm$logdist + coeff[6]*mm$logShortCount), 10)
    mm$expected2 <- round(exp(coeff[1]  + coeff[2]*mm$loggc + coeff[3]*mm$logm + coeff[4]*mm$logdist + coeff[5]*mm$logShortCount), 10)
    mm$expected2 <- mm$expected2 /(1-exp(-mm$expected2))
    mm$ratio2 <- mm$count / mm$expected2
    mm$p_val_reg2 = ppois(mm$count, mm$expected2, lower.tail = FALSE, log.p = FALSE) / ppois(0, mm$expected2, lower.tail = FALSE, log.p = FALSE)
    mm$p_bonferroni = mm$p_val_reg2 * dataset_length
    mm$fdr <- p.adjust(mm$p_val_reg2, method='fdr')
    return(mm)
}

negbinom_regression <- function(mm, dataset_length) {
    #fit <- glm.nb(count ~ logl + loggc + logm + logdist + logShortCount, data = mm)
    fit <- glm.nb(count ~  loggc + logm + logdist + logShortCount, data = mm)
    mm$expected = fitted(fit)
    sze = fit$theta ##size parameter
    mm$p_val = pnbinom(mm$count, mu = mm$expected, size = sze, lower.tail = FALSE)
    m1 = mm[ mm$p_val > ( 1 / length(mm$p_val)),]
    ## second regression
    # fit <- glm.nb(count ~ logl + loggc + logm + logdist + logShortCount, data = m1)
    fit <- glm.nb(count ~  loggc + logm + logdist + logShortCount, data = m1)
    coeff<-round(fit$coefficients,10)
    sze = fit$theta
    #mm$expected2 <- round(exp(coeff[1] + coeff[2]*mm$logl + coeff[3]*mm$loggc + coeff[4]*mm$logm + coeff[5]*mm$logdist + coeff[6]*mm$logShortCount), 10) ## mu parameter
    mm$expected2 <- round(exp(coeff[1]  + coeff[2]*mm$loggc + coeff[3]*mm$logm + coeff[4]*mm$logdist + coeff[5]*mm$logShortCount), 10) ## mu parameter
    mm$ratio2 <- mm$count / mm$expected2
    mm$p_val_reg2 = pnbinom(mm$count, mu = mm$expected2, size = sze, lower.tail = FALSE)
    mm$p_bonferroni = mm$p_val_reg2 * dataset_length
    mm$fdr <- p.adjust(mm$p_val_reg2, method='fdr')
    return(mm)
}

do_summaries <- function(peaks_and,peaks_xor, peaks, fraction, r) {
    ## no peaks with this fdr
    if (ncol(peaks_and) == 0) {
        peaks_and = data.frame('count' = NA, 'dist'=NA, 'p_val_reg2'=NA, 'fdr'=NA)
    }
    if (ncol(peaks_xor) == 0) {
        peaks_xor = data.frame('count' = NA, 'dist'=NA, 'p_val_reg2'=NA, 'fdr'=NA)
    }
    if (ncol(peaks_and) == 0 & ncol(peaks_xor) == 0) {
        peaks = data.frame('count' = NA, 'dist'=NA, 'p_val_reg2'=NA, 'fdr'=NA)
    }
    summary_one_fdr_val = data.frame('run' = r, 'log10_fdr_cutoff' = fdr_cutoff, 'singleton_fraction' = fraction,
'AND_size'=length(peaks_and$count), 'AND_mean_dist'=mean(peaks_and$dist)*RESOLUTION,'AND_median_dist'=median(peaks_and$dist)*RESOLUTION,
'AND_min_count'=min(peaks_and$count), 'AND_max_pval'=max(peaks_and$p_val_reg2), 'AND_max_fdr'=max(peaks_and$fdr),
'XOR_size'=length(peaks_xor$count), 'XOR_mean_dist'=mean(peaks_xor$dist)*RESOLUTION,'XOR_median_dist'=median(peaks_xor$dist)*RESOLUTION,
'XOR_min_count'=min(peaks_xor$count), 'XOR_max_pval'=max(peaks_xor$p_val_reg2), 'XOR_max_fdr'=max(peaks_xor$fdr),
'size'=length(peaks$count), 'mean_dist'=mean(peaks$dist)*RESOLUTION,'median_dist'=median(peaks$dist)*RESOLUTION,
'min_count'=min(peaks$count), 'max_pval'=max(peaks$p_val_reg2), 'max_fdr'=max(peaks$fdr)
    )
    return(summary_one_fdr_val)
}

label_peaks <- function(df) {
    chroms = unique(df$chr)
    print('chromosomes with potential interactions:')
    print(chroms)
    final = data.frame()
    for (CHR in chroms) {
        y = df[df$chr == CHR,]
        y$p_val_reg2[ y$p_val_reg2 == 0 ] = 1111111
        y$p_val_reg2[ y$p_val_reg2 == 1111111 ] = min(y$p_val_reg2)
        for(i in 1:nrow(y)) {
            z <- y[ abs(y$bin1_mid - y$bin1_mid[i])<=GAP & abs(y$bin2_mid - y$bin2_mid[i])<=GAP,]
            y$CountNei[i] <- nrow(z)
        }
        u <- y[ y$CountNei == 1 ,] # singletons
        v <- y[ y$CountNei >= 2 ,] # peak cluster: sharp peak + broad peak
        out <- NULL
        if(nrow(u)>0) {
            u$label <- 0 # for singletons, assign cluster label 0
            # for singletons, cluster size = 1
            u$NegLog10P <- -log10(u$p_val_reg2 )
            u$ClusterSize <- 1
            out <- rbind(out, u)
        }
        if(nrow(v)>0) {
            v$label <- seq(1,nrow(v),1) # for peak cluster, assign label 1, 2, ..., N
            # for all bin pairs within the neighborhood
            # assign the same cluster label, using the minimal label
            for(i in 1:nrow(v)) {
                w <- v[ abs(v$bin1_mid - v$bin1_mid[i])<=GAP & abs(v$bin2_mid - v$bin2_mid[i])<=GAP ,]
                w.min <- min(w$label)
                w.label <- sort(unique(w$label))
                for(j in 2:length(w.label)) {
                    v$label[ v$label == w.label[j] ] <- w.min
                }
            }
            # step 4: assign consecutive label number
            v.rec <- sort( unique( v$label ) )
            v.rec <- cbind(v.rec, seq(1, length(v.rec), 1))
            for(i in 1:nrow(v)) {
                v$label[i] <- v.rec[ v.rec[,1]==v$label[i] ,2]
            }
            # step 5: calculate cumulative NegLog10P and the cluster size
            v$NegLog10P <- 0
            v$ClusterSize <- 0
            for(i in 1:nrow(v.rec)) {
            # find all bin pairs within the same cluster i
                vtmp <- v[ v$label == i ,]
                v$NegLog10P[ v$label == i ] <- sum( -log10( vtmp$p_val_reg2 ) )
                v$ClusterSize[ v$label == i ] <- nrow(vtmp)
            }
            out <- rbind(out, v)
        }
        final<-rbind(final, out)
    }
    print(dim(final))
    return(final)
}

classify_peaks <- function(final) {

    # only keep unique peak clusters, not bin pairs
    x <- unique( final[ final$label != 0, c('chr', 'label', 'NegLog10P', 'ClusterSize')] )
    if(nrow(x)==0){
        final$ClusterType <- 'Singleton'
        return(final)
    }

    # sort rows by cumulative -log10 P-value
    x <- x[ order(x$NegLog10P) ,]
    y<-sort(x$NegLog10P)
    z<-cbind( seq(1,length(y),1), y )

    # keep a record of z before normalization
    z0 <- z

    z[,1]<-z[,1]/max(z[,1])
    z[,2]<-z[,2]/max(z[,2])

    u<-z
    u[,1] <-  1/sqrt(2)*z[,1] + 1/sqrt(2)*z[,2]
    u[,2] <- -1/sqrt(2)*z[,1] + 1/sqrt(2)*z[,2]

    v<-cbind(u, seq(1,nrow(u),1) )
    RefPoint <- v[ v[,2]==min(v[,2]) , 3] # 1423
    RefValue <- z0[RefPoint,2]

    # define peak cluster type
    final$ClusterType <- '0'
    final$ClusterType[ final$label==0 ] <- 'Singleton'
    final$ClusterType[ final$label>=1 & final$NegLog10P<RefValue  ] <-  'SharpPeak'
    final$ClusterType[ final$label>=1 & final$NegLog10P>=RefValue  ] <- 'BroadPeak'
    #table(final$ClusterType)
    return(final)
}

mx_combined_and = data.frame()
mx_combined_xor = data.frame()
summary_all_runs = data.frame()

singletons_names = paste(chroms,'_0',sep='')
for (r in runs) {
## in case you want to do resampling
## you'd put resampling code here
    name_counter = 1
    for (i in chroms) {
            ## regression
            tryCatch({
                print(paste('run',r,': regression on chromosome',i))
                print(outf_names[name_counter])
                mm = subset(mm_combined_and, chr == i)
                if(nrow(mm)>6){
                    if (REG_TYPE == 'pospoisson') {
                        mm = pospoisson_regression(mm, dataset_length)
                    } else if (REG_TYPE == 'negbinom') {
                        mm = negbinom_regression(mm, dataset_length)
                    }
                    mx_combined_and = rbind(mx_combined_and, mm)
                }
                write.table(mm,outf_names[name_counter],row.names = TRUE,col.names = TRUE,quote=FALSE)
                name_counter = name_counter + 1
                print(outf_names[name_counter])
                mm = subset(mm_combined_xor, chr == i)
                if(nrow(mm)>6){
                    if (REG_TYPE == 'pospoisson') {
                        mm = pospoisson_regression(mm, dataset_length)
                    } else if (REG_TYPE == 'negbinom') {
                        mm = negbinom_regression(mm, dataset_length)
                    }
                    mx_combined_xor = rbind(mx_combined_xor, mm)
                }
                write.table(mm,outf_names[name_counter],row.names = TRUE,col.names = TRUE,quote=FALSE)
            }, error=function(.e){
                message(.e)
            })
            name_counter = name_counter + 1
            ## finding min FDR so I can set appropriate lower boundary for FDR
    }
    ## save QC file
    qc_out = paste(INFDIR,SET,'.maps.qc',sep = '')
    qc_label = c('AND_set','XOR_set')
    qc_val = c(sum(mm_combined_and$count), sum(mm_combined_xor$count))
    qc_name = c('number of sequencing pairs in AND set', 'number of sequencing pairs in XOR set')
    df_qc = data.frame()

    summary_one_run = data.frame()
    singletons = data.frame()
    for (fdr_cutoff in FDR) {
        peaks_and = if(nrow(mx_combined_and)>0) subset(mx_combined_and, count >= COUNT_CUTOFF & ratio2 >= RATIO_CUTOFF & -log10(fdr) > fdr_cutoff) else data.frame()
        peaks_xor = if(nrow(mx_combined_xor)>0) subset(mx_combined_xor, count >= COUNT_CUTOFF & ratio2 >= RATIO_CUTOFF & -log10(fdr) > fdr_cutoff) else data.frame()
        print("finding peaks")
        peaks = rbind(peaks_and, peaks_xor)
        if (dim(peaks)[1] == 0) {
            print(paste('ERROR MAPS_regression_and_peak_caller.r: 0 bin pairs with count >= ',COUNT_CUTOFF,' observed/expected ratio >= ',RATIO_CUTOFF,' and -log10(fdr) > ',fdr_cutoff,sep=''))
            quit()
        }
        peaks = label_peaks(peaks)
        peaks$lab = paste(peaks$chr, peaks$label,sep='_')
        peak_types = classify_peaks(peaks)
        outf_name = paste(INFDIR,SET, '.',fdr_cutoff,'.peaks',sep='')
        write.table(peak_types,outf_name, row.names = FALSE, col.names = TRUE, quote=FALSE)
        print("finding singletons")
        peak_classes = table(peaks$lab)
        n_singletons = sum(peak_classes[names(peak_classes) %in% singletons_names])
        n_singleton_chroms = length(peak_classes[names(peak_classes) %in% singletons_names])

        fraction= n_singletons / (length(peak_classes) + n_singletons - n_singleton_chroms)
        fraction = n_singletons / (length(peak_classes) + n_singletons - n_singleton_chroms)

        singletons_one_run = data.frame('fdr'=fdr_cutoff, 'fraction'=fraction)
        singletons = rbind(singletons, singletons_one_run)
        print(paste(fdr_cutoff,':',singletons))
        summary_one_run = rbind(summary_one_run, do_summaries(peaks_and, peaks_xor, peaks, fraction, r))
    }
    ## find singletons, sharp peaks, broad peaks
    summary_all_runs = rbind(summary_all_runs, summary_one_run)
}
summary_outf_name = paste(INFDIR,'summary.',SET,'.txt',sep='')
write.table(summary_all_runs, summary_outf_name, row.names = FALSE, col.names = TRUE, quote=FALSE)


#!/usr/bin/env Rscript
#
# Use generalized linear mixed models to test for differences in allele
# frequency.
#
# Each read is treated as an observation, and pools are treated as random
# effects. A likelihood ratio test is used to produce a p-value.
#
# Usage:
#
#   snp_by_snp_glmm_test.r <sync file> <file with pool names>
#       <group 1 pools> <group 2 pools>
#
#   The names of the pools in each group should be separated by commas.
#
#==============================================================================#

library(data.table)
library(lme4)

options(warn=1)

#==============================================================================#

## From a sync file row, get read counts.
get_counts = function(sync_row, pools, pool_names) {
    contig = sync_row[[1]]
    pos = sync_row[[2]]
    ref_allele = toupper(sync_row[[3]])
    counts = structure(vector('list', length=length(pools)),
                       names=pools)
    for(pn in pools) {
        x = sync_row[[which(pool_names == pn) + 3]]
        cnts = as.numeric(unlist(strsplit(x, ':')))
        names(cnts) = c('A', 'T', 'C', 'G', 'N', 'D')
        ref_cnt = cnts[ref_allele]
        alt_cnt = (sum(cnts) - cnts['N']) - ref_cnt
        counts[[pn]] = c('ref'=ref_cnt, 'alt'=alt_cnt)
    }
    counts
}

## Test if this set of counts is variable
is_variable = function(counts) {
    ref = sum(sapply(counts, function(x) x[1]))
    alt = sum(sapply(counts, function(x) x[2]))
    return((ref != 0) && (alt != 0))
}

null_result = list('p'=NaN, 'effect'=NaN, term=NA, converged=NA,
                   'wald_p'=NaN, 'freqs0'=NA, 'freqs1'=NA)

## Run a GLMM with pool as a random effect. Use the default
## Wald Z-test and likelihood ratio test to get p-values
test = function(counts, groups) {
    resp = unlist(sapply(counts, function(x) c(rep(0, x[1]), rep(1, x[2]))))
    n_reads = sapply(counts, sum)
    freqs = structure(round(sapply(counts, function(x) x[1] / sum(x)), 4),
                      names=names(counts))
    pools = factor(rep(names(counts), n_reads))
    trt = rep(names(groups),
              sapply(groups, function(x) sum(n_reads[x])))
    freqs0 = paste(freqs[names(freqs) %in% groups[[1]]], collapse=',')
    freqs1 = paste(freqs[names(freqs) %in% groups[[2]]], collapse=',')
    ret = null_result
    if(length(unique(trt)) > 1) {
        ## Random intercept for each pool
        m = glmer(resp ~ trt + (1|pools), family=binomial('logit'))
        mnull = glmer(resp ~ (1|pools), family=binomial('logit'))
        lrt_p = anova(m, mnull)[['Pr(>Chisq)']][2]
        s = summary(m)
        conv = (length(s$optinfo$conv$lme4) == 0) &&
               (length(mnull@optinfo$conv$lme4) == 0)
        p = s$coefficients[2, 4]
        fe = fixef(m)[2]
        ret = list('p'=lrt_p, 'wald_p'=p, 'effect'=fe, 'term'=names(fe),
                   'converged'=as.numeric(conv),
                   'freqs0'=freqs0, 'freqs1'=freqs1)
    }
    ret
}

#==============================================================================#

## Get arguments to the script
cargs = commandArgs(trailingOnly=TRUE)
sync_file_name = cargs[1]
pool_file_name = cargs[2]
group_1 = Filter(function(x) x != '', unlist(strsplit(cargs[3], ',')))
group_2 = Filter(function(x) x != '', unlist(strsplit(cargs[4], ',')))

## Read in data
read_counts = fread(sync_file_name, sep='\t', stringsAsFactors=FALSE)
pool_names = scan(pool_file_name, what='character')

trts = list('group1'=group_1, 'group2'=group_2)

## Test every SNP and print results
cat('contig\tpos\tref\tp\twald_p\teffect\tterm\tconverged\tfreqs0\tfreqs1\n', file=stdout())
for(i in 1:nrow(read_counts)) {
    row_data = read_counts[i]
    contig = row_data[[1]]
    pos = row_data[[2]]
    ref = row_data[[3]]
    counts = get_counts(row_data, unlist(trts), pool_names)
    if(is_variable(counts)) {
        test_results = tryCatch(test(counts, trts),
                                error=function(e) null_result)
    } else {
        test_results = null_result
    }

    cat(paste(contig, pos, ref, test_results$p, test_results$wald_p,
              test_results$effect, test_results$term, test_results$converged,
              test_results$freqs0, test_results$freqs1,
              sep='\t'),
        '\n', sep='', file=stdout())
}