iv.test <- function(model.iv, robust=TRUE, cl=NULL, first = TRUE, orthog=NULL, endog=NULL){
    #if(class(model.iv)!="ivfastplm"){
    #    stop("Must be an ivfastplm object.")
    #}

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

    y <- model.iv$y
    x <- model.iv$x
    z <- model.iv$z

    u.hat <- model.iv$residuals
    iv.matrix <- model.iv$matrix

    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

    # first stage
    if(length(en.var.x)==1){
        multiple.endo <- 0
    }else{
        multiple.endo <- 1
    }
    pos.z.test <- which(colnames(z)%in%exclude.iv)

    # regress all endogenous x on all excluded variables
    inv.z <- iv.matrix$inv.z # inv(z'z)
    inv.xPzx <- iv.matrix$inv.xPzx

    if(is.null(cl)){
        sub.df.residual <- model.iv$df.residual + dim(x)[2] - dim(z)[2]
        sub.df <- model.iv$df.original + dim(x)[2] - dim(z)[2]
        sub.df.cl <- sub.df
    }else{
        sub.df.residual <- model.iv$df.residual
        sub.df <- model.iv$df.original
        sub.df.cl <- model.iv$df.cl + dim(x)[2] - dim(z)[2]
    }

    first.stage <- list()
    if(length(en.var.x)>0 && first==TRUE){ #first stage information

        en.var.x.matrix <- matrix(dx[,en.var.x],ncol=length(en.var.x))
        #en.var.x.coef <- inv.z%*%t(dz)%*%en.var.x.matrix
        #colnames(en.var.x.coef) <- en.var.x
        #en.var.x.hat <- dz%*%en.var.x.coef
        #colnames(en.var.x.hat) <- 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

        # F test
        for(i in 1:length(en.var.x)){
            target.en.var <- en.var.x[i]
            other.en.var <- en.var.x[-i]

            sub.dx <- matrix(dx[,target.en.var],ncol=1)
            sub.coef <- matrix(en.var.x.coef[,target.en.var],ncol=1)
            rownames(sub.coef) <- colnames(z)
            sub.res <- matrix(sub.dx-en.var.x.hat[,target.en.var],ncol=1)

            sub.df.cl <- sub.df
            sub.sigma2 <- t(sub.res)%*%sub.res/(sub.df)
            sub.RMSE <- sqrt(sub.sigma2)
            if(is.null(cl)){
                if (robust == FALSE) {
                    sub.vcov <- as.matrix(c(t(sub.res)%*%sub.res/sub.df)*inv.z)
                } else{
                    meat <- dz * matrix(rep(c(sub.res), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                    meat <- t(meat) %*% meat
                    vcov <- inv.z%*%meat%*%inv.z
                    sub.vcov <- dim(dz)[1]/sub.df*vcov
                }
            }
            else{
                cl <- model.iv$cl
                sub.df.cl <- model.iv$df.cl + dim(x)[2] - dim(z)[2]
                if (dim(cl)[2] == 1) {
                    stderror <- cluster.se(cl = cl, x = z, res = sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl)
                    sub.vcov <- stderror$vcov.cl
                }
                if (dim(cl)[2] == 2) {
                    stderror1 <- cluster.se(cl = as.matrix(cl[,1]), x = z, res = sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl[1])
                    vcov1 <- stderror1$vcov.cl

                    stderror2 <- cluster.se(cl = as.matrix(cl[,2]), x = z, res = sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl[2])
                    vcov2 <- stderror2$vcov.cl

                    cl_inter <- as.numeric(as.factor(paste(cl[,1], "-:-", cl[,2], sep = "")))

                    #if cl_inter is unique; then stderror3 is robust standard error
                    cl_inter.count <- table(cl_inter)
                    if(max(cl_inter.count)==1){
                        meat3 <- dz * matrix(rep(c(sub.res), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                        meat3 <- as.matrix(t(meat3) %*% meat3)
                        vcov3 <- inv.z %*% meat3 %*% inv.z
                        vcov3 <- dim(dz)[1]/sub.df*vcov3
                    }else{
                        stderror3 <- cluster.se(cl = as.matrix(cl_inter), x = z, res = sub.res, dx =dz,
                                                sfe.index = NULL,
                                                cfe.index = NULL,
                                                ind = NULL, df = NULL, invx = inv.z,
                                                df.cl = sub.df.cl[3])
                        vcov3 <- stderror3$vcov.cl
                    }
                    sub.vcov <- vcov1+vcov2-vcov3
                }
            }

            colnames(sub.vcov) <- rownames(sub.vcov) <- colnames(z)
            sub.use.coef <- matrix(sub.coef[exclude.iv,],ncol=1)
            sub.use.vcov <- as.matrix(sub.vcov[exclude.iv,exclude.iv])
            partial.F <- t(sub.use.coef)%*%solve(sub.use.vcov)%*%sub.use.coef/length(exclude.iv)

            partial.F.statistic <- cbind(partial.F, length(exclude.iv), sub.df.residual, 1 - pf(partial.F, length(exclude.iv), sub.df.residual))
            colnames(partial.F.statistic) <- c("partial F statistics", "df1", "df2", "P value")
            sub.model <- list(coefficients=sub.coef,vcov=sub.vcov,df.original=sub.df,df.cl=sub.df.cl,df.residual=sub.df.residual,
                            partial.F=partial.F.statistic,RMSE=sub.RMSE)

            if(multiple.endo==0){
                AP.F.statistic <- SW.F.statistic <- partial.F.statistic
                sub.model$AP.F.statistic <- AP.F.statistic
                sub.model$SW.F.statistic <- SW.F.statistic
            }

            if(multiple.endo==1){
                #AP F.statistics
                target.dx.hat <- matrix(en.var.x.hat[,target.en.var],ncol=1)
                target.dx <- matrix(dx[,target.en.var],ncol=1)

                if(!is.null(include.iv)){
                    other.dx.hat <- cbind(matrix(en.var.x.hat[,other.en.var],ncol=length(other.en.var)),
                                          matrix(dx[,include.iv],ncol=length(include.iv)))

                    other.dx <- cbind(matrix(dx[,other.en.var],ncol=length(other.en.var)),
                                      matrix(dx[,include.iv],ncol=length(include.iv)))
                }else{
                    other.dx.hat <- matrix(en.var.x.hat[,other.en.var],ncol=length(other.en.var))
                    other.dx <- matrix(dx[,other.en.var],ncol=length(other.en.var))
                }

                #inv.other.dx.hat <- solve(t(other.dx.hat)%*%other.dx.hat)
                #other.coef.hat <- matrix(inv.other.dx.hat%*%t(other.dx.hat)%*%target.dx,ncol=1)
                #e1 <- target.dx - other.dx.hat%*%other.coef.hat

                sub.lm.APSW <- simpleols(Y=target.dx,X=other.dx.hat)
                other.coef.hat <- sub.lm.APSW[['coef']]
                e1 <- sub.lm.APSW[['u_hat']]

                #second stage
                AP.sub.coef <- matrix(inv.z%*%t(dz)%*%e1,ncol=1)
                rownames(AP.sub.coef) <- colnames(z)
                AP.sub.res <- matrix(e1-dz%*%AP.sub.coef,ncol=1)
                AP.sub.sigma2 <- t(AP.sub.res)%*%AP.sub.res/(sub.df)
                AP.sub.RMSE <- sqrt(AP.sub.sigma2)
                if(is.null(cl)){
                    if (robust == FALSE) {
                        AP.sub.vcov <- as.matrix(c(t(AP.sub.res)%*%AP.sub.res/sub.df)*inv.z)
                    } else{
                        AP.meat <- dz * matrix(rep(c(AP.sub.res), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                        AP.meat <- t(AP.meat) %*% AP.meat
                        AP.vcov <- inv.z%*%AP.meat%*%inv.z
                        AP.sub.vcov <- dim(dz)[1]/sub.df*AP.vcov
                    }
                }
                else{
                    if (dim(cl)[2] == 1) {
                        stderror <- cluster.se(cl = cl, x = z, res = AP.sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl)
                        AP.sub.vcov <- stderror$vcov.cl
                    }
                    if (dim(cl)[2] == 2) {
                        stderror1 <- cluster.se(cl = as.matrix(cl[,1]), x = z, res = AP.sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl[1])
                        AP.vcov1 <- stderror1$vcov.cl

                        stderror2 <- cluster.se(cl = as.matrix(cl[,2]), x = z, res = AP.sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl[2])
                        AP.vcov2 <- stderror2$vcov.cl

                        if(max(cl_inter.count)==1){
                            meat3 <- dz * matrix(rep(c(AP.sub.res), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                            meat3 <- as.matrix(t(meat3) %*% meat3)
                            AP.vcov3 <- inv.z %*% meat3 %*% inv.z
                            AP.vcov3 <- dim(dz)[1]/sub.df*vcov3
                        }else{
                            stderror3 <- cluster.se(cl = as.matrix(cl_inter), x = z, res = AP.sub.res, dx =dz,
                                                sfe.index = NULL,
                                                cfe.index = NULL,
                                                ind = NULL, df = NULL, invx = inv.z,
                                                df.cl = sub.df.cl[3])
                            AP.vcov3 <- stderror3$vcov.cl
                        }
                        AP.sub.vcov <- AP.vcov1+AP.vcov2-AP.vcov3
                    }
                }

                colnames(AP.sub.vcov) <- rownames(AP.sub.vcov) <- colnames(z)
                AP.sub.use.coef <- matrix(AP.sub.coef[exclude.iv,],ncol=1)
                AP.sub.use.vcov <- as.matrix(AP.sub.vcov[exclude.iv,exclude.iv])
                Fdf1 <- (length(exclude.iv)-length(en.var.x)+1)
                AP.partial.F <- t(AP.sub.use.coef)%*%solve(AP.sub.use.vcov)%*%AP.sub.use.coef/Fdf1
                AP.partial.F.statistic <- cbind(AP.partial.F, Fdf1, sub.df.residual, 1 - pf(AP.partial.F, Fdf1, sub.df.residual))
                colnames(AP.partial.F.statistic) <- c("Angrist-Pischke F Value", "df1", "df2", "P value")
                sub.model$AP.F.statistic <- AP.partial.F.statistic

                #second stage
                e2 <- target.dx - other.dx%*%other.coef.hat
                SW.sub.coef <- matrix(inv.z%*%t(dz)%*%e2,ncol=1)
                rownames(SW.sub.coef) <- colnames(z)
                SW.sub.res <- matrix(e2-dz%*%SW.sub.coef,ncol=1)
                SW.sub.sigma2 <- t(SW.sub.res)%*%SW.sub.res/(sub.df)
                SW.sub.RMSE <- sqrt(SW.sub.sigma2)
                if(is.null(cl)){
                    if (robust == FALSE) {
                        SW.sub.vcov <- as.matrix(c(t(SW.sub.res)%*%SW.sub.res/sub.df)*inv.z)
                    } else{
                        SW.meat <- dz * matrix(rep(c(SW.sub.res), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                        SW.meat <- t(SW.meat) %*% SW.meat
                        SW.vcov <- inv.z%*%SW.meat%*%inv.z
                        SW.sub.vcov <- dim(dz)[1]/sub.df*SW.vcov
                    }
                }
                else{
                    if (dim(cl)[2] == 1) {
                        stderror <- cluster.se(cl = cl, x = z, res = SW.sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl)
                        SW.sub.vcov <- stderror$vcov.cl
                    }
                    if (dim(cl)[2] == 2) {
                        stderror1 <- cluster.se(cl = as.matrix(cl[,1]), x = z, res = SW.sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl[1])
                        SW.vcov1 <- stderror1$vcov.cl

                        stderror2 <- cluster.se(cl = as.matrix(cl[,2]), x = z, res = SW.sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl[2])
                        SW.vcov2 <- stderror2$vcov.cl

                        if(max(cl_inter.count)==1){
                            meat3 <- dz * matrix(rep(c(SW.sub.res), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                            meat3 <- as.matrix(t(meat3) %*% meat3)
                            SW.vcov3 <- inv.z %*% meat3 %*% inv.z
                            SW.vcov3 <- dim(dz)[1]/sub.df*vcov3
                        }else{
                            stderror3 <- cluster.se(cl = as.matrix(cl_inter), x = z, res = SW.sub.res, dx =dz,
                                                sfe.index = NULL,
                                                cfe.index = NULL,
                                                ind = NULL, df = NULL, invx = inv.z,
                                                df.cl = sub.df.cl[3])
                            SW.vcov3 <- stderror3$vcov.cl
                        }
                        SW.sub.vcov <- SW.vcov1+SW.vcov2-SW.vcov3
                    }
                }

                colnames(SW.sub.vcov) <- rownames(SW.sub.vcov) <- colnames(z)
                SW.sub.use.coef <- matrix(SW.sub.coef[exclude.iv,],ncol=1)
                SW.sub.use.vcov <- as.matrix(SW.sub.vcov[exclude.iv,exclude.iv])

                SW.partial.F <- t(SW.sub.use.coef)%*%solve(SW.sub.use.vcov)%*%SW.sub.use.coef/Fdf1
                SW.partial.F.statistic <- cbind(SW.partial.F, Fdf1, sub.df.residual, 1 - pf(SW.partial.F, Fdf1, sub.df.residual))
                colnames(SW.partial.F.statistic) <- c("Sanderson-Windmeijer F Value", "df1", "df2", "P value")
                sub.model$SW.F.statistic <- SW.partial.F.statistic
            }
            first.stage[[en.var.x[i]]] <- sub.model
        }
    }

    #Anderson-Rubin Wald test
    if(length(en.var.x)>0){
        dy <- model.iv$demeaned$dy
        AR.sub.coef <- matrix(inv.z%*%t(dz)%*%dy,ncol=1)
        rownames(AR.sub.coef) <- colnames(z)
        AR.sub.res <- matrix(dy-dz%*%AR.sub.coef,ncol=1)
        AR.sub.sigma2 <- t(AR.sub.res)%*%AR.sub.res/(sub.df)
        AR.sub.RMSE <- sqrt(AR.sub.sigma2)
        if(is.null(cl)){
            if (robust == FALSE) {
                AR.sub.vcov <- as.matrix(c(t(AR.sub.res)%*%AR.sub.res/sub.df)*inv.z)
            } else{
                    AR.meat <- dz * matrix(rep(c(AR.sub.res), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                    AR.meat <- t(AR.meat) %*% AR.meat
                    AR.vcov <- inv.z%*%AR.meat%*%inv.z
                    AR.sub.vcov <- dim(dz)[1]/sub.df*AR.vcov
                }
        }
        else{
            if (dim(cl)[2] == 1) {
                stderror <- cluster.se(cl = cl, x = z, res = AR.sub.res, dx =dz,
                                    sfe.index = NULL,
                                    cfe.index = NULL,
                                    ind = NULL, df = NULL, invx = inv.z,
                                    df.cl = sub.df.cl)
                 AR.sub.vcov <- stderror$vcov.cl
            }
            if (dim(cl)[2] == 2) {
                stderror1 <- cluster.se(cl = as.matrix(cl[,1]), x = z, res = AR.sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl[1])
                AR.vcov1 <- stderror1$vcov.cl

                stderror2 <- cluster.se(cl = as.matrix(cl[,2]), x = z, res = AR.sub.res, dx =dz,
                                        sfe.index = NULL,
                                        cfe.index = NULL,
                                        ind = NULL, df = NULL, invx = inv.z,
                                        df.cl = sub.df.cl[2])
                AR.vcov2 <- stderror2$vcov.cl

                cl_inter <- as.numeric(as.factor(paste(cl[,1], "-:-", cl[,2], sep = "")))

                #if cl_inter is unique; then stderror3 is robust standard error
                cl_inter.count <- table(cl_inter)

                if(max(cl_inter.count)==1){
                            meat3 <- dz * matrix(rep(c(AR.sub.res), dim(dz)[2]), dim(dz)[1], dim(dz)[2])
                            meat3 <- as.matrix(t(meat3) %*% meat3)
                            AR.vcov3 <- inv.z %*% meat3 %*% inv.z
                            AR.vcov3 <- dim(dz)[1]/sub.df*AR.vcov3
                }else{
                            stderror3 <- cluster.se(cl = as.matrix(cl_inter), x = z, res = AR.sub.res, dx =dz,
                                                sfe.index = NULL,
                                                cfe.index = NULL,
                                                ind = NULL, df = NULL, invx = inv.z,
                                                df.cl = sub.df.cl[3])
                            AR.vcov3 <- stderror3$vcov.cl
                }
                AR.sub.vcov <- AR.vcov1+AR.vcov2-AR.vcov3
            }
        }
        colnames(AR.sub.vcov) <- rownames(AR.sub.vcov) <- colnames(z)
        AR.sub.use.coef <- matrix(AR.sub.coef[exclude.iv,],ncol=1)
        AR.sub.use.vcov <- as.matrix(AR.sub.vcov[exclude.iv,exclude.iv])
        AR.partial.F <- t(AR.sub.use.coef)%*%solve(AR.sub.use.vcov)%*%AR.sub.use.coef/(length(exclude.iv))
        AR.partial.F.statistic <- cbind(AR.partial.F, length(exclude.iv), sub.df.residual, 1 - pf(AR.partial.F, length(exclude.iv), sub.df.residual))
        colnames(AR.partial.F.statistic) <- c("Anderson-Rubin F Value", "df1", "df2", "P value")
        first.stage$AR.F.value <- AR.partial.F.statistic
    }

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

    if(is.null(cl)){
        df.cl <- df.residual <- model.iv$df.residual
    }else{
        df.cl <- model.iv$df.cl
        df.residual <- model.iv$df.residual
    }
    u.hat <- model.iv$residuals

    over.identify <- try(get.over.identify(dy=dy,
                                           dx=dx,
                                           dz=dz,
                                           cl=cl,
                                           robust = robust,
                                           df.cl=df.cl,
                                           u.hat=u.hat,
                                           inv.z=inv.z,
                                           en.var.x=en.var.x,
                                           exclude.iv=exclude.iv,
                                           orthog=orthog),silent=TRUE)
    if('try-error' %in% class(over.identify)) {
        over.identify <- NULL
        warning("Collinearity/identification problems in overidentification test.\n")
    }

    #endogenous
    #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
    endogenous.out <- list()

    if(length(en.var.x)>0){
        if(is.null(endog)){ #test all instrumented covariate
            endog <- en.var.x
        }else{
            #endog must belong to en.var.x
            for(var in endog){
                if(!var%in%en.var.x){
                    stop(paste0(var," must belong to all endogenous variables."))
                }
            }
        }

        #put endogenous variables in z
        dx.endog <- dx
        dy.endog <- dy
        dz.endog <- as.matrix(cbind(dz,matrix(dx[,endog],ncol=length(endog))))
        colnames(dz.endog) <- c(colnames(dz),endog)

        iv.solve.endog <- solveiv(Y=dy.endog,X=dx.endog,Z=dz.endog)
        u.hat.endog <- iv.solve.endog[["residual"]]
        inv.z.endog <- iv.solve.endog[["invzz"]]

        orthog.endog <- endog
        en.var.x.endog <- en.var.x[which(!en.var.x%in%endog)]
        exclude.iv.endog <- c(exclude.iv,en.var.x[which(en.var.x%in%endog)])

        endog.out <- try(get.over.identify(dy=dy.endog,
                                    dx=dx.endog,
                                    dz=dz.endog,
                                    cl=cl,
                                    robust = robust,
                                    df.cl=df.cl,
                                    u.hat=u.hat.endog,
                                    inv.z=inv.z.endog,
                                    en.var.x=en.var.x.endog,
                                    exclude.iv=exclude.iv.endog,
                                    orthog=orthog.endog),silent=TRUE)

        if('try-error' %in% class(endog.out)) {
            endog.out <- NULL
            endogenous <- NULL
            warning("Collinearity/identification problems in endogenous test.\n")
        }else{
            endogenous <- endog.out$C.statistic
            names(endogenous) <- c("DWH Value","df","P Value")
            endogenous.out[['DWH']] <- endogenous
        }
    }

    output <- list(first.stage=first.stage,over.identify=over.identify,endogenous=endogenous.out)
    return(output)
}


library(limma)

# Configurations
setwd("~/Projects/crispy/")

# Import samplesheet
samplesheet = read.csv(gzfile("crispy/data/crispr_manifests/HT29_Dabraf_samplesheet.csv.gz", "rt"), stringsAsFactors = F, check.names = F, row.names = 7)
samplesheet$id = paste(samplesheet$medium, samplesheet$time, sep="_")

# Import data
for (metric in c("All", "Minimal")) {
  message(c("Metric: ", metric))

  data <- read.csv(
    gzfile(
      paste(
        "notebooks/minlib/reports/HT29_Dabraf_gene_fc_", metric, ".csv.gz", sep=""),
      "rt"
    ),
    row.names = 1,
    check.names = F,
    stringsAsFactors = F
  )
  colnames(data) <- samplesheet[colnames(data), 'id']

  # Design matrix
  l <- c(
    "Initial_D8",
    "Dabraf_D10", "Dabraf_D14", "Dabraf_D18", "Dabraf_D21",
    "DMSO_D10", "DMSO_D14", "DMSO_D18", "DMSO_D21"
  )
  f <- factor(colnames(data), levels = l)
  design <- model.matrix(~0 + f)
  colnames(design) <- l

  # Linear fit: design matrix
  fit <- lmFit(data, design)

  # Contrast matrix
  contrasts.m <- makeContrasts(
    Dif10d=Dabraf_D10 - DMSO_D10,
    Dif14d=Dabraf_D14 - DMSO_D14,
    Dif18d=Dabraf_D18 - DMSO_D18,
    Dif21d=Dabraf_D21 - DMSO_D21,
    levels=design)

  # Linear fit: contrast matrix
  fit2 <- contrasts.fit(fit, contrasts.m)

  # Bayesian shrinkage
  fit2 <- eBayes(fit2)

  # Export results
  res <- topTableF(fit2, adjust="fdr", number=Inf)
  write.csv(res, paste("notebooks/minlib/reports/HT29_Dabraf_limma_", metric, ".csv", sep=""), quote = F)
}


#!/usr/bin/Rscript

med <- function(pointsFile, labelsFile) {
	points <- read.table(pointsFile, header=T);
	labels <- scan(labelsFile);

	pointsAmount = nrow(points)
	labelsAmount = length(unique(labels))

	if (pointsAmount != length(labels)) {
		cat("Lengths not match ", pointsAmount, " != ", length(labels), "\n");
		return ("not ok")
	}

	points <- as.data.frame(points);
	points$label <- labels;

	xVec <- points[,1];
	yVec <- points[,2];
	cl <- rainbow(labelsAmount);
	plot(0, 0, xlim=range(xVec), ylim=range(yVec), type="n")
	points(xVec, yVec, col=cl[points$label], pch=(points$label + 3) %% 26)

	return ("ok")
}

args <- commandArgs(trailingOnly=TRUE);

if (length(args) == 2) {
	X11();
	med(args[1], args[2]);
	message("Press Return To Continue")
	invisible(readLines("stdin", n=1))
} else {
	print("Give me two files with data and labels dude!");
}


# pull out the necessary internal functions from greta
op <- .internals$nodes$constructors$op

#' @import greta
#'
#' @title Convert a \code{greta_mcmc_list} to a \code{DHARMa} obect
#'
#'
#' @description Create a \code{DHARMa} object from a fitted greta model.
#'
#' @param object A greta_mcmc_list object obtained from the greta::mcmc function
#' @param y A greta array of the response variable, see example
#' @param linpred A greta array of the expected value of y (typically the linear predictor in GLMM)
#' @param nsim A numeric, the number of posterior simulation to draw, default is 10
#' @param integerResponse A logical, whether the response variable is of integer type (binomial or poisson distribution).
#' If TRUE, noise will be added to the residuals to maintain uniform expectations. Default is FALSE.
#'
#'
#' @return A DHARMa object that allows plenty of model checks methods from the \pkg{DHARMa} package.
#'
#' @details For hierarchical models the linear predictor can be set conditional to the random terms, or unconditional to them. Best practice seems to be to define the linear predictor (the predictions) unconditional from the random effects (see \href{https://github.com/florianhartig/DHARMa/issues/43}{DHARMa issues 43}).
#' DHARMa objects come with many methods to check (among other): model miss-fit, overdispersion, spatial or temporal autocorrelation ... Check the \code{DHARMa} manual for examples and options.
#'
#' @examples
#' \dontrun{
#'
#' x <- runif(100, -2, 2)
#' y <- rnorm(100, 1 + 2 * x, 1)
#' y <- as_data(y)
#'
#' intercept <- normal(0, 1)
#' slope <- normal(0, 1)
#' linpred <- intercept + slope * x
#' sd_res <- cauchy(0, 1, truncation = c(0, 50))
#'
#' distribution(y) <- normal(linpred, sd_res)

#' m <- model(intercept, slope, sd_res)
#' d <- mcmc(m)
#'
#' sims <- simulate_residual(d, y, linpred)
#' plot(sims)
#' }
#'
#' @importFrom DHARMa createDHARMa
#' @export

simulate_residual <- function(object, y, linpred, nsim = 10,
                               integerResponse = FALSE){
  # draw new response variable
  yrep <- calculate(y, values = object, nsim = nsim)[[1]][,,1]

  # fitted response
  mu <- calculate(linpred, values = object, nsim = nsim)[[1]][,,1]

  # create a DHARMa object
  dh <- createDHARMa(simulatedResponse = t(yrep),
                     observedResponse = as.numeric(y),
                     integerResponse = integerResponse,
                     fittedPredictedResponse = apply(mu, 2, median))

  return(dh)
}


as.roman(1666) + 334   # MM


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))

data_file <- file.path("results", "compression_simulation_results.tsv")
data_df <- readr::read_tsv(data_file, col_types = readr::cols()) %>%
    reshape2::melt(id.vars = c("k", "algorithm", "compressed_feature"),
                   variable.name = "feature",
                   value.name = "feature_importance") %>%
    dplyr::mutate(abs_feature_importance = abs(feature_importance)) %>%
    dplyr::filter(feature %in% c("feature_1", "feature_2", "feature_3",
                                 "feature_5", "feature_6", "feature_7")) %>%
    dplyr::group_by(k, algorithm, feature) %>%
    dplyr::top_n(n = 1, wt = abs_feature_importance) %>%
    tidyr::separate(compressed_feature, into = c("alg", "feature_num"), sep = "_", remove = FALSE)

data_df <- data_df %>%
    dplyr::mutate(feature_num_recode = paste(as.numeric(paste(feature_num)) + 1))

data_df$feature_num <- factor(paste(data_df$feature_num),
                              levels = c("0", "1", "2", "3", "4", "5"))

data_df$algorithm <- factor(data_df$algorithm, levels = c("PCA", "ICA", "NMF", "DAE", "VAE"))

data_df$feature_block <- dplyr::recode(
    data_df$feature,
    feature_1 = "feature_block_1",
    feature_2 = "feature_block_1",
    feature_3 = "feature_block_1",
    feature_5 = "feature_block_2",
    feature_6 = "feature_block_2",
    feature_7 = "feature_block_2",
)

print(dim(data_df))
head(data_df, 10)

feature_colors = c(
    "feature_1" = "#9B4A34",
    "feature_2" = "#D59673",
    "feature_3" = "#DC9C2A",
    "feature_5" = "#291F46",
    "feature_6" = "#373443",
    "feature_7" = "#4D5575"
)

feature_labels = c(
    "feature_1" = "1",
    "feature_2" = "2",
    "feature_3" = "3",
    "feature_5" = "5",
    "feature_6" = "6",
    "feature_7" = "7"
)

feature_block_colors = c(
    "feature_block_1" = "#C77A39",
    "feature_block_2" = "#2A2930"
)

feature_block_labels = c(
    "feature_block_1" = "Block 1",
    "feature_block_2" = "Block 2"
)

simulation_theme <- theme_bw() +
  theme(axis.text = element_text(size = 5.5),
        axis.title = element_text(size = 6.5),
        legend.text = element_text(size = 7),
        legend.title = element_text(size = 7.5),
        legend.key.size = unit(1, "lines"),
        strip.background = element_rect(colour = "black",
                                        fill = "#fdfff4"),
        strip.text.x = element_text(size = 5,
                                    margin = margin(t = 2,
                                                    b = 1.5,
                                                    l = 0,
                                                    r = 0)))

append_k <- function(string) paste0("k=", string)

plot_gg <- ggplot(data_df,
       aes(x = feature_num_recode, y = feature_importance)) +
    geom_bar(stat="identity", aes(fill=feature), position = position_dodge()) +
    facet_wrap(k~algorithm,
               scales = "free",
               ncol = 5,
               labeller = labeller(k = as_labeller(append_k))) +
    scale_fill_manual(values = feature_colors, labels = feature_labels, name = "Feature") +
    xlab("Compressed Feature Number (Top Scoring Feature)") +
    ylab("Feature Importance (Weight)") +
    simulation_theme

plot_gg

for(extension in c('.png', '.pdf')) {
    fig_file <- paste0("simulated_feature_number", extension)
    fig_file <- file.path("figures", fig_file)
    ggsave(filename = fig_file,
           plot = plot_gg,
           height = 150,
           width = 125,
           units = "mm",
           dpi = 400)
}

data_count_df <- data_df %>%
    dplyr::filter(k == 6) %>%
    dplyr::group_by(algorithm, feature_block, feature_num_recode) %>%
    dplyr::count() %>%
    tidyr::drop_na()

data_count_df

plot_count_gg <- ggplot(data_count_df,
       aes(x = feature_num_recode, y = n, fill = feature_block)) +
    geom_bar(stat="identity", position = position_dodge()) +
    facet_wrap(~algorithm,
               scales = "fixed",
               ncol = 5) +
    scale_fill_manual(values = feature_block_colors, labels = feature_block_labels, name = "") +
    xlab("Compressed Feature Number (Top Scoring Feature)") +
    ylab("Feature Count") +
    simulation_theme

plot_count_gg

for(extension in c('.png', '.pdf')) {
    fig_file <- paste0("simulated_feature_number_feature_block_summary", extension)
    fig_file <- file.path("figures", fig_file)
    ggsave(filename = fig_file,
           plot = plot_count_gg,
           height = 50,
           width = 125,
           units = "mm",
           dpi = 400)
}


#' @importFrom raster cellStats
#' @export
ave_prop_rem <-
  function(x, y, p) {
    ans <- cellStats(x * (y > p), sum) / cellStats(x, sum)
    sum(ans, na.rm = TRUE) / nlayers(x)
  }


#  James Rekow

subgroupVecDifferences = function(subgroupVec1, subgroupVec2){

  #  ARGS: subgroupVec1 - a partition of a numeric vector of the form 1:n
  #        subgroupVec2 - another partition of the same numeric vector
  #
  #  RETURNS: numDiffs - number of elements in subgroupVec2 that are placed in a different subgroup
  #                      than in partition1

  #  identify the number of elements in the set being partitioned
  numElements = length(subgroupVec1)

  #  identify the set which the partitions divide
  baseSet = 1:numElements

  computeSubgroupIxVec = function(inputPartition){

    #  ARGS: inputPartition - partition
    #
    #  RETURNS: subgroupIxVec - numeric vector whose ith element is the index of the subgroup to which
    #                           the ith element of the base set belongs to in the input partition

    #  identify number of subgroups in input partition
    numSubgroups = length(inputPartition)

    # intializeVector
    subgroupIxVec = baseSet

    for(ii in 1:numSubgroups){

      #  identify elements of baseSet in subgroup ii
      subgroupElements = inputPartition[[ii]]

      #
      subgroupIxVec[subgroupElements] = ii

    } #  end for

    return(subgroupIxVec)

  } #  end computesubgroupIxVec

  #  compute subgroup ix vector for each partition
  subgroupIxVec1 = computeSubgroupIxVec(partition1)
  subgroupIxVec2 = computeSubgroupIxVec(partition2)

  #  count the number of elements that are in different subgroups in the two partitions
  numDiffs = sum(subgroupIxVec1 != subgroupIxVec2)

  return(numDiffs)

} #  end subgroupVecDifferences function


#create map of Other Agriculture Captial
#currently this is based solely on slope (script converts to values needed)

rm(list=ls())
library(raster)

#note decliv_class.asc in zip file is 1.8GB!
#read munis.r as latlong
#unzip(zipfile="Data/sim10_BRmunis_latlon_5kmzip",exdir="Data")  #unzip
munis.r <- raster("Data/sim10_BRmunis_latlon_5km.asc")
latlong <- "+proj=longlat +ellps=WGS84 +towgs84=0,0,0,0,0,0,0 +no_defs "
crs(munis.r) <- latlong

#note decliv_class.asc in zip file is 1.8GB!
unzip(zipfile="Data/decliv_class.zip",exdir="Data")  #unzip
vslope<-raster("Data/decliv_class.asc")

vslope.m<- resample(vslope, munis.r, method='ngb')  #JM edited munis.r
vslope.m<- mask(x=vslope.m, mask=munis.r)  #JM edited munis.r

#	0 (1) becomes 0.2 – (0 – 3% No limitation)
#	1 (2) becomes 0.4 – (3 – 8% Slight limitation )
#	2 (3) becomes 0.6 – (8 – 13% Moderate limitation)
#	3 (4) becomes 0.8 – (13 – 20% Strong limitation)
#	4* (5) becomes 1.0 – (20 – 45 % Very strong limitation)
#	4* (6) becomes 0 –(>45% Unsuitable)

a <- c(1,0.2)
a <- rbind(a,(c(2,0.4)))
a <- rbind(a,(c(3,0.6)))
a <- rbind(a,(c(4,0.8)))
a <- rbind(a,(c(5,1.0)))
a <- rbind(a,(c(6,0)))

OAslope.m <- reclassify(vslope.m, a)

summary(OAslope.m)

writeRaster(OAslope.m, "Data/OAgri-slope_2018-08-16", "ascii", "overwrite"=T)

unlink("Data/decliv_class.asc")  #large file so delete!
#unlink("Data/sim10_BRmunis_latlon_5km.asc")


days <- read.table('ttl.csv', header=FALSE, sep=',')
d_sncf <- days[which(days$V1=='Disponible' & days$V2 == 'sncf'), ]
d_ratp <- days[which(days$V1=='Disponible' & days$V2 == 'ratp'), ]
hs_ratp <- days[which(days$V1=='Hors service' & days$V2 == 'ratp'), ]
hs_sncf <- days[which(days$V1=='Hors service' & days$V2 == 'sncf'), ]
d1 <- density(d_ratp$V3/24.0, from=0, to=182)
d2 <- density(d_sncf$V3/24.0, from=0, to=182)

png("ttl.png", width=800, height=600)
plot(d2, col="red", main="Temps avant panne des ascenseurs STIF", xlab="Temps (jours)", ylab = "Probabilité")
lines(d1, col="blue")
abline(v=seq(0, 182, 10), lty=2)
legend("topright", title="Réseau", c("SNCF", "RATP"), fill=c("red", "blue"), bg="white")
dev.off()

d1 <- density(hs_ratp$V3, from=0, to=168, adjust=3)
d2 <- density(hs_sncf$V3, from=0, to=168, adjust=3)
png("ttd.png", width=800, height=600)
plot(d1, col="blue", main="Temps avant réparation des ascenseurs STIF", xlab="Temps (heures)", ylab = "Probabilité")
lines(d2, col="red")> abline(v=seq(0, 168, 24), lty=2)
legend("topright", title="Réseau", c("SNCF", "RATP"), fill=c("red", "blue"), bg="white")
dev.off()


rm(list=ls())
library(plyr)
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)

# Colors
# https://www.w3schools.com/colors/colors_picker.asp
color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "yellow4" # 8b8b00
# set dataset

#dataset <- "SinghalOG"
dataset <- "Streicher"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS")) %>%
  mutate_if(is.numeric,round,2)
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF"))

# Change from 2ln(BF) to ln(BF) by dividing all comparisons by 2 7-10 - not including average calcs
names(mLBF[7:10])
mLBF[7:10] <- mLBF[7:10]/2
# for singhal OG
#names(mLBF[4])
#mLBF[4] <- mLBF[4]/2

# Get total number of loci
loci <- length(mLGL$Locus)

#------------------------------------------------------------------------------------------------------------------------------------------------------

# Histogram ---------------------------------------------- Histogram --------------------------------------------------------------------------------------------------------

#------------------------------------------------------------------------------------------------------------------------------------------------------

H <- function(df,xval,cc,hbin,xlab){
  ggplot(data=df, aes(x=xval)) +
  geom_histogram(bins=hbin, alpha=1, position="dodge",  fill=cc, color="grey",size=0.1) +
  #geom_histogram(breaks=brx, alpha=1, position="dodge",  fill=cc, color="grey",size=0.1)+
  #geom_histogram(binwidth = max(abs(xval))*0.01, alpha=1, position="dodge",color="grey", fill=cc, size=0.1)+
  theme_classic() +
  theme(plot.title = element_text(hjust = 0.5, size=10),
        axis.text = element_text(size=6, color="black"),
        text = element_text(size=8),
        legend.title = element_text(size = 8),
        legend.text = element_text(size = 8),
        panel.border = element_blank(),
        panel.background = element_rect(fill = "transparent"), # bg of the panel
        plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
        panel.grid = element_blank()) +
  labs(y="Number of Loci",x=xlab)  #+
  #coord_cartesian(xlim = x.tic) +
  #coord_cartesian(ylim=ytic, xlim = xtic) +
  #scale_y_continuous() +
  #scale_x_continuous(breaks = xtic) +
  # geom_vline(xintercept=lines.g,color=c("black"), linetype="dashed", size=0.5) +
  #geom_vline(xintercept=c(0),color=c("black"), linetype="dashed", size=0.2)
  }

#quartz()

h.bin <- 50
h <- "TvS"
#-------GL-----------------------------------------------------------------------------------------------------------------------------------------------------

# Set input data

x.val <- mLGL$TvS
df <- mLGL
cc <- 'slateblue'
# Get max min for graph to set x axis values
max.x <- round_any(max(abs(x.val)),10,f=ceiling)
x.tic <- seq(-max.x,max.x,round(max.x/5,digits=-1))
max(abs(x.val))
x.tic

gl <- H(df,x.val,cc,h.bin,'dGLS values') +
  coord_cartesian(xlim = x.tic) +
  scale_x_continuous(breaks = x.tic)

#quartz()
gl

y.tic <- seq(0,800,200)

gl <- H(df,x.val,cc,h.bin,'dGLS values') +
  coord_cartesian(xlim = x.tic, ylim=y.tic) +
  scale_x_continuous(breaks = x.tic) +
  scale_y_continuous(breaks = y.tic)
gl

#--------BF-----------------------------------------------------------------------------------------------------------------------------------------------------
rm(x.val,x.tic)

# Set
x.val <- mLBF$TvS
df <- mLBF
cc <- 'orange3'
# Get max min for graph to set x axis values
max.x <- round_any(max(abs(x.val)),10,f=ceiling)
x.tic <- seq(-max.x,max.x,round(max.x/5,digits=-1))
x.tic <- seq(-max.x,max.x,10)
max(abs(x.val))
x.tic
h.bin <- 50
bf <- H(df,x.val,cc,h.bin,'ln(BF) values') +
  coord_cartesian(xlim = x.tic, ylim=y.tic) +
  scale_x_continuous(breaks = x.tic) +
  scale_y_continuous(breaks = y.tic)
#quartz()
bf

title <- paste(dataset," - ",h,sep="")

g <- annotate_figure(ggarrange(gl,bf, ncol=1, nrow=2, align="v"),
                     top = text_grob(title, color = "black", size = 16))
g <- g + theme_transparent()

#ggsave(paste(dataset,"_histo_",h,".pdf",sep=""), plot=g,width = 4, height = 3, units = "in", device = 'pdf',bg = "transparent")

#---Tx------------------------------------------------------------------------------------------------------------------------------------------------------------

Htx <- function(x.val){
  # Get max min for graph to set x axis values
  max.x <- round_any(max(abs(x.val)),10,f=ceiling)
  x.tic <- seq(-max.x,max.x,round(max.x/2,digits=0))
  return(x.tic)
  }
Htx(mLGL$AIvSA)
# Singhal has outlier that messes up the graphs - AHE-L95, AHE-L8, AHE-L354
#nope <- c('AHE-L95', 'AHE-L8', 'AHE-L354')
#mLBF <- mLBF %>% filter(!Locus %in% nope)
#mLGL <- mLGL %>% filter(!Locus %in% nope)

#----------TxGL-----------------------------------------------------------------------------------------------------------------------------------------------------
nclass.FD(mLGL$AIvSA)
quartz()
# Set input data
hbin <- 50
y.tic <- seq(0,4000,1000)
cc <- 'slateblue'
g1 <- H(mLGL,mLGL$AIvSA,cc,hbin,'dGLS') +
  coord_cartesian(xlim = seq(-60,30, by=10), ylim=y.tic) +
  #scale_x_continuous(breaks=Htx(mLGL$AIvSA)) +
  scale_x_continuous(breaks=seq(-60,30, by=10)) +
  scale_y_continuous(breaks = y.tic) #+ ggtitle('AIvSA')
g1
#x <- seq(-0.5,0.5,0.05)
#g1 + coord_cartesian(xlim = x, ylim=y.tic) +
#  scale_x_continuous(breaks=x)
g2 <- H(mLGL,mLGL$AIvSI,cc,hbin,'dGLS') + ggtitle('AIvSI') +
  coord_cartesian(xlim = Htx(mLGL$AIvSI), ylim=y.tic) +
  scale_x_continuous(breaks=Htx(mLGL$AIvSI)) +
  scale_y_continuous(breaks = y.tic)

g3 <- H(mLGL,mLGL$SAvSI,cc,hbin,'dGLS') + ggtitle('SAvSI') +
  coord_cartesian(xlim = Htx(mLGL$SAvSI), ylim=y.tic) +
  scale_x_continuous(breaks=Htx(mLGL$SAvSI)) +
  scale_y_continuous(breaks = y.tic)

#-------TxBF-----------------------------------------------------------------------------------------------------------------------------------------------------
cc <- 'orange3'

b1 <- H(mLBF,mLBF$AIvSA,cc,hbin,'ln(BF)')  +
  coord_cartesian(xlim = seq(-60,30, by=10), ylim=y.tic) +
  scale_x_continuous(breaks=seq(-60,30, by=10)) +
  #scale_x_continuous(breaks=Htx(mLBF$AIvSA)) +
  scale_y_continuous(breaks = y.tic) #+ ggtitle('AIvSA')
b1
b2 <- H(mLBF,mLBF$AIvSI,cc,hbin,'ln(BF)') + ggtitle('AIvSI') +
  coord_cartesian(xlim = Htx(mLBF$AIvSI), ylim=y.tic) +
  scale_x_continuous(breaks=Htx(mLBF$AIvSI)) +
  scale_y_continuous(breaks = y.tic)

b3 <- H(mLBF,mLBF$SAvSI,cc,hbin,'ln(BF)') + ggtitle('SAvSI') +
  coord_cartesian(xlim = Htx(mLBF$SAvSI), ylim=y.tic) +
  scale_x_continuous(breaks=Htx(mLBF$SAvSI)) +
  scale_y_continuous(breaks = y.tic)

title <- dataset

#g <- annotate_figure(ggarrange(g1,g2,g3,b1,b2,b3, ncol=3, nrow=2, align="v"),
#                     top = text_grob(title, color = "black", size = 16))
#g

gv <- g1 + geom_vline(xintercept=c(-0.5,0.5),color=c("black"))
gv
bv <- b1 + geom_vline(xintercept=c(-5,5),color=c("black"))
bv

gv <- g1 + geom_hline(yintercept=3170,color=c("black"),linetype="dashed",size=0.2)
bv <- b1 + geom_hline(yintercept=3170,color=c("black"),linetype="dashed",size=0.2) +
  geom_hline(yintercept=2490,color=c("black"),size=0.2)
bv

v <- ggarrange(gv,bv, ncol=1, nrow=2, align="v")
v

h <- "aivsa"
ggsave(paste(dataset,"_histo_",h,".pdf",sep=""), plot=v,width = 3, height = 3, units = "in", device = 'pdf',bg = "transparent")

### old

## Get max number of loci around 0
#brx <- pretty(range(x.val), n = nclass.FD(x.val), min.n = 1)
#binwidth <- brx[2]-brx[1]
#max.y <- round_any(sum(x.val > 0 & x.val < binwidth),50,f=ceiling)
#y.tic <- seq(0,max.y,round(max.y/10,digits=-1))
#sum(x.val > 0 & x.val < binwidth)
#y.tic
#H <- function(df,xval,cc,xtic,brx,xlab){
#  ggplot(data=df, aes(x=xval)) +
#    geom_histogram(bins=100, alpha=1, position="dodge",  fill=cc, color="grey",size=0.1) +
#    #geom_histogram(breaks=brx, alpha=1, position="dodge",  fill=cc, color="grey",size=0.1)+
#    #geom_histogram(binwidth = max(abs(xval))*0.01, alpha=1, position="dodge",color="grey", fill=cc, size=0.1)+
#    theme_classic() +
#    theme(plot.title = element_text(hjust = 0.5, size=16),
#          axis.text = element_text(size=8, color="black"),
#          text = element_text(size=12),
#          legend.title = element_text(size = 10),
#          legend.text = element_text(size = 10)) +
#    labs(y="Number of Loci",x=xlab)  +
#    #coord_cartesian(xlim = xtic) +
#    #coord_cartesian(ylim=ytic, xlim = xtic) +
#    #scale_y_continuous() +
#    #scale_x_continuous(breaks = xtic) +
#    # geom_vline(xintercept=lines.g,color=c("black"), linetype="dashed", size=0.5) +
#    geom_vline(xintercept=c(0),color=c("black"), linetype="dashed", size=0.2)
#}
#


library(lodown)
lodown( "brfss" , output_dir = file.path( path.expand( "~" ) , "BRFSS" ) )
# examine all available BRFSS microdata files
brfss_cat <-
  get_catalog( "brfss" ,
               output_dir = file.path( path.expand( "~" ) , "BRFSS" ) )

# 2016 only
brfss_cat <- subset( brfss_cat , year == 2016 )
# download the microdata to your local computer
brfss_cat <- lodown( "brfss" , brfss_cat )

options( survey.lonely.psu = "adjust" )

library(survey)

brfss_df <-
  readRDS( file.path( path.expand( "~" ) , "BRFSS" , "2016 main.rds" ) )

variables_to_keep <-
  c( 'one' , 'xpsu' , 'xststr' , 'xllcpwt' , 'genhlth' , 'medcost' ,
     'xstate' , 'xage80' , 'nummen' , 'numadult' , 'hlthpln1' )

brfss_df <- brfss_df[ variables_to_keep ] ; gc()

brfss_design <-
  svydesign(
    id = ~ xpsu ,
    strata = ~ xststr ,
    data = brfss_df ,
    weight = ~ xllcpwt ,
    nest = TRUE
  )


# Makes a decreasing sorted vector of all unique vals
# TODO: Use this for is_itinerant() function to compare top two modes
make_mode_vec_uniques <- function (v) with(rle(sort(v)), values[order(lengths, decreasing = TRUE)])

# IN PROGRESS
# Makes a sorted mode vector.
# Will be useful for obtaining the second most common element
# if the most active tower during a customer’s respective timeframe criteria
# has less than 30% more activity than the second-most-active tower,
# then the record is removed.
#is_itinerant <- function(cell_ids) {

#    if (length(cell_ids) == 1) {
#	return(FALSE)
#    }
#    new_vec <- as.vector(cell_ids)
#    mode_vec_uniques <- make_mode_vec_uniques(new_vec)
#    num_instances_most_active_tower <- length(which(cell_ids == mode_vec_uniques[1]))
#    num_instances_second_most_active_tower <- sum(cell_ids == mode_vec_uniques[2] )
#    print(paste("num instances most act is ", num_instances_most_active_tower))
#    if (is.na(num_instances_second_most_active_tower) | (num_instances_second_most_active_tower == 0))
#	return(FALSE)
#    print(paste("num instances 2nd most act is ", num_instances_second_most_active_tower))
#    tot <- (num_instances_most_active_tower) + (num_instances_second_most_active_tower)
#    diff_in_percent <- (num_instances_second_most_active_tower) / (tot)
#    print(paste("percent active is ", 1 - diff_in_percent))
#    if (diff_in_percent < 0.30) {
#	print(paste("ANUMBER with this cellID is itinerant", cell_ids))
#	return(FALSE)
#    }
#    return(TRUE)
#}

is_work_time <- function(call_start_time, k_options) {
    # Determines whether a call_start_time occurs during typical work hours.
    #
    # Args:
    #   call_start_time: The time at the start of a call for a given record.
    #   k_options: The data frame containing a set of user-defined
    #              constants.
    #
    # Returns:
    #   TRUE if during work time, FALSE otherwise

    if ((get_hour(call_start_time) >= k_options$k_work_start) & (get_hour(call_start_time) <= k_options$k_work_end))
    return(TRUE)
  else
    return(FALSE)
}

home_or_work <- function(call_start_time, k_options) {
    # Determines whether a given call time occurs during work or home hours.
    #
    # Args:
    #   call_start_time: The time at the start of a call for a given record.
    #   k_options: The data frame containing a set of user-defined
    #              constants.
    #
    # Returns:
    #  Since ifelse tests conditions for each vector, it writes "Home" or
    #  "Work" to each element accordingly.

    ifelse(!is_work_time(call_start_time, k_options), "Home", "Work")
}

get_mode <- function(v) {
    # Gets the mode of vector v

    uniqv <- unique(v)
    uniqv[which.max(tabulate(match(v, uniqv)))]
}

get_home_or_work_loc_by_label <- function(possible_locs, home_and_work_vec, label) {
    # Gets the mode of a set of CELL_IDs to determine which is the most likely
    # home/work id.
    #
    # Args:
    #   possible_locs: A single-column dframe of possible_locs. Depending on
    #                  value set in k_options, possible vals could be a
    #                  dframe of cell_ids, munis, or depts.
    #   home_and_work_vec: A single-column dframe with values of "Home" and
    #    	           "Work", which are classified as such by time of
    #                      day and correspond to the values in possible_locs.
    #   label: The label (can be either "Home" or "Work") which is used to
    #          filter all possible_locs. E.g. if the input label == "Home",
    #          Then this function will take all possible_locs, subset all
    #          vals such that their corresponding home_work_vec val ==
    #          "Home", and find the mode of possible_locs.
    #
    # Returns:
    #   The most probable home/work location.

    possible_locs <- as.data.frame(possible_locs)
    home_and_work_vec <- as.data.frame(home_and_work_vec)

    filt <- data.frame(possible_locs, home_and_work_vec) %>%
	filter(home_and_work_vec == label)

    #if(isItinerant(filt$CELL_ID)) {
    #return() # returns <NA> (I think)
    #print("found itinerant record")
    #}

    probable_home_or_work_loc = get_mode(filt$possible_locs)

    return(probable_home_or_work_loc)
}

# TODO: Can use get_id_by_label instead?
get_home_id <- function(fcdr, HOME_TYPE, number) {
    # Gets the home_id of a given number.
    #
    # Args:
    #   HOME_TYPE: The user-defined home type (muni, dept, or cell_id).
    #   fcdr: The filtered cdr data frame.
    #   number: The number for which to get home_id (ANUMBER or BNUMBER).
    #
    # Returns:
    #   The home_id.

    filt <- fcdr %>%
	filter(ANUMBER == number)
    ID <- filt$HOME_ID
    return(as.character(ID))
}

# TODO: Can use get_id_by_label instead?
get_work_id <- function(fcdr, number) {
    # Same as get_home_id but work_id.

    filt <- fcdr %>%
	filter(ANUMBER == number)
    ID = filt$WORK_ID
    return(as.character(ID))
}

# IN PROGRESS
# option: either "city" or "state"
#get_geo_info_by_coords <- function(option, lat, lon) {
#    geo_information <- revgeo(lat, lon, output = "frame")
#    if(option == "city")
#	return(geo_information$city)
#    else if(option == "state")
#	return(geo_information$state)
#    else
#	stop("Error in getGeoInfoByCoords() call.\n
#	      Must specifiy option for first param.\n
#	      Option choices: city or state")
#}

get_coords <- function(tower_id, towers) {
    # Gets the lat/lon coords for a given tower.
    #
    # Args:
    #   tower_id: The tower whose lat/lon coords are to be obtained.
    #   towers: The data frame consisting of all towers and lat/lons.
    #
    # Returns:
    #   The coordinates of the tower.

    coords <- filter(towers, CELL_ID == tower_id) %>%
	select(LATITUDE, LONGITUDE)
    lat <- coords[1, 1]
    lon <- coords[1, 2]
    return(paste(lat, lon, sep = ","))
}

# Calculates driving distance in km between two points
# From https://stackoverflow.com/questions/16863018/getting-driving-distance-between-two-points-lat-lon-using-r-and-google-map-ap€‹
driving_distance <- function(origin, destination){
  xml.url <- paste0('http://maps.googleapis.com/maps/api/distancematrix/xml?origins=',origin,'&destinations=',destination,'&mode=driving&sensor=false')
  xmlfile <- xmlParse(getURL(xml.url))
  dist <- xmlValue(xmlChildren(xpathApply(xmlfile,"//distance")[[1]])$value)
  distance <- as.numeric(sub(" km","",dist))
  #ft <- distance*3.28084 # FROM METER TO FEET
  km <- distance/1000.0 # from meters to km
  return(km)
}

get_distance <- function(fcdr, towers) {
    # Creates a data frame containing the distances between home and work
    # towers.
    #
    # Args:
    #   fcdr: The filtered cdr.
    #   towers: The data frame consisting of all tower data.
    #
    # Returns:
    #   The data frame of fcdr with an added column of driving distances
    #   between home and work.

    dist <- group_by(fcdr, ANUMBER) %>%
	summarise(distCommute = driving_distance(get_coords(get_home_id(fcdr, k_options$HOME_TYPE, ANUMBER), towers), get_coords(get_work_id(fcdr, ANUMBER), towers)))
  return(dist)
}

show_home_and_work_towers <- function(data, towers, k_options) {
    # Creates a data frame which shows the home/work towers for each
    # ANUMBER.
    #
    # Args:
    #   data: The cdr.
    #   towers: The tower data.
    #   k_options: The data frame containing a set of user-defined
    #              constants.
    #
    # Returns:
    #   The data frame with all home and work towers for each ANUMBER.

    probable_place <- group_by(data, ANUMBER, START_DATE_TIME, CELL_ID) %>%
	summarise(PLACE = home_or_work(START_DATE_TIME, k_options)) %>%
	group_by(ANUMBER) %>%
	summarise(HOME_ID = get_home_or_work_loc_by_label(CELL_ID, PLACE, "Home"),
	      WORK_ID = get_home_or_work_loc_by_label(CELL_ID, PLACE, "Work")) %>%
	return()
}

show_home_by_label <- function(data, towers, k_options) {
    # Shows the type of home_id based on user-defined constant.
    #
    # Args:
    #   data: The cdr.
    #   towers: The tower data.
    #   k_options: The data frame containing a set of user-defined
    #              constants.
    #
    # Returns:
    #   The filtered cdr with the home shown for each ANUMBER.

    label <- k_options$k_home_type[1]

    # if home_type is tower
    if (label == 1) {
	probable_place <- group_by(data, ANUMBER, START_DATE_TIME, CELL_ID) %>%
	    summarise(PLACE = home_or_work(START_DATE_TIME, k_options)) %>%
	    group_by(ANUMBER) %>%
	    summarise(HOME_ID = get_home_or_work_loc_by_label(CELL_ID, PLACE, "Home")) %>%
	    return()
    }

    # home_type is city
    else if (label == 2) {
	print("data is:")
	print(head(data))
	probable_place <- group_by(data, ANUMBER, START_DATE_TIME, CITY) %>%
	    summarise(PLACE = home_or_work(START_DATE_TIME, k_options)) %>%
	    group_by(ANUMBER) %>%
	    summarise(HOME_ID = get_home_or_work_loc_by_label(CITY, PLACE, "Home")) %>%
	    return()
    }

    # home_type is state
    else if (label == 3) {
	probable_place <- group_by(data, ANUMBER, START_DATE_TIME, STATE) %>%
	    summarise(PLACE = home_or_work(START_DATE_TIME, k_options)) %>%
	    group_by(ANUMBER) %>%
	    summarise(HOME_ID = get_home_or_work_loc_by_label(STATE, PLACE, "Home")) %>%
	    return()
    }
}

find_and_remove_records_with_no_home_work_pair <- function(data, towers, k_options) {
    # Removes all records that do not have home/work pairs.
    #
    # Args:
    #   data: The cdr.
    #   towers: The tower data.
    #   k_options: k_options: The data frame containing a set of user-defined
    #              constants.
    #
    # Returns:
    #   The filtered cdr containing only records that have home/work pairs.

    print("Removing records with no home/work pairs...")
    orig_num <- nrow(data) # get orig num records

    #redefine cdr with only pairs
    filt_cdr <- show_home_and_work_towers(data, towers, k_options) %>%
	filter(!is.na(HOME_ID) & !is.na(WORK_ID))

    # get new num records after removing records w/o home and work locs
    new_num <- nrow(filt_cdr)

    print(paste("raw data: ", orig_num, " record(s)", sep = ""))
    print(paste("filtered data: ", new_num, " record(s)", sep = ""))
    print(paste("percentage removed", 100 - (orig_num / new_num)))

  return(filt_cdr)
}

# TODO: Split functions such that, in main(), show_home_and_work_towers()
#       passes its return value into remove_records_with_no_home()
find_and_remove_records_with_no_home <- function(data, towers, k_options) {
    # Removes all records that do not have home_ids.
    #
    # Args:
    #   See above.
    #
    # Returns:
    #   The filtered cdr containing only records that have homes.

    print("Removing records with no home...")
    orig_num <- nrow(data) # get orig num records

    #redefine cdr showing only recs with homes
    filt_cdr <- show_home_by_label(data, towers, k_options) %>%
	filter(!is.na(HOME_ID) & (HOME_ID != "NOT APPLICABLE") &
	       (HOME_ID != "TO BE DETERMINED" &
		(HOME_ID != "NIVEL DEPARTAMENTAL")))

    # get new num records after removing records w/o home
    new_num <- nrow(filt_cdr)

    print(paste("raw data: ", orig_num, " record(s)", sep = ""))
    print(paste("num records with homes: ", new_num, " record(s)", sep = ""))
    print(paste("percentage removed", 100 - (orig_num / new_num)))

  return(filt_cdr)
}

get_data <- function(PATHS) {
    # Load all data into a vector of data frames.
    #
    # Args:
    #   PATHS: The vector of paths containing user-defined file paths.
    #
    # Returns:
    #   A list of three data frames (cdr, towers, and elec_data).

    cdr_raw <- read.csv(PATHS[1]) # import call detail records
    print("Loaded raw data")
    towers <- read.csv(PATHS[2]) # import tower locations
    print("Loaded tower data")
    cdr <- merge(cdr_raw, towers, by="CELL_ID") # merge data into one table
    print("Merged tower and cell data")
    elec_data <- read.csv(PATHS[3]) # import 2015 secondary election data
    print("Loaded election data")

    # make a list of three data frames (cdr, towers, elec_data)
    df.cdr <- data.frame(cdr)
    df.towers <- data.frame(towers)
    df.elec_data <- data.frame(elec_data)
    return(list("cdr" = df.cdr, "towers" = df.towers, "elec_data" = df.elec_data))
}

# init file paths
init_paths <- function() {
  CDR_DATA <- "/Users/tedhadges/Projects/guatemala/raw_data/Filtered_Sample.csv"
  TOWER_DATA <- "/Users/tedhadges/Projects/guatemala/raw_data/tower_data.csv"
  ELECTION_DATA <- "../../mapping/data/elecData2015.csv"
  PATHS <- c(CDR_DATA, TOWER_DATA, ELECTION_DATA)

  return(PATHS)
}

set_options<- function() {
    # Creates a data frame of user-defined constants to be used in other
    # functions. Manually set all params here.

    k_work_start_time <- 8 # set work start time here
    k_work_end_time <- 18 # set work end time here

    # use k_home_id_type to define how to classify home_id
    # opts: tower: 1, city: 2, state: 3
    k_home_id_type <- 2

    k_options_frame <- data.frame("k_work_start", "k_work_end", "k_home_type")
    k_options_frame$k_work_start <- k_work_start_time
    k_options_frame$k_work_end <- k_work_end_time
    k_options_frame$k_home_type <- k_home_id_type

    return(k_options_frame)
}

# check if packs installed and load them
load_packs <- function() {
    source("timeParser.r")
  list_of_packages <- c("dplyr", "modeest", "lubridate", "XML", "bitops", "RCurl", "profvis", "ggmap", "reshape")
  new_packages <- list_of_packages[!(list_of_packages %in% installed.packages()[,"Package"])]
  if(length(new_packages)) install.packages(new_packages)

  # load the packs
  library(dplyr)
  library(modeest)
  library(lubridate)
  library(XML)
  library(bitops)
  library(RCurl)
  library(reshape)
}

# dframe is a two-column dframe with ANUMBER HOME_ID
# Returns a data frame whose columns are "HOME_ID" and "n", where n is the
# number of callers who have that home_id.
group_by_home_loc <- function(dframe) {
    groupedFrame <- group_by(dframe, HOME_ID) %>%
	tally() %>%
	return()
}

# IN PROGRESS
#plot_by_home_id <- function(dframe) {
    #plot(x, axes = FALSE,
    #axis(side = 1, at = c(1,5,10))
    #axis(side = 2, at = c(1,3,7,10))
    #main="Number of Callers by Home Location",
    #xlab="Home IDs",
    #ylab="Number of Callers",
    #type="b",
    #col="blue")
    #lines(x,col="red")
    #fill=c("blue")
#}

main_commute <- function() {
  load_packs() # install (if necessary) and load packages
  PATHS <- init_paths() # init file paths
  k_options <- set_options() # dframe with all params/options

  data_list <- get_data(PATHS)
  cdr <- data_list$cdr
  towers <- data_list$towers

  #fcdr <- removeRecordsWithNoHomeWorkPair(cdr, towers, threshs)

  fcdr <- find_and_remove_records_with_no_home(cdr, towers, k_options)

  #fcdr_dist <- get_distance(fcdr, towers)
  cdr_for_plotting<- group_by_home_loc(fcdr)

  return(cdr_for_plotting)
}


# This is an example code for subsetting and filtering in H2O
# We'll split the dataset into "YES" entries and "NO" entries
# Then from that subset the dataset further to take a random sample of 500 "YES" and 500 "NO" each

# Detach and remove old H2O package if it exists
detach("package:h2o", unload=TRUE)
remove.packages("h2o",.libPaths())

# Install the same version of H2O from online repository that is running on your Hadoop Cluster
install.packages("h2o", repos=(c("http://s3.amazonaws.com/h2o-release/h2o/master/1477/R", getOption("repos"))))
#Load H2O library
library(h2o)

#Start and connect to an H2O instance
local.h2o = h2o.init(max_mem_size = '4g')

#Import small YES/NO data set into H2O
class_col = h2o.importFile(local.h2o,
                           "https://raw.githubusercontent.com/0xdata/h2o/63e04a6654ebcb2561852aca8f16b664a7b46400/smalldata/categoricals/simple_YES_NO.csv",
                           key="class_col")

#Check dimensions of data file
dim(class_col)
#Run summary, should have 9000 "YES" entries and 1000 "NO" entries
summary(class_col)

# Create a new h2o frame for row indices and cbind to the categorical column to avoid different chunk sizes
row_indices = h2o.exec(expr_to_execute = seq(1,nrow(class_col),1), h2o = class_col@h2o)
labels = class_col[,1]
label_col = cbind(labels, row_indices)

# Run the equivalent of which(label_col == "YES") and which(label_col == "NO")
idx0 = label_col[label_col[,1] == levels(labels)[1] ] [,2]
idx1 = label_col[label_col[,1] == levels(labels)[2] ] [,2]

# Produce a vector of random uniform numbers for each of the  class
random0 = h2o.runif(idx0)
random1 = h2o.runif(idx1)

# Subset the indices to take random 500 entries for each of the two classes
rows = 1000
select_idx0 = idx0[random0 <= ceiling((rows*0.5)/length(idx0))+0.01] [1:(rows*0.5)]
select_idx1 = idx1[random1 <= ceiling((rows*0.5)/length(idx1))+0.01] [1:(rows*0.5)]

# Subset the original H2OParsedData object by combining the indices of desired entries
all_idx = h2o.exec(c(select_idx0,select_idx1))
dataset = h2o.exec(class_col[all_idx,])
dataset


#library(ggplot2)
library(data.table)
library(BiocParallel)
library(limma)
library(edgeR)
library(variancePartition)
library(dplyr)
library(Matrix)
library(compositions)

pdf(file = "figures.pdf") # The height of the plot in inches

geneExpr = fread('./freq_celltype.csv')
metadata = geneExpr[, 10:15]
geneExpr = as.matrix(geneExpr[, 1:9])

metadata$is_covid = factor(metadata$covid)
metadata$subject_id = factor(metadata$subject)
metadata$tissue = factor(metadata$tissue)
metadata$pid = factor(metadata$pid)
metadata$Biosample = factor(with(metadata, paste(subject_id, pid, tissue)))
metadata$aggr_unit = factor(with(metadata, paste(subject_id, pid, tissue_id))) # tissue_id
metadata$ID = factor(with(metadata, paste(subject_id, pid, tissue)))

## dream
info = metadata
mat = clr(t(geneExpr))

form = ~ 0 + is_covid:tissue + (1|tissue) + (1|subject_id)

L1  = getContrast(mat, form, info, c("is_covid1:tissuePFC",'is_covid0:tissuePFC'))
L2  = getContrast(mat, form, info, c("is_covid1:tissuemedulla",'is_covid0:tissuemedulla'))
L3  = getContrast(mat, form, info,
  c("is_covid1:tissuechoroidplexus",'is_covid0:tissuechoroidplexus'))
L = data.frame(PFC = L1, medulla = L2, choroidplexus = L3)
fit = dream(mat, form, info, L = L, BPPARAM=SnowParam(24, progressbar=TRUE))

tabList = lapply( colnames(coef(fit))[1:3], function(tissue){
    tab = topTable(fit, coef=tissue, number=Inf)

    data.frame( Gene      = rownames(tab),
                Tissue    = tissue,
                logFC     = tab$logFC,
                P.Value   = tab$P.Value,
                z.std     = tab$z.std)
  })

resTab = do.call(rbind, tabList)
resTab$fdr = p.adjust(resTab$P.Value, 'fdr')
write.csv(resTab, 'dream_test.csv')

dev.off()


##########################################
# simple demo of building sequence rules
##########################################

library(arulesSequences)
library("readr")
library(dplyr)

##load training data and modify
##load training data and modify
train_clicks <- read_csv("RecSys/data_cleaned/train.csv",
                         col_types = cols(X1 = col_skip(), cat = col_character(),
                                     itemID = col_character(), sessionID = col_character(),
                                     status = col_logical(), ts = col_datetime(format = "%Y-%m-%dT%H:%M:%OS%Z")))

train_clicks<-train_clicks[with(train_clicks,order(sessionID,ts)),]
train_clicks<-train_clicks %>% group_by(sessionID) %>% mutate(eventid = row_number(sessionID))
train_clicks$ts<-train_clicks$eventid
train_clicks$itemID<-paste0("itemID=",train_clicks$itemID)
#train_clicks$itemID<-paste(train_clicks$itemID,"-",train_clicks$cat)
train_clicks$eventid<-NULL
train_clicks$status<-NULL
train_clicks$cat<-NULL
readr::write_csv(train_clicks,"./RecSys/data_cleaned/seq.csv",col_names = FALSE)

#read sequences
data <- read_baskets(con = "./RecSys/data_cleaned/seq.csv",sep = ",", info = c("sequenceID","eventID"))

as(head(data), "data.frame") # view first few rows of the data

seqs <- cspade(data, parameter = list(support = 0.001), control = list(verbose = TRUE))
as(seqs,"data.frame")  # view the sequences
summary(seqs)

rules <- ruleInduction(seqs, confidence = 0.01,control = list(verbose = TRUE))
as(rules,"data.frame")  # view the rules

#form rules dataframe
rulesDF = as(rules,"data.frame")
rulesDF$lhs<-as(lhs(rules), "list")
rulesDF$rhs<-as(rhs(rules), "list")
rulesDF$lhs_length<-apply(rulesDF,1,function(x)length(x["lhs"][[1]]))
#readr::write_csv(rulesDF,"./RecSys/data_cleaned/seq_rules.csv")


\name{hc_segments-HilbertCurve-method}
\alias{hc_segments,HilbertCurve-method}
\title{
Add line segments to Hilbert curve
}
\description{
Add line segments to Hilbert curve
}
\usage{
\S4method{hc_segments}{HilbertCurve}(object, ir = NULL, x1 = NULL, x2 = NULL,
    gp = gpar(lty = 1, lwd = 1, col = 1))
}
\arguments{

  \item{object}{A \code{\link{HilbertCurve-class}} object.}
  \item{ir}{an \code{\link[IRanges:IRanges-constructor]{IRanges}} object which specifies the input intervals.}
  \item{x1}{if start positions are not integers, they can be set by \code{x1}.}
  \item{x2}{if end positions are not integers, they can be set by \code{x2}.}
  \item{gp}{graphic parameters for lines. It should be specified by \code{\link[grid]{gpar}}. Note you cannot set \code{linejoin} and \code{lineend}.}

}
\value{
A data frame which contains coordinates (in the 2D space) of segments.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
hc = HilbertCurve(1, 100, level = 4, reference = TRUE)

x = sort(sample(100, 20))
s = x[1:10*2 - 1]
e = x[1:10*2]
require(IRanges)
ir = IRanges(s, e)

hc_segments(hc, ir)
}


as.roman(1666)   # MDCLXVI


#BETWEEN LINES 3 AND 51 IS THE CODE TO DOWNLOAD
#THE DATA SET
################################
# Create edx set, validation set
################################

# Note: this process could take a couple of minutes

if(!require(tidyverse)) install.packages("tidyverse", repos = "http://cran.us.r-project.org")
if(!require(caret)) install.packages("caret", repos = "http://cran.us.r-project.org")
if(!require(data.table)) install.packages("data.table", repos = "http://cran.us.r-project.org")

# MovieLens 10M dataset:
# https://grouplens.org/datasets/movielens/10m/
# http://files.grouplens.org/datasets/movielens/ml-10m.zip
# http://files.grouplens.org/datasets/movielens/ml-10m.zip
dl <- tempfile()
download.file("http://files.grouplens.org/datasets/movielens/ml-10m.zip", dl)

ratings <- fread(text = gsub("::", "\t", readLines(unzip(dl, "ml-10M100K/ratings.dat"))),
                 col.names = c("userId", "movieId", "rating", "timestamp"))

movies <- str_split_fixed(readLines(unzip(dl, "ml-10M100K/movies.dat")), "\\::", 3)
colnames(movies) <- c("movieId", "title", "genres")
movies <- as.data.frame(movies) %>% mutate(movieId = as.numeric(levels(movieId))[movieId],
                                           title = as.character(title),
                                           genres = as.character(genres))

movielens <- left_join(ratings, movies, by = "movieId")

# Validation set will be 10% of MovieLens data

set.seed(1)
# if using R 3.5 or earlier, use `set.seed(1)` instead
test_index <- createDataPartition(y = movielens$rating, times = 1, p = 0.1, list = FALSE)
edx <- movielens[-test_index,]
temp <- movielens[test_index,]

# Make sure userId and movieId in validation set are also in edx set

validation <- temp %>%
  semi_join(edx, by = "movieId") %>%
  semi_join(edx, by = "userId")

# Add rows removed from validation set back into edx set

removed <- anti_join(temp, validation)
edx <- rbind(edx, removed)

rm(dl, ratings, movies, test_index, temp, movielens, removed)

# WE EXPLORE OUR DATA IN THE NEXT LINES
#####
#fINDING The number of unique users
edx$userId %>% unique() %>% length()
#THE RESULT PROVES USERS RATE MULTIPLE MOVIES
#the number of unique movies
edx$movieId %>% unique() %>% length()
#THE RESULT SHOWS A RELATIVELY LOW NUMBER OF
#MOVIES TO THE DATA, HENCE MOVIES ARE RATED A
#BY MANY USERS

# WE OBSERVE the most rated films
movie_counts <- edx %>% group_by(title) %>% summarise(count = n())
movie_counts[order(movie_counts$count, decreasing = TRUE),]

# AND the least rated films
movie_counts[order(movie_counts$count, decreasing = FALSE),]

#FREQUENCY OF RATINGS
# WE ALSO OBSERVE THE DISTRIBUTION OF THE RATINGS
edx %>%
  group_by(rating)%>%
  summarise(count = n()) %>%
  ggplot(aes(x = rating, y = count))+
  geom_smooth(se= FALSE)
#WE TEST THE IMPACT OF REMOVING MOVIES AND USERS WITH A FEW RATINGS
# REMOVING MOVIES WITH few RATINGS
edx %>%
  group_by(movieId) %>%
  summarise(mcount=n())%>%
  filter(mcount>500)%>%
  left_join(edx,by= 'movieId')%>%
  group_by(rating)%>%
  summarise(count = n())%>%
  ggplot(aes(x = rating, y = count ))+
  geom_col()
# REMOVING users WITH few RATINGS
edx %>%
  group_by(userId) %>%
  summarise(ucount=n())%>%
  filter(ucount>1000)%>%
  left_join(edx,by= 'userId') %>%
  group_by(rating)%>%
  summarise(count = n())%>%
  ggplot(aes(x = rating, y = count))+
  geom_col()
######
#FINALLY WE BUILD OUR MODEL
#####
# We fist split our data into training and testing sets,
#We will carry out cross validation
#so they will be 9 training sets and one test set.
ind = createFolds(edx$rating, k = 4)

test1 = edx[ind$Fold1,]
train1 = edx[-ind$Fold1,]
#To ensure all users in the train set appear in the test and likewise for movies we use the semi join function

test1 <- test1 %>%
  semi_join(train1, by = "movieId") %>%
  semi_join(train1, by = "userId")

# After splitting our data in to train and test
#we create a naive model that assings the average movie rating
# to all movies, thus our first model is y(rating) = mu(average rating) + e(error)
avg_rat1 = mean(train1$rating)

#Thus our RMSE for our naive prediction is:
naive_rmse1 <- RMSE(test1$rating, avg_rat1)
naive_rmse1

# Our value is 1.06 which is quite high our goal is to go below 0.865,
#however any other value will in this simple model will be worse,
#We shall store our results
rmse_results <- tibble(method = "Just the average1", RMSE = naive_rmse1)

#So now we know all movie cannot have the same rating
#so we improve our model by including a specifif movie effect
# y = mu + bi(specific movie effect) + e
mu = avg_rat1
movie_avgs1 <- train1 %>%
  group_by(movieId) %>%
  summarize(b_i = mean(rating - mu))
#So we now have each movies average rating,
#thus we know find our predicted rating with this new model
predicted_ratings1 <- mu + test1 %>%
  left_join(movie_avgs1, by='movieId') %>%
  pull(b_i)
model_1_rmse1 <- RMSE(predicted_ratings1, test1$rating)
rmse_results <- bind_rows(rmse_results,
                          data_frame(method="Movie Effect Mode1l",
                                     RMSE = model_1_rmse1))
rmse_results
# we observe a large improvement our RMSE is now 0.944
# We can now include a user effect
user_avgs1 <- train1 %>%
  left_join(movie_avgs1, by='movieId') %>%
  group_by(userId) %>%
  summarize(b_u = mean(rating - mu - b_i))
#we now complete the model
predicted_ratings1 <- test1 %>%
  left_join(movie_avgs1, by='movieId') %>%
  left_join(user_avgs1, by='userId') %>%
  mutate(pred = mu + b_i + b_u) %>%
  pull(pred)
model_2_rmse1 <- RMSE(predicted_ratings1, test1$rating)
rmse_results <- bind_rows(rmse_results,
                          tibble(method="Movie + User Effects Model1",
                                 RMSE = model_2_rmse1))
rmse_results
#THESE MODELS FAIL TO ACHEIVE THE DESIRED LEVEL OF ACCURACY IT IS OBVIOUS
#A BETTER MODEL IS REQUIRED. TO ACHIEVE THIS WE SHALL EXPERIMENT WITH REGULARISATION
#THAT IS FINDING A PENALTY TERM THAT WILL MINIMISE THE ERROR
#THIS INTUTION IS OSERVED WHEN WE EXPLORE
#THE BEST RATED AND WORST RATED MOVIES IN OUR INITIAL MODEL
# AS SHOWN
movie_titles <-edx[,c('movieId','title')]
train1 %>% count(movieId) %>%
  left_join(movie_avgs1 ) %>%
  left_join(movie_titles, by="movieId") %>%
  arrange(desc(b_i)) %>%
  select(title, b_i, n) %>%
  slice(1:10)

train1 %>% count(movieId) %>%
  left_join(movie_avgs1) %>%
  left_join(movie_titles, by="movieId") %>%
  arrange(b_i) %>%
  select(title, b_i, n) %>%
  slice(1:10)
#WE QUICKLY OBSERVE EXTREME BIASES FOR MOVIES WITH FEW RATINGS,
#THUS WE PENALISE THESE VALUES AND ARE JUSTIFED IN USING REGULARISATION
#####

#####
#####
#The RMSE this time around is 0.867 we hope to drop to less than 0.8649
#We now penalise the rating of movies that have few ratings
#that is popular movies will get the average rating plus the movie effect and the user effect,
#but unpopular movies will be penalised
#That is they will be regularised
#Before we can regularise the model an appropriate lamda has to be selected

lambdas <- seq(-10, 10, 0.25)
rmses <- sapply(lambdas, function(l){
  mu <- mean(train1$rating)
  b_i <- train1 %>%
    group_by(movieId) %>%
    summarize(b_i = sum(rating - mu)/(n()+l))
  b_u <- train1 %>%
    left_join(b_i, by="movieId") %>%
    group_by(userId) %>%
    summarize(b_u = sum(rating - b_i - mu)/(n()+l))
  predicted_ratings <-
    test1 %>%
    left_join(b_i, by = "movieId") %>%
    left_join(b_u, by = "userId") %>%
    mutate(pred = mu + b_i + b_u) %>%
    pull(pred)
  return(RMSE(predicted_ratings, test1$rating))
})
lambdas[which.min(rmses)]
#####
#OUR FINAL MODEL WITH L = 5 AS FOUND ABOVE USING THE COMPLETE EDX DATASET
#FOR TRAINING AND THE VALIDATION SET FOR CALCULATING THE RMSE
#####
# WE INITIALLY NOTE THE MEAN RATING
mu <- mean(edx$rating)
# USING THE MEAN RATING WE TRY TO EXPLAIN THE RESIDUAL
#AS A BIAS EACH MOVIE GETS TO DO THIS WE FIND THE MEAN
b_i <- edx %>%
  group_by(movieId) %>%
  summarize(b_i = sum(rating - mu)/(n()+5))
b_u <- edx %>%
  left_join(b_i, by="movieId") %>%
  group_by(userId) %>%
  summarize(b_u = sum(rating - b_i - mu)/(n()+5))
final_predicted_ratings <-
  validation %>%
  left_join(b_i, by = "movieId") %>%
  left_join(b_u, by = "userId") %>%
  mutate(pred = mu + b_i + b_u) %>%
  pull(pred)

RMSE(final_predicted_ratings, validation$rating)

#the predicted chart
cbind(validation,final_predicted_ratings)%>%
  ggplot(aes(final_predicted_ratings))+
  geom_density()
#the residual after our final prediction
cbind(validation,final_predicted_ratings)%>%
  mutate(residual = rating-final_predicted_ratings)%>%
  ggplot(aes(residual))+
  geom_density()
#mean and sd of residual
mean(validation$rating - final_predicted_ratings)
sd(validation$rating - final_predicted_ratings)


w = read.csv("discrete-error.csv", header=F)
summary(w[,1])
res = sapply(list(w[,1]), sd)
print(res)


#load library
library(MethComp)

#import data
df<-read.csv("gatti.csv", header = TRUE, sep = ";", dec= ",", stringsAsFactors = FALSE)
#
# #ignore columns
# df<-df[,1:22]
#
# head(df)
# str(df)
# #delete record number 99
# df<-df[-c(393:396),]
#

#convert data to Meth object type and save pdf with meth plot

pdf()

for(i in c(4:22)){

df_Meth<-Meth(df, 2,1,3,i)
df_Meth$meth<-factor(df_Meth$meth, levels=c("Procyte Idexx", "DF-50"))

plot(df_Meth)
title(main=list(colnames(df[i]), col="red"), line=3, adj=0.45)
print(i)
}
dev.off()

#Bland-Altman plot

BA.plot(df_Meth, repl.conn=FALSE, meth.names = TRUE)

#passing  bablok regression

reg<-PBreg(df_Meth)
print(reg)

plot(reg,subtype= 1, xlim = c(0,50), ylim= c(0,50))

#concordance correlation coefficient agreement=(misure del target, misure del test)


look.for.multiple.sets = function( x,  tdiff.min=20 ) {

  # some logs contain multiple sets in one file
  # break them down into separate groups

  if (0) {
    yr=2009
    fn="/home/jae/aegis/data/nets/Scanmar/datalogs/2009/2009-Aug20-024348.SET.LOG"
    x = load.scanmar.rawdata( fn, yr=yr)
     threshold.depth=20
    tdiff.min=20
  }

  ii = which( x$depth > 20 )
  if (length(ii) > 30) {
    zm = modes( x$depth[ii ] ) #
    threshold.depth = zm$mode / 3  # retain bottom 2/3 of data
  } else {
    threshold.depth = 20
  }

  shallow = which( x$depth < threshold.depth )
  if (length(shallow)>0) x$depth[shallow] = NA
  x = x[order( x$timestamp ) ,]
  fn0 = unique(x$nm_id)
  set = list()
  startdata = which( is.finite(x$depth) )
  if (length(startdata) < 30) return(x) # nothing to do

  ir = range( startdata)  # start and ending index
  nr = nrow(x)

  active = rep(0, nr)
  active[ which( is.finite(x$depth) ) ] = 1

  da = rep( 0, nr )
  da[1:(nr-1)] = diff( active)

  i0 = which( da ==  1 )  # starting
  i1 = which( da == -1 ) # ending

  tdiff0 = diff( x$timestamp[ i0 ] ) / 60  # minutes
  tdiff1 = diff( x$timestamp[ i1 ] ) / 60  # minutes
  tdiffs = difftime( x$timestamp[ i1 ], x$timestamp[ i0 ], units="mins" )

  i = which( tdiffs > tdiff.min )
  if (length(i) %in% c( 0,1) ) {
    # nothing to do if there is no data or if a single tow
    # plot( depth~timestamp, x)
    return(x)  # do nothing
  }

  print( "Multiple tows in one file, breaking into separate data streams and adding a numeric suffix to file name ...")

  tn = 0
  for ( ti in i) {
    tn = tn + 1
    j = which( x$timestamp >= x$timestamp[i0[ti]] &  x$timestamp <= x$timestamp[i1[ti]] )
    fnj =  paste(fn0, tn, sep=".")
    x$nm_id[j] = fnj
    print( fnj )
  }

  todrop = which(  x$nm_id == fn0 )
  if (length(todrop) > 0 ) x=x[-todrop,]

  return(x)
}


# ---- Download WDI package and install

# --- Install World Development Indicators API if not already installed
install.packages("WDI")

# --- Clear the workspace
remove(list = ls())

# --- Load libraries & set working directory
libs <- c ("ggplot2", "dplyr", "RColorBrewer", "grid", "WDI", "zoo", "lubridate")

# --- Load required libraries
lapply(libs, require, character.only=T)

# --- Search WDI database for urban population variables
WDIsearch('urban population')

# --- Extract urban population variable into new data frame
# Select extra = TRUE to extract extra variables and use tbl_df for dplyr
d <- tbl_df(WDI(country = "all", indicator = "SP.URB.TOTL.IN.ZS",
         start = 1960, end = 2010, extra = TRUE, cache = NULL))

# Remove "(developing only)" from country name
d$country <- gsub("(developing only)", "", d$country, fixed = TRUE)

# --- Browse the names to get a sense of what is in the data
head(d)
tail(d)
unique(d$iso3c)

# --- Looking for EAP, ECA, LAC, MENA, SA, SSA using dplyr and ISO3 codes
#     see http://data.worldbank.org/developers/api-overview?print&book_recurse
fd <- filter(d, iso3c == "EAP" | iso3c == "ECA" | iso3c == "LAC" |
          iso3c == "MNA" | iso3c == "SSA" ) %>%
          arrange(country, year)

# Define Global Development Lab Colors for potential use
# Lab RGB colors
redL   	<- c("#B71234")
dredL 	<- c("#822443")
dgrayL 	<- c("#565A5C")
lblueL 	<- c("#7090B7")
dblueL 	<- c("#003359")
lgrayL	<- c("#CECFCB")

# --- Make first basic spaghetti plot of data
p <- ggplot(fd, aes(y = SP.URB.TOTL.IN.ZS, x = year, colour = country)) +
       geom_path(alpha = 0.1) + geom_point(aes(size = (SP.URB.TOTL.IN.ZS/10)))

# --- Customize plot
pp <- p + theme(legend.position = "top", legend.title=element_blank(),
          panel.border = element_blank(), legend.key = element_blank(),
          legend.text = element_text(size = 13), #Customize legend
          plot.title = element_text(hjust = 0, size = 16, face = "bold"), # Adjust plot title
          panel.background = element_rect(fill = "white"), # Make background white
          panel.grid.major = element_blank(), panel.grid.minor = element_blank(), #remove grid
          axis.ticks.y = element_blank(), #Remove axis
          axis.text.y = element_text(hjust = -0.5, size = 12, colour = dgrayL), #soften axis text
          axis.text.x = element_text(hjust = 1, size = 12, colour = dgrayL),
          axis.ticks.x=element_blank(), # remove x-axis ticks
          #plot.margin = unit(c(1,1,1,1), "cm"),
          plot.title = element_text(lineheight = .8)) + # Move plot title up
          scale_x_continuous(breaks = seq(1960, 2015, 5), expand = c(0.02,0.02)) + #customize x-axis
          scale_y_continuous(breaks = seq(10, 80, 10)) + # customize y-axis
          labs(x = "", y = "Urban population (% of total)\n",
          title = "Urbanization rose the fatest in East Asia and the Pacific", size = 14) +
          scale_colour_brewer(palette="Set1")
pp

# --- Make first basic spaghetti plot of data
p <- ggplot(fd, aes(y = SP.URB.TOTL.IN.ZS, x = year, colour = country)) +
  geom_line(alpha = 0.1) + geom_point(size = 3.5)
p <- p + theme(legend.position = "top", legend.title=element_blank(),
               panel.border = element_blank(), legend.key = element_blank(),
               legend.text = element_text(size = 13), #Customize legend
               plot.title = element_text(hjust = 0, size = 16, face = "bold"), # Adjust plot title
               panel.background = element_rect(fill = "white"), # Make background white
               panel.grid.major = element_blank(), panel.grid.minor = element_blank(), #remove grid
               axis.ticks.y = element_blank(), #Remove axis
               axis.text.y = element_text(hjust = -0.5, size = 12, colour = dgrayL), #soften axis text
               axis.text.x = element_text(hjust = 1, size = 12, colour = dgrayL),
               axis.ticks.x=element_blank(), # remove x-axis ticks
               #plot.margin = unit(c(1,1,1,1), "cm"),
               plot.title = element_text(lineheight = .8)) + # Move plot title up
               scale_x_continuous(breaks = seq(1960, 2010, 10), expand = c(0.02,0.02)) + #customize x-axis
               scale_y_continuous(breaks = seq(0, 80, 10)) + # customize y-axis
               labs(x = "", y = "Urban population (% of total)\n",
               title = "Urbanization rose the fatest in East Asia and the Pacific", size = 14) +
               scale_colour_brewer(palette="Set1") + facet_wrap(~country, ncol =5)

# --- Look at regional values
p <- ggplot(d, aes(y = SP.URB.TOTL.IN.ZS, x = year, colour = region)) +
  geom_path(alpha = 0.9) + facet_wrap(~region) + theme(legend.position = "top")

p


pdf_file<-"pdf/piecharts_1x4.pdf"
cairo_pdf(bg="grey98", pdf_file,width=14,height=6)

library(plotrix)
par(omi=c(0.5,0.5,1,0.5),mai=c(0,0,0,0),xpd=T,mfcol=c(1,4),family="Lato Light",las=1)

# Import data

source("scripts/inc_data_dfg.r")

# Define charts and other elements

for (i in 1:4)
{
plot(1:5,type="n",axes=F,xlab="",ylab="")
values<-c(x[2,i]-y[2,i],y[2,i])
myCircle<-floating.pie(3,3,values,border="white",radius=2.1*sqrt(x[1,i]/max(x[1,])),col=c(myColours1[i],myColours2[i]))
pie.labels(3,3,myCircle,values,bg=NA,border=NA,radius=x[1,i]/max(x[1,]),cex=2,col="white")
if (i==1) pie.labels(3,3,myCircle,c("rejected","granted"),bg=NA,border=NA,radius=1.95,font=3)
text(3,4.7,cex=2,adj=0.5,paste(format(round(100*y[2,i]/x[1,i],1),nsmall=1),"%",sep=" "))
text(3,1.2,labelling[i],cex=2,adj=0.5)
}

# Titling

mtext("DFG grants 2010",3,line=4,adj=0,family="Lato Black",outer=T,cex=2)
mtext("Individual grants by science sector, values in million Euro. Percent values: approval ratio",3,line=1,adj=0,cex=1.35,font=2,outer=T)
mtext("Source: DFG Information Cards 2011, www.dfg.de",1,line=2,adj=1.0,cex=1.1,font=3,outer=T)
dev.off()


p<-Read.OP.par()

# find max SSB
a<-Read.summary.data()
a<-subset(a,select=c(Species.n,Year,SSB),Quarter==1)
a<-aggregate(SSB~Species.n+Year,data=a,sum)
a<-aggregate(SSB~Species.n,data=a,max)

a<-merge(a,p)

cleanup()
nox<-4; noy<-4;
noxy<-nox*noy

newplot(dev='screen',nox,noy)
par(mar=c(4,4,3,2))  #bottom, left, top, right

for (sp in (first.VPA:nsp)){
 sp.name<-sp.names[sp]
 b<-subset(a,Species.n==sp)
 do.plot<-F
 if (b[1,'HCR']==1) {
   SSB<-c(0,b[1,'SSB'])/1000
   Fi<-rep(b[1,'Ftarget'],2)
   do.plot<-T
 }
 else if (b[1,'HCR']==2) {
   SSB<-c(0,b[1,'T1'],b[1,'T2'],max(b[1,'SSB'],b[1,'T2']))/1000
   Fi<-c(0,0,b[1,'Ftarget'],b[1,'Ftarget'])
   do.plot<-T
 }
 else if (b[1,'HCR']==3) {
   maxSSB<-max(b[1,'SSB'],b[1,'T2'])
   SSB<-c(0,b[1,'T1'],b[1,'T2'],maxSSB)/1000
   Fi<-c(0,0,b[1,'Ftarget'],b[1,'Ftarget']+(maxSSB-b[1,'T2'])/b[1,'T2']*b[1,'Fslope'])
   do.plot<-T
 }
 else if (b[1,'HCR']==4) {
   maxSSB<-max(b[1,'SSB'],b[1,'T2'])
   SSB<-seq(0,maxSSB,maxSSB/100)/1000
   Fi<-b[1,'Ftarget']/(1+exp(b[1,'S1'] - b[1,'S1']/b[1,'SSB50']*SSB))
   do.plot<-T
 }

 if (do.plot) plot(SSB,Fi,xlab='SSB (1000 t)',ylab='F',type='l',lwd=2,main=sp.name)
 if (b[1,'HCR']==4) abline(v=b[1,"SSB50"],lty=2,lwd=2)
}


repo = "http://cran.us.r-project.org"
library(caret)
library(ggfortify)
library(ggplot2)
library(dplyr)
library(RSQLite)
library(DBI)
library(class)
library(MASS)
# library(pscl)
library(nnet)
library(randomForest)
library(e1071)

run_model = function(model_type, trn_data, trn_in_data, trn_out_data, tst_in_data, tst_out_data, fmla){
  if (model_type != 'rf' & model_type != 'zeroinf'){
  print('normalizing')
	train_col_stds = apply(trn_in_data, 2, sd)
	train_col_means = colMeans(trn_in_data)

	train_normalized = t((t(trn_in_data)-train_col_means)/train_col_stds)
	test_normalized = t((t(tst_in_data)-train_col_means)/train_col_stds)

	pca = prcomp(train_normalized)

	trn_preprocessed = predict(pca, train_normalized)
	tst_preprocessed = predict(pca, test_normalized)

	fmla = as.formula(paste(out_col_name, "~", paste(colnames(trn_preprocessed), collapse="+")))

	train_data = cbind(as.data.frame(trn_preprocessed), num_flooded = model_data[prt$Resample1, out_col_name])
	trn_in_data = trn_preprocessed
	tst_in_data = tst_preprocessed
  	if (model_type == 'poisson'){output = glm(fmla, data=train_data, family = poisson)}
  	else if (model_type == 'quasipoisson'){output = glm(fmla, data=train_data, family = quasipoisson)}
	  else if (model_type == 'negb'){output = glm.nb(fmla, data=train_data)}
	  else if (model_type == 'ann'){
	    num_units_in_hidden_layers = 10 # called M in our notes and text
	    range_for_initial_random_weights = 0.7 # see next three lines of comments
	    weight_decay = 5e-1 # weight decaay to avoid overfitting
	    maximum_iterations = 400 # maximum number of iterations in training
	    output = nnet(fmla, data=train_data,
	                  size = num_units_in_hidden_layers,
	                  rang = range_for_initial_random_weights,
	                  decay = weight_decay,
	                  maxit = maximum_iterations)
	    }
	  else if (model_type == 'svm'){output = svm(fmla, data=train_data)}

  }
  else if (model_type == 'rf'){
	output = randomForest(fmla, data=trn_data, importance = TRUE, ntree=500, mtry=16)
	impo = as.data.frame(output$importance)
	impo = impo[,1]
  }

  pred_trn = predict(output, newdata = as.data.frame(trn_in_data), type='response')

  pred_tst = predict(output, newdata = as.data.frame(tst_in_data), type='response')
  if (model_type == 'rf'){
       return(list(pred_trn, pred_tst, impo))
  }
  else {
       return(list(pred_trn, pred_tst))
  }

}

remove_cols= function(l, cols){
    return(l[! l %in% cols])
}

clear_db_tables = function(models, con, suffix){
  db_table_list = dbListTables(con)
  for (model in models){
    table_suffixes = c('train', 'test')
    for (t in table_suffixes){
      table = paste(model, '_', suffix, '_', t, sep="")
      if (table %in% db_table_list){
        dbGetQuery(con, paste("DROP TABLE", table))
      }
    }
  }
}

base_dir<- "C:/Users/Jeff/Documents/research/Sadler_3rdPaper/manuscript/"
data_dir<- "C:/Users/Jeff/Google Drive/research/Sadler_3rdPaper_Data/"
fig_dir <- paste(base_dir, "Figures/general/", sep="")
db_filename <- "floodData.sqlite"

con = dbConnect(RSQLite::SQLite(), dbname=paste(data_dir, db_filename, sep=""))

df = dbReadTable(con, 'for_model_avgs')

colnames(df)

set.seed(5)

df = df[df[,'rd']>0.01,]

cols_to_remove = c('event_name', 'event_date', 'num_flooded')
in_col_names = remove_cols(colnames(df), cols_to_remove)
out_col_name = 'num_flooded'

model_data = df[, append(in_col_names, out_col_name)]
model_data = na.omit(model_data)

import_df = data.frame(matrix(nrow=length(in_col_names)))
all_pred_tst = c()
all_pred_trn = c()
all_tst = c()
all_trn = c()
fomla = as.formula(paste(out_col_name, "~", paste(in_col_names, collapse="+")))
model_types = c('rf', 'poisson')
suffix = 'revisions2_500'
clear_db_tables(model_types, con, suffix)
tuned_list = data.frame(matrix(ncol=2, nrow=0), colnames(c("mtry", "OOBError")))
for (i in 1:101){
  prt = createDataPartition(model_data[, out_col_name], p=0.7)
  train_data = model_data[prt$Resample1,]
  train_in_data = data.frame(train_data[, in_col_names])
  colnames(train_in_data) = in_col_names
  train_out_data = train_data[, out_col_name]
  test_in_data = data.frame(model_data[-prt$Resample1, in_col_names])
  colnames(test_in_data) = in_col_names
  test_out_data = model_data[-prt$Resample1, out_col_name]

  for (model in model_types){
	  print(paste("run: ", i, sep = ''))

    model_results = run_model(model, train_data, train_in_data, train_out_data, test_in_data, test_out_data, fomla)
	  pred_train = model_results[1]
	  pred_test = model_results[2]

	  all_trn_df = data.frame(train_out_data, unlist(pred_train))
	  colnames(all_trn_df) = c('all_trn', 'all_pred_trn')
	  all_tst_df = data.frame(test_out_data, unlist(pred_test))
	  colnames(all_tst_df) = c('all_tst', 'all_pred_tst')
	  dbWriteTable(con, paste(model, '_', suffix, '_train', sep=""), all_trn_df, append=TRUE)
	  dbWriteTable(con, paste(model, '_', suffix, '_test', sep=""), all_tst_df, append=TRUE)

	  if (model == 'rf'){
      impo = model_results[3]
	    import_df = cbind(import_df, impo)
	  }
	}
}
colnames(import_df) = 1:ncol(import_df)
row.names(import_df) = in_col_names
dbWriteTable(con, paste('rf_impo_', suffix, sep=""), import_df, overwrite=TRUE)


 #SNOPSIS

 #runs genetic correlation analyis.
 #correlation coeffiecients are stored in tabular and json formats

 #AUTHOR
 # Isaak Y Tecle (iyt2@cornell.edu)

options(echo = FALSE)

library(ltm)
#library(rjson)
library(jsonlite)
library(methods)
library(dplyr)
library(tibble)

allArgs <- commandArgs()

outputFiles <- scan(grep("output_files", allArgs, value = TRUE),
                    what = "character")

inputFiles  <- scan(grep("input_files", allArgs, value = TRUE),
                    what = "character")

correTableFile <- grep("genetic_corre_table", outputFiles, value=TRUE)
correJsonFile  <- grep("genetic_corre_json", outputFiles, value=TRUE)

geneticDataFile <- grep("combined_gebvs", inputFiles, value=TRUE)

selectionIndexFile <- grep("selection_index", inputFiles, value=TRUE)

geneticData <- read.table(geneticDataFile,
                          header = TRUE,
                          row.names = 1,
                          sep = "\t",
                          na.strings = c("NA"),
                          dec = "."
                          )

indexData <- c()

if (length(selectionIndexFile) != 0
    && file.info(selectionIndexFile)$size != 0) {
    indexData <- read.table(selectionIndexFile,
                            header = TRUE,
                            row.names = 1,
                            sep = "\t",
                            na.strings = c("NA"),
                            dec = "."
                            )
}

corrData <- c()

if (!is.null(indexData)) {
    geneticData <- rownames_to_column(geneticData, var="genotypes")
    indexData   <- rownames_to_column(indexData, var="genotypes")

    geneticData <- geneticData %>% arrange(genotypes)
    indexData   <- indexData %>% arrange(genotypes)

    corrData <- full_join(geneticData, indexData)
    corrData <- column_to_rownames(corrData, var="genotypes")

} else {
    corrData <- geneticData
}

coefpvalues <- rcor.test(corrData,
                         method="pearson",
                         use="pairwise"
                         )

coefficients <- coefpvalues$cor.mat
allcordata   <- coefpvalues$cor.mat

allcordata[lower.tri(allcordata)] <- coefpvalues$p.values[, 3]
diag(allcordata) <- 1.00

pvalues <- as.matrix(allcordata)
pvalues <- round(pvalues,
                 digits=2
                 )

coefficients <- round(coefficients,
                      digits=3
                      )

allcordata <- round(allcordata,
                    digits=3
                    )

#remove rows and columns that are all "NA"
if (apply(coefficients, 1, function(x) any(is.na(x))) ||
    apply(coefficients, 2, function(x) any(is.na(x)))) {

    coefficients <- coefficients[-which(apply(coefficients, 1, function(x) all(is.na(x)))),
                                 -which(apply(coefficients, 2, function(x) all(is.na(x))))]
}

pvalues[upper.tri(pvalues)]           <- NA
coefficients[upper.tri(coefficients)] <- NA
coefficients <- data.frame(coefficients)

coefficients2json <- coefficients
names(coefficients2json) <- NULL

traits <- colnames(coefficients)

correlationList <- list(
    labels = traits,
    values  = coefficients
)

correlationJson <- jsonlite::toJSON(correlationList)

write.table(coefficients,
      file=correTableFile,
      col.names=TRUE,
      row.names=TRUE,
      quote=FALSE,
      dec="."
      )

write(correlationJson,
       file = correJsonFile)

q(save = "no", runLast = FALSE)


###############################################################################
##                                                                           ##
##  Exploratory Data Analysis                                                ##
##  Project 01                                                               ##
##  Plot 04                                                                  ##
##                                                                           ##
###############################################################################

#
# Read in all data
# Note: if you ran my code for an earlier plot you can skip to below
#

data <- read.csv(file = "./data/household_power_consumption.txt",
                 header = TRUE,
                 sep = ";",
                 na.strings = "?")

#
# Add in new column DateC that converts data$Date from factor to date
#

data$DateC <- as.Date(data$Date, format="%d/%m/%Y")

#
# Subset for our dates of interest
#

data <- subset(data, subset=(DateC >= "2007-02-01" & DateC <= "2007-02-02"))

#
# Consider time...
#

data$DateC <- as.POSIXct(paste(data$DateC, data$Time))

#
# OK, DateC now has date and time data, let's make plots and save them to png
# NOTE: If you ran my code for another plot then you can start here
#

png(filename = "./data/plot4.png",
    width = 480,
    height = 480)

#
# So now we're doing a panel plot, and the left column plots are
#    plots 2 and 3... so we'll set mfcol and copy the code for these
#    plots first then do the other 2
# And I'm using the margins and outer margins from the lectures...
# Note that there was a small change to the ylabel for the first plot
#  and that the box for the legend was removed for the second plot
#

par(mfcol = c(2, 2),
    mar = c(4, 4, 2, 1),
    oma = c(0, 0, 2, 0))

# From plot2.r - Upper left plot
plot(x = data$DateC,
     y = data$Global_active_power,
     type = "l",
     xlab="",
     ylab="Global Active Power")

# From plot3.r - Lower left plot
plot(x = data$DateC,
     y = data$Sub_metering_1,
     type = "l",
     xlab="",
     ylab="Energy sub metering")
lines(x = data$DateC,
      y = data$Sub_metering_2,
      type = "l",
      col = "red")
lines(x = data$DateC,
      y = data$Sub_metering_3,
      type = "l",
      col = "blue")
legend(x = "topright",
       legend = c("Sub_metering_1", "Sub_metering_2", "Sub_metering_3"),
       col = c("black", "red", "blue"),
       lty = 1,
       lwd = 2,
       bty = "n")

# Upper right plot
plot(x = data$DateC,
     y = data$Voltage,
     type = "l",
     xlab = "datetime",
     ylab = "Voltage")

# Lower right plot
plot(x = data$DateC,
     y = data$Global_reactive_power,
     type = "l",
     xlab = "datetime",
     ylab = "Global_reactive_power")

dev.off()


require(sdcMicro)
data <- readMicrodata(path="C:/Users/prasser/git/suda2/data/ihsn.csv", type="csv", header=FALSE, sep=";")
su <- suda2(data)
su$score
su$disScore


#Similarity matrix as a single functions
similarity_taxon <- function(S0, wt, taxa) {
    # Note: the similarity on the diagonal has to be set to 1 since it's all the same species.
    # taxa is either resource or consumer

    similarity.matrix <- matrix(nrow = nrow(S0), ncol = nrow(S0), dimnames = list(S0[, 'taxon'], S0[, 'taxon']))

    taxonomy <- vector("list",nrow(S0))
    taxon <- vector("list",nrow(S0))
    for(i in 1:nrow(S0)) {
      taxonomy[[i]] <- unlist(strsplit(S0[i, 'taxonomy'], " \\|\\ "))
      if(length(which(taxonomy[[i]] == "NA")) > 0) {
          taxonomy[[i]] <- taxonomy[[i]][-which(taxonomy[[i]] == "NA")]
      }

      if(taxa == 'consumer') {
          taxon[[i]] <- unlist(strsplit(S0[i, 'resource'], " \\|\\ "))
      } else if(taxa == 'resource') {
          taxon[[i]] <- unlist(strsplit(S0[i, 'consumer'], " \\|\\ "))
      }
    }

    pb <- txtProgressBar(min = 0,max = nrow(S0), style = 3)

    for(i in 1:nrow(S0)){
      for(j in i:nrow(S0)){ #No need to evaluate both side of the matrix diagonal for the similarity matrix
          similarity.matrix[i,j] <- similarity.matrix[j,i] <- tanimoto_traits(resource_x = taxon[[i]],
                                                                              resource_y = taxon[[j]],
                                                                              trait_x = taxonomy[[i]],
                                                                              trait_y = taxonomy[[j]],
                                                                              trait_weight = wt
                                                                              )
      }#j
    setTxtProgressBar(pb, i)
    }#i
    close(pb)

    diag(similarity.matrix) <- 1

  return(similarity.matrix)
}#similarity_taxon function