if (!("shiny" %in% names(installed.packages()[,"Package"]))) {install.packages("shiny")}
suppressMessages(library(shiny, quietly = TRUE))

if (!("openintro" %in% names(installed.packages()[,"Package"]))) {install.packages("openintro")}
suppressMessages(library(openintro, quietly = TRUE))

if (!("plotrix" %in% names(installed.packages()[,"Package"]))) {install.packages("plotrix")}
suppressMessages(library(plotrix, quietly = TRUE))

library(stats)
library(dygraphs)
library(datasets)
library(xts)
library(forecast)
library(fANCOVA)

#Aqui empieza

shinyServer(function(input, output,session) {

#Carga de datos desde un archivo
  data <- reactive({
    req(input$file1) ## ?req #  require that the input is available

    inFile <- input$file1
    if (!(is.null(inFile))){
      #Se lee un archivo con los parametros selecionados y se se carga en un dataframe
      df <- read.csv(inFile$datapath, header = input$header, sep = input$sep,
                     quote = input$quote, dec= input$deci )
      ejex <-  1:nrow(df)
      ejey <- as.numeric(df$V1)
      if (input$frec == 'days') f <- 365
      if (input$frec == 'month') f <- 12
      if (input$frec == 'quarter') f <- 4
      if (input$frec == 'years') f <- 1
      serie=ts(ejey,freq=f, start=input$fecha)
      return(serie)
    }
    else{return = NULL}
  })

  #Carga ventana de datos
  dataw <- reactive({
    req(input$file1) ## ?req #  require that the input is available
    d <- data()
    #ventana de tiempo
    inicioS <- strftime(input$fecha, "%Y-%m-%d")
    inicioV <- strftime(req(input$dygraph_date_window[[1]]), "%Y-%m-%d")
    finV <- strftime(req(input$dygraph_date_window[[2]]), "%Y-%m-%d")
    dia.nuevo.inicio <- difftime(inicioV, inicioS, units = "days") + 1
    dias.nuevaserie <- difftime(finV, inicioV, units = "days")
    dia.nuevo.fin <- dia.nuevo.inicio + dias.nuevaserie
    nuevadata <- as.matrix(d[dia.nuevo.inicio:dia.nuevo.fin])
    ejex <-  1:nrow(nuevadata)
    if (input$frec == 'days') f <- 365
    if (input$frec == 'month') f <- 12
    if (input$frec == 'quarter') f <- 4
    if (input$frec == 'years') f <- 1
    serie=ts(nuevadata,freq=f, start=input$fecha)
    return(serie)
  })

# grafica la serie con dygraphs
  output$dygraph <- renderDygraph({
    inFile <- input$file1
    if (!(is.null(inFile))){
    df <- data()
    ny <- as.matrix(df)
    Date <- seq(input$fecha, length= length(ny), by=input$frec)#preguntar a Aldo para cambiar con frecu
    ndf <- data.frame(ny, Date)
    yxts <- xts(ndf$ny, order.by = ndf$Date, frecuency = input$frec)

    dygraph(yxts, main = "Serie Usuario") %>%
    dyRangeSelector()
    }
  })

  output$from <- renderText({
    strftime(req(input$dygraph_date_window[[1]]), "%Y-%m-%d")
  })

  output$to <- renderText({
       strftime(req(input$dygraph_date_window[[2]]), "%Y-%m-%d")
  })

# Modelos para evaluar

  #Regresion lineal
  lmResults <- reactive({
    d <- data()
    t <- seq(1:length(d))
    It <- seasonaldummy(d)
    It2 <- seasonaldummy(log(d))

    if (!(input$est)){
      if (input$tipo == "Aditivos"){
        if(input$metodo == "Lineal"){
          return <- lm(formula = d ~ t)
        }
        else{
          if(input$metodo == "Cuadratico"){
            tt <- t^2
            return <- lm(formula = d ~ t + tt)
          }
          else{
            if(input$metodo == "Cubico"){
              tt <- t^2
              ttt <- t^3
              return <- lm(formula = d ~ t + tt + ttt)
            }
            else{
              if(input$metodo == "Orden 4"){
                #TENDENCIA Grado cuarta
                tt <- t^2
                ttt <- t^3
                tttt <- t^4
                return <- lm(formula = d ~ t + tt + ttt + tttt)
              }
            }
          }
        }
      }# fin if aditivos
      else{
        if (input$tipo == "Multiplicativos"){
          if(input$metodo == "Lineal"){
            return <- lm(formula = log(d) ~ t)
          }
          else{
            if(input$metodo == "Cuadratico"){
              tt <- t^2
              return <- lm(formula = log(d) ~ t + tt)
            }
            else{
              if(input$metodo == "Cubico"){
                #TENDENCIA CUBICA
                tt <- t^2
                ttt <- t^3
                return <- lm(formula = log(d) ~ t + tt + ttt)
              }
              else{
                if(input$metodo == "Orden 4"){
                  #TENDENCIA Grado cuarta
                  tt <- t^2
                  ttt <- t^3
                  tttt <- t^4
                  return <- lm(formula = log(d) ~ t + tt + ttt + tttt)
                }
              }
            }
          }
        }# fin if multiplicativos
      }
    }
    else{ # es el bloque para los estacionarios
      if (input$tipo == "Aditivos"){
        if(input$metodo == "Lineal"){
          return <- lm(formula = d ~ t + It)
        }
        else{
          if(input$metodo == "Cuadratico"){
            tt <- t^2
            return <- lm(formula = d ~ t + tt + It )
          }
          else{
            if(input$metodo == "Cubico"){
              tt <- t^2
              ttt <- t^3
              return <- lm(formula = d ~ t + tt + ttt + It)
            }
            else{
              if(input$metodo == "Orden 4"){
                #TENDENCIA Grado cuarta
                tt <- t^2
                ttt <- t^3
                tttt <- t^4
                return <- lm(formula = d ~ t + tt + ttt + tttt + It)
              }
            }
          }
        }
      }# fin if aditivos
      else{
        if (input$tipo == "Multiplicativos"){
          if(input$metodo == "Lineal"){
            return <- lm(formula = log(d) ~ t + It2)
          }
          else{
            if(input$metodo == "Cuadratico"){
              tt <- t^2
              return <- lm(formula = log(d) ~ t + tt + It2)
            }
            else{
              if(input$metodo == "Cubico"){
                #TENDENCIA CUBICA
                tt <- t^2
                ttt <- t^3
                return <- lm(formula = log(d) ~ t + tt + ttt + It2)
              }
              else{
                if(input$metodo == "Orden 4"){
                  #TENDENCIA Grado cuarta
                  tt <- t^2
                  ttt <- t^3
                  tttt <- t^4
                  return <- lm(formula = log(d) ~ t + tt + ttt + tttt + It2)
                }
              }
            }
          }
        }# fin if multiplicativos
      }
    }

  })

  #REGRESION_show plots
  output$scatter <- renderPlot({
    y <- data()
    x <- seq(1:length(y))

    datos.entreno <- dataw()

    #used for confidence interval
    xcon <- seq(min
                (x), max(x), 1)

    predictor <- data.frame(x=xcon)

    if(input$tipo == "Multiplicativos"){
      yhat2 <- predict(lmResults())
      yhat <- exp(yhat2)
      yline2 <- predict(lmResults(), predictor)
      yline <- exp(yline2)
      r.squared = round(summary((lmResults()))$r.squared, 4)
      newx <- seq(min(x), max(x), length.out=length(x))
      confs2 <- predict((lmResults()), newdata = data.frame(x=newx),
                       interval = 'confidence')
      confs <- exp(confs2)
      preds2 <- predict(lmResults(), newdata = data.frame(x=newx),
                       interval = 'predict')
      preds <- exp(preds2)
    }
    else{
      if(input$tipo =="Aditivos"){
        yhat <- predict(lmResults())
        yline <- predict(lmResults(), predictor)
        r.squared = round(summary(lmResults())$r.squared, 4)
        newx <- seq(min(x), max(x), length.out=length(x))
        confs <- predict(lmResults(), newdata = data.frame(x=newx),
                         interval = 'confidence')
        preds <- predict(lmResults(), newdata = data.frame(x=newx),
                         interval = 'predict')

      }
    }

    par(cex.main=1, cex.lab=1, cex.axis=1, mar = c(4,4,4,1))
    corr.coef = round(sqrt(r.squared), 4)

    plot(c(min(x),max(x))
         ,c(min(y,yline),max(y,yline)),
         type="n",
         xlab="x",
         ylab="y",
         main=paste0("Modelo de Regresion\n","(R = ", corr.coef,", ", "R-cuadrado = ", r.squared,")"))

    polygon(c(rev(newx), newx), c(rev(preds[ ,3]), preds[ ,2]), col = grey(.95), border = NA)
    polygon(c(rev(newx), newx), c(rev(confs[ ,3]), confs[ ,2]), col = grey(.60), border = NA)

    points(x,y,pch=21, col=COL[1,4])
    lines(xcon, yline, lwd=1, col="red")

    if (input$show.resid) for (j in 1:length(x))
      lines(rep(x[j],2), c(yhat[j],y[j]), col=COL[4])

    legend_pos = ifelse(lmResults()$coefficients[1] < 1, "topleft", "topright")
    # if(input$type == "linear.down") legend_pos = "topright"
    #if(input$type == "fan.shaped") legend_pos = "topleft"
    legend(legend_pos, inset=.05,
           legend=c(length(datos.entreno), "AQUI SE LEEN LOS RESULTADOS", "AQUI SE LEEN LOS RESULTADOS"),
           fill=c(COL[1],grey(.75),grey(.95)))
    box()
  })

  output$residuals <- renderPlot({
    par(mfrow=c(1,3), cex.main=1.3, cex.lab=1.3, cex.axis=1.3, mar=c(4,5,2,2))
    residuals = residuals(lmResults())
    predicted = predict(lmResults(), newdata = data.frame(x=data()))
    plot(residuals ~ predicted,
         main="Residuales vs. Valores Ajustados", xlab="Valores Ajustados", ylab="Residuales",
         pch=19, col = COL[1,2])
    abline(h = 0, lty = 2)
    d = density(residuals)$y
    h = hist(residuals, plot = FALSE)
    hist(residuals, main="Histograma de Residuales", xlab="Residuales",
         col=COL[1,2], prob = TRUE, ylim = c(0,max(max(d), max(h$density))))
    lines(density(residuals), col = COL[1], lwd = 2)
    qqnorm(residuals, pch=19, col = COL[1,2], main = "Normal Q-Q Plot de Residuales")
    qqline(residuals, col = COL[1], lwd = 2)
  }, height=280 )

  #Modelo Holt Winters
  hwResults <- reactive({
    p <- data()
    demand <- ts(p, start = c(2000, 1), frequency = 365)
    t <- seq(1:length(demand))

    if (input$tipohw == "Multiplicativos"){
      return <- HoltWinters(demand, alpha=NULL, beta=NULL, gamma=NULL, seasonal = "multiplicative")
    }
    else{
      if(input$tipohw == "Aditivos"){
        return <- HoltWinters(demand, alpha=NULL, beta=NULL, gamma=NULL, seasonal = "additive")
      }
    }

  })

  # HOLT WINTERS_Show plot
  output$scatter2 <- renderPlot({
    o <- data()
    demand2 <- ts(log(o), start = c(2000, 1), frequency = 365)
    t <- seq(1:length(demand2))

    pred <- predict(hwResults(), n.ahead = 730, prediction.interval = T, level = 0.95)

    plot(hwResults(),pred, col=1)
    lines(fitted(hwResults())[,1], col=2)
    #plot(x=t,y=o,col=1, type="l")
    #plot(x=t,y=hwResults(), col=3)
    #lines(fitted(hwResults())[,1], col=2)

    #if (input$tipohw == "Multiplicativos"){
    #y <- log(y)
    #}
    #x <- seq(1:length(y))
    #plot(x,y, col=1)
    #lines(hwResults(), col=3)
    #lines(fitted(hwResults())[,1], col=2)
    #all <- cbind(yy)
    #ny <- as.matrix(y)
    #Date <- seq(1, length= length(ny), by=365)#preguntar a Aldo para cambiar con frecu
    #ndf <- data.frame(ny, Date)
    #yxts <- xts(ndf$ny, order.by = ndf$Date, frecuency = input$frec)
    #dygraph(yxts, pred) %%
    #dySeries("y", label="Actual") %%
    #dySeries(c("p.lwr", "p.fit", "p.upr"), label = "Predicted")
  })

  output$residuals2 <- renderPlot({
    par(mfrow=c(1,3), cex.main=1.3, cex.lab=1.3, cex.axis=1.3, mar=c(4,5,2,2))
    residuals = residuals(hwResults())
    plot(residuals,
         main="Residuales", xlab="Valores Ajustados", ylab="Residuales",
         pch=19, col = COL[1,2])
    abline(h = 0, lty = 2)
    d = density(residuals)$y
    h = hist(residuals, plot = FALSE)
    hist(residuals, main="Histograma de Residuales", xlab="Residuales",
         col=COL[1,2], prob = TRUE, ylim = c(0,max(max(d), max(h$density))))
    lines(density(residuals), col = COL[1], lwd = 2)
    qqnorm(residuals, pch=19, col = COL[1,2], main = "Normal Q-Q Plot de Residuales")
    qqline(residuals, col = COL[1], lwd = 2)
  }, height=280 )

  #LOESS y Descomposicion
  loResults1 <- reactive({
    d <- data()
    o <- ts(d, start = c(2000, 1), frequency = 365)
    t <- seq(1:length(d))
    tnuevo <- (length(d)+1):(length(d)+730)
    Tt <- 1
    St <- 1

    factoresdeltai=function(descom,s,estacioni){
      if(estacioni==1){
        deltasi=descom$figure
      }
      if(estacioni!=1){
        j=estacioni;deltasi=c(descom$figure[(s-j+2):s],descom$figure[1:(s-j+1)])
      }
      deltasi
    }

    if (input$tipolo == "Lineal") grado <- 1
    if (input$tipolo == "Cuadratico") grado <- 2
    if (input$tipob == "Aditivos"){
      comp <- "additive"
      ecu <- o-St
    }
    if (input$tipob == "Multiplicativos") {
      comp <- "multiplicative"
      ecu <- o/St
    }

    descom=decompose(o,type = comp)
    St=descom$seasonal
    deltas_i=factoresdeltai(descom=descom,s=365,estacioni = 1)
    data.frame(deltas_i)
    o.no.St=(ecu)

    ajusteloess=loess.as(t,o.no.St,degree = grado,criterion = "aicc",family = "gaussian",plot = F)
    Tt=ts(fitted(ajusteloess),frequency = 365,start = c(2000,1))
    alpha.optimo=ajusteloess$pars$span #guardando el alpha optimo

    if (input$tipob == "Aditivos"){
      modelo <- Tt+St
    }
    if (input$tipob == "Multiplicativos"){
      modelo <- Tt*St
    }
    return(modelo)
  })

  loResults2 <- reactive({
    d <- data()
    o <- ts(d, start = c(2000, 1), frequency = 365)
    t <- seq(1:length(d))
    tnuevo <- (length(o)+1):(length(o)+1395)
    Ttnuevo <- 1
    Stnuevo <- 1

    factoresdeltai=function(descom,s,estacioni){
      if(estacioni==1){
        deltasi=descom$figure
      }
      if(estacioni!=1){
        j=estacioni;deltasi=c(descom$figure[(s-j+2):s],descom$figure[1:(s-j+1)])
      }
      deltasi
    }

    if (input$tipolo == "Lineal") grado <- 1
    if (input$tipolo == "Cuadratico") grado <- 2
    if (input$tipob == "Aditivos"){
      comp <- "additive"
      ecu <- o-Stnuevo
    }
    if (input$tipob == "Multiplicativos") {
      comp <- "multiplicative"
      ecu <- o/Stnuevo
    }

    descom=decompose(o,type = comp)
    St=descom$seasonal
    deltas_i=factoresdeltai(descom=descom,s=365,estacioni = 1)
    data.frame(deltas_i)
    o.no.St=(ecu)

    ajusteloess=loess.as(t,o.no.St,degree = grado,criterion = "aicc",family = "gaussian",plot = F)
    Tt=ts(fitted(ajusteloess),frequency = 365,start = c(2000,1))
    alpha.optimo=ajusteloess$pars$span #guardando el alpha optimo

    l <- seq(1:365)
    i=c(l,l,l) #identificando la estacion correspondiente a los m=15 periodos de pronostico
    Stnuevo=deltas_i[i] #asignando los delta_i a los periodos a pronosticar
    Stnuevo=ts(Stnuevo,frequency=365,start=c(2010,365)) #convertimos en serie el pronostico de St

    o.no.St=(ecu)

    Ttnuevo=predict(loess(o.no.St~t,span = alpha.optimo, degree = grado,control = loess.control(surface = "direct")),data.frame(t=tnuevo),se=FALSE)
    Ttnuevo=ts(Ttnuevo,frequency=365,start = c(2010,365)) #Convirtiendo en serie de tiempo al pronostico de Tt

    if (input$tipob == "Aditivos"){
      modelopron <- Ttnuevo+Stnuevo
    }
    if (input$tipob == "Multiplicativos"){
      modelopron <- Ttnuevo*Stnuevo
    }
    return(modelopron)
  })

  #LOESS
  output$scatter3 <- renderPlot({
    y <- data()
    o <- ts(y, start = c(2000, 1), frequency = 365)

    plot(o,col=1)
    lines(loResults1(), col=2)
    lines(loResults2(), col=3)
    #lines(y.fit.hat2,col=2)
    #legend("topleft",legend=c("Original","Ajustada", "Pronostico"),col=c(1,2,3),lty = 1)

  })
})


library(dplyr)
library(data.table)
library(ggplot2)
library(stringr)
library(glue)
library(parallel)
home_dir = '/home/tenggao'
devtools::load_all(glue('{home_dir}/numbat'))

run_bench = function(df, cell_annot, segs_dna, sample, n_cells = 500, ratios = seq(0, 1, 0.05), seed = 0, gamma = 20, ncores = 10, replace = FALSE) {

    ### simulate cell mixtures and infer haplotypes ###
    message('Simulating mixture pseudobulks .. ')

    set.seed(seed)
    nodes = list()
    cells_train = cell_annot %>% sample_frac(0.7) %>% pull(cell)
    cells_test = cell_annot %>% filter(!cell %in% cells_train) %>% pull(cell)

    for (n in n_cells) {
        for (r in ratios) {
            for (s in 1:5) {

                set.seed(s)

                cells_tumor = cell_annot %>%
                    filter(annot == 'T' & cell %in% cells_train) %>%
                    pull(cell) %>% sample(n * r, replace = replace)

                cells_normal = cell_annot %>%
                    filter(annot == 'N' & cell %in% cells_train) %>%
                    pull(cell) %>% sample(n * (1-r), replace = replace)

                nodes[[paste0(r, '_', s, '_', n)]] = list(cells = c(cells_tumor, cells_normal), members = s, label = r, size = n)
            }
        }
    }

    bulks_mixture = mclapply(
        nodes,
        mc.cores = ncores,
        function(g) {
            get_allele_bulk(
                df_allele = df %>% filter(cell %in% g$cells),
                genetic_map = genetic_map_hg38,
                lambda = 1
            ) %>%
            mutate(
                seed = g$members,
                ratio = g$label,
                n_cells = g$n_cells
            ) %>%
            annot_consensus(
                segs_dna
            ) %>%
            group_by(CHROM, seg) %>%
            mutate(
                approx_theta_post(pAD, DP, p_s, gamma = gamma, start = 0.1)
            ) %>%
            classify_alleles() %>%
            ungroup()
    })

    ### Scoring cells ###
    message('Scoring cells .. ')
    cell_scores = mclapply(
        bulks_mixture,
        mc.cores = ncores,
        function(bulk) {

            allele_post_naive = get_allele_post(
                bulk,
                segs_dna %>% mutate(seg = factor(seg_cons)),
                df %>% filter(cell %in% cells_test),
                naive = TRUE
            )

            allele_post_phasing = get_allele_post(
                bulk,
                segs_dna %>% mutate(seg = factor(seg_cons)),
                df %>% filter(cell %in% cells_test),
                naive = FALSE
            )

            allele_post = rbind(
                allele_post_naive %>% mutate(method = 'naive'),
                allele_post_phasing %>% mutate(method = 'phasing')
            ) %>%
            mutate(
                seed = unique(bulk$seed),
                ratio = unique(bulk$ratio)
            )

            return(allele_post)

    }) %>% bind_rows()

    fwrite(
        cell_scores,
        glue('~/paper_data/phasing_benchmark/cell_scores_{sample}.tsv.gz'),
        sep = '\t', nThread = min(10, ncores)
    )

    message('Done!')

}

####### run ########

samples = c('47491_Primary', '27522_Relapse_2', '59114_Relapse_1', '37692_Primary', '58408_Primary')

cell_annot = fread('~/paper_data/cell_annotations/cell_annot_WASHU_march.tsv') %>%
    split(.$sample)

df = c()
segs_dna = c()

for (sample in samples) {

    message(sample)

    for (ratio in c(1)) {

        df = fread(glue('~/paper_data/processed/{sample}_{ratio}_allele_counts.tsv.gz'), nThread = 4)

        segs_dna = fread(glue('~/paper_data/purple_out/{sample}/segs_consensus_dna.tsv')) %>%
            filter(cnv_state_post %in% c('amp', 'loh', 'del')) %>%
            mutate(cnv_state = cnv_state_post) %>%
            mutate(CHROM = factor(CHROM, 1:22)) %>%
            as.data.frame()

        run_bench(
            df,
            cell_annot[[sample]],
            segs_dna,
            paste0(sample, '_', ratio),
            n_cells = 500,
            ratios = seq(0, 1, 0.05),
            ncores = 10,
            replace = TRUE
        )
    }
}

# ## TNBC4 ##
# cell_annot = fread('~/paper_data/cell_annotations/cell_annot_MDA.tsv', sep = ',') %>%
#     mutate(annot = copykat.pred) %>%
#     filter(sample == 'TNBC4')

# segs_dna = fread('~/paper_data/phasing_benchmark/segs_truth_TNBC4.tsv') %>%
#     mutate(CHROM = factor(CHROM, 1:22)) %>%
#     as.data.frame()

# samples = c(
#     'TNBC4', 'TNBC4_1000G',
#     'TNBC4_0.25', 'TNBC4_0.5'
# )

# df = mclapply(
#     samples,
#     mc.cores = length(samples),
#     function(sample) {
#         fread(glue('~/paper_data/processed/{sample}_N_allele_counts.tsv.gz'))
#     }) %>%
#     setNames(samples)

# for (sample in samples) {

#     message(sample)

#     run_bench(
#         df[[sample]], cell_annot, segs_dna, sample,
#         n_cells = 750,
#         ratios = c(seq(0, 0.1, 0.01), seq(0.15, 0.5, 0.05)),
#         ncores = 10,
#         replace = FALSE
#     )
# }


library(GOstats)
library(org.Dm.eg.db)

flybase_to_eg <- function(fb_ids) {
  idmap <- readRDS("flybase/fbidmap.rds")
  fb_ids <- subset(idmap, prev_id %in% fb_ids)$fb_gene_id
  fb_ids <- unique(c(fb_ids, subset(idmap, fb_gene_id %in% fb_ids)$prev_id))

  na.omit(unlist(mget(as.character(fb_ids), org.Dm.egFLYBASE2EG, ifnotfound=NA)))
}

get_gene_names_for_bpid <- function(bpid, go_results) {
  matching <- geneIdsByCategory(go_results, bpid)[[1]]
  paste(sort(unlist(na.omit(mget(matching, org.Dm.egSYMBOL, ifnotfound=NA)))), collapse=", ")
}

run_go <- function(fb_ids, universe_fb_ids) {
  test_ids     <- unique(flybase_to_eg(fb_ids))
  universe_ids <- unique(flybase_to_eg(universe_fb_ids))

  go.params <- new("GOHyperGParams",
                   geneIds=test_ids,
                   universeGeneIds=universe_ids,
                   annotation="org.Dm.eg.db",
                   ontology="BP",
                   pvalueCutoff=0.01,
                   conditional=TRUE,
                   testDirection="over")
  go.results <- hyperGTest(go.params)

  results.df <- summary(go.results)
  results.df$Gene_Names <- sapply(results.df$GOBPID, get_gene_names_for_bpid, go.results)
  results.df
}


library(tmap)
library(sf)

shape <- read_sf(dsn = "./shp", layer = "gadm36_DZA_1") #READING THE SHAPE FILE

########################### FIRST MAP ###########################
tm <- tm_shape(shape) +
tm_fill("MAP1", title = "Legende", style = "fixed",
        breaks = c(0, 70, 200, 400, 700, 2100),
        textNA = "Donnee inconnue") +
tm_borders() +
tm_text("NAME_1", size="AREA", root=10)+
tm_style("bw",legend.frame = TRUE, bg.color="lightblue", legend.bg.color="lightblue")+
tm_compass(type = "rose", show.labels=2) +
tm_credits("Algerie", size=1.3,fontfamily="Z003") +
tm_layout("Year 2011 Map1",
          fontfamily="Z003",
          title.size=1.8,
          legend.title.size = 1.5,
          legend.text.size = 1.3,
          legend.position = c("left","bottom"),
          legend.bg.color = "white",
          legend.bg.alpha = 0.7)+
tm_scale_bar()
tmap_save(tm, "map1.png", width=4000, height=3000)

########################### SECOND MAP ###########################

tm[2]<-tm_fill("MAP2", title = "Legende", style = "fixed",
        breaks = c(0, 25, 100, 250, 400, 1000),
        textNA = "Donnee inconnue")
tm[8]<-tm_layout("Year 2011 Map2",
          fontfamily="Z003",
          title.size=1.8,
          legend.title.size = 1.5,
          legend.text.size = 1.3,
          legend.position = c("left","bottom"),
          legend.bg.color = "white",
          legend.bg.alpha = 0.7)
tmap_save(tm, "map2.png", width=4000, height=3000)

########################### THIRD MAP ###########################

tm[2]<-tm_fill("MAP3", title = "Legende", style = "fixed",
        breaks = c(0, 40, 100, 200, 300, 1200),
        textNA = "Donnee inconnue")
tm[8]<-tm_layout("Year 2011 Map3",
          fontfamily="Z003",
          title.size=1.8,
          legend.title.size = 1.5,
          legend.text.size = 1.3,
          legend.position = c("left","bottom"),
          legend.bg.color = "white",
          legend.bg.alpha = 0.7)
tmap_save(tm, "map3.png", width=4000, height=3000)

########################### FOURTH MAP ###########################

tm[2]<-tm_fill("MAP4", title = "Legende", style = "fixed",
        breaks = c(0, 30, 100, 200, 250, 1000),
        textNA = "Donnee inconnue")
tm[8]<-tm_layout("Year 2011 Map4",
          fontfamily="Z003",
          title.size=1.8,
          legend.title.size = 1.5,
          legend.text.size = 1.3,
          legend.position = c("left","bottom"),
          legend.bg.color = "white",
          legend.bg.alpha = 0.7)
tmap_save(tm, "map4.png", width=4000, height=3000)


# W SA i GA jest inna filozofia funkcji_oceniajacej: w SA ma byc jak najmniejsza, w GA ma byc jak najwieksza

# Zeby to zadzialalo, wczesniej trzeba zrobic:
# install.packages("GenSA")
library(GenSA)

# Do zmiennej "poznan" wczytujemy dane z pliku CSV
setwd('/')
poznan <- read.csv(file = 'poznan.csv')

#liczba obos
N <- 65

#plec i wiek
N_WOMAN18 <- 2
N_MAN18 <- 2
N_WOMAN25 <- 9
N_MAN25 <- 8
N_WOMAN40 <- 14
N_MAN40 <- 12
N_WOMAN65 <- 11
N_MAN65 <- 7

#wyksztalcenie
N_PRIMARY <- 9
N_MEDIUM <- 35
N_HIGHER <- 21

#stosunek do zmian kliematu skala 5-stopniowa
NC_1 <- 10
NC_2 <- 2
NC_3 <- 14
NC_4 <- 11
NC_5 <- 28

#osiedle
N_A_1 <- 1
N_A_2 <- 2
N_A_3 <- 1
N_A_4 <- 1
N_A_5 <- 1
N_A_6 <- 2
N_A_7 <- 3
N_A_8 <- 2
N_A_9 <- 1
N_A_10 <- 2
N_A_11 <- 1
N_A_12 <- 1
N_A_13 <- 1
N_A_14 <- 1
N_A_15 <- 1
N_A_16 <- 1
N_A_17 <- 1
N_A_18 <- 2
N_A_19 <- 2
N_A_20 <- 2
N_A_21 <- 1
N_A_22 <- 1
N_A_23 <- 1
N_A_24 <- 3
N_A_25 <- 1
N_A_26 <- 3
N_A_27 <- 1
N_A_28 <- 3
N_A_29 <- 1
N_A_30 <- 1
N_A_31 <- 1
N_A_32 <- 1
N_A_33 <- 1
N_A_34 <- 3
N_A_35 <- 2
N_A_36 <- 1
N_A_37 <- 1
N_A_38 <- 3
N_A_39 <- 2
N_A_40 <- 1
N_A_41 <- 2
N_A_42 <- 2

# ROZMIAR_DANYCH (dla zbioru poznan)
ROZMIAR_DANYCH <- nrow(poznan)

funkcja_oceniajaca <- function(v,b) {

  ret <- 0

  #zapobieganie duplikatom
  if(any(duplicated(poznan$ID[v]))){
    ret <- 99999999
  }else{

    # Liczymy ile jest "man/woman" i zakresy wiekowe
    man18 <- 0
    woman18 <- 0
    man25 <- 0
    woman25 <- 0
    man40 <- 0
    woman40 <- 0
    man65 <- 0
    woman65 <- 0

    #liczniki wyksztalcenia
    primary <- 0
    medium <- 0
    higher <- 0

    #liczniki stosunku klimatu
    c1 <- 0
    c2 <- 0
    c3 <- 0
    c4 <- 0
    c5 <- 0

    #liczniki osiedla
    a1 <- 0
    a2 <- 0
    a3 <- 0
    a4 <- 0
    a5 <- 0
    a6 <- 0
    a7 <- 0
    a8 <- 0
    a9 <- 0
    a10 <- 0
    a11 <- 0
    a12 <- 0
    a13 <- 0
    a14 <- 0
    a15 <- 0
    a16 <- 0
    a17 <- 0
    a18 <- 0
    a19 <- 0
    a20 <- 0
    a21 <- 0
    a22 <- 0
    a23 <- 0
    a24 <- 0
    a25 <- 0
    a26 <- 0
    a27 <- 0
    a28 <- 0
    a29 <- 0
    a30 <- 0
    a31 <- 0
    a32 <- 0
    a33 <- 0
    a34 <- 0
    a35 <- 0
    a36 <- 0
    a37 <- 0
    a38 <- 0
    a39 <- 0
    a40 <- 0
    a41 <- 0
    a42 <- 0

    for (i in 1:length(v)) {

      if (poznan$GenderAge[v[i]] == "man18-24") {
        man18 <- man18+1
      } else if (poznan$GenderAge[v[i]] == "woman18-24") {
        woman18 <- woman18+1
      } else if (poznan$GenderAge[v[i]] == "man25-39") {
        man25 <- man25+1
      } else if (poznan$GenderAge[v[i]] == "woman25-39") {
        woman25 <- woman25+1
      } else if (poznan$GenderAge[v[i]] == "man40-64") {
        man40 <- man40+1
      } else if (poznan$GenderAge[v[i]] == "woman40-64") {
        woman40 <- woman40+1
      } else if (poznan$GenderAge[v[i]] == "man65+") {
        man65 <- man65+1
      } else if (poznan$GenderAge[v[i]] == "woman65+") {
        woman65 <- woman65+1
      } else {

      }

      if (poznan$Education[v[i]] == "primary") {
        primary <- primary+1
      } else if (poznan$Education[v[i]] == "medium") {
        medium <- medium+1
      } else if (poznan$Education[v[i]] == "higher") {
        higher <- higher+1
      } else {

      }

      if (poznan$climate[v[i]] == "1") {
        c1 <- c1+1
      } else if (poznan$climate[v[i]] == "2")  {
        c2 <- c2+1
      } else if (poznan$climate[v[i]] == "3")  {
        c3 <- c3+1
      } else if (poznan$climate[v[i]] == "4")  {
        c4 <- c4+1
      } else if (poznan$climate[v[i]] == "5")  {
        c5 <- c5+1
      }

      if (poznan$area[v[i]] == "1") {
        a1 <- a1+1
      }else if(poznan$area[v[i]] == "2") {
        a2 <- a2+1
      }else if(poznan$area[v[i]] == "3") {
        a3 <- a3+1
      }else if(poznan$area[v[i]] == "4") {
        a4 <- a4+1
      }else if(poznan$area[v[i]] == "5") {
        a5 <- a5+1
      }else if(poznan$area[v[i]] == "6") {
        a6 <- a6+1
      }else if(poznan$area[v[i]] == "7") {
        a7 <- a7+1
      }else if(poznan$area[v[i]] == "8") {
        a8 <- a8+1
      }else if(poznan$area[v[i]] == "9") {
        a9 <- a9+1
      }else if(poznan$area[v[i]] == "10") {
        a10 <- a10+1
      }else if(poznan$area[v[i]] == "11") {
        a11 <- a11+1
      }else if(poznan$area[v[i]] == "12") {
        a12 <- a12+1
      }else if(poznan$area[v[i]] == "13") {
        a13 <- a13+1
      }else if(poznan$area[v[i]] == "14") {
        a14 <- a14+1
      }else if(poznan$area[v[i]] == "15") {
        a15 <- a15+1
      }else if(poznan$area[v[i]] == "16") {
        a16 <- a16+1
      }else if(poznan$area[v[i]] == "17") {
        a17 <- a17+1
      }else if(poznan$area[v[i]] == "18") {
        a18 <- a18+1
      }else if(poznan$area[v[i]] == "19") {
        a19 <- a19+1
      }else if(poznan$area[v[i]] == "20") {
        a20 <- a20+1
      }else if(poznan$area[v[i]] == "21") {
        a21 <- a21+1
      }else if(poznan$area[v[i]] == "22") {
        a22 <- a22+1
      }else if(poznan$area[v[i]] == "23") {
        a23 <- a23+1
      }else if(poznan$area[v[i]] == "24") {
        a24 <- a24+1
      }else if(poznan$area[v[i]] == "25") {
        a25 <- a25+1
      }else if(poznan$area[v[i]] == "26") {
        a26 <- a26+1
      }else if(poznan$area[v[i]] == "27") {
        a27 <- a27+1
      }else if(poznan$area[v[i]] == "28") {
        a28 <- a28+1
      }else if(poznan$area[v[i]] == "29") {
        a29 <- a29+1
      }else if(poznan$area[v[i]] == "30") {
        a30 <- a30+1
      }else if(poznan$area[v[i]] == "31") {
        a31 <- a31+1
      }else if(poznan$area[v[i]] == "32") {
        a32 <- a32+1
      }else if(poznan$area[v[i]] == "33") {
        a33 <- a33+1
      }else if(poznan$area[v[i]] == "34") {
        a34 <- a34+1
      }else if(poznan$area[v[i]] == "35") {
        a35 <- a35+1
      }else if(poznan$area[v[i]] == "36") {
        a36 <- a36+1
      }else if(poznan$area[v[i]] == "37") {
        a37 <- a37+1
      }else if(poznan$area[v[i]] == "38") {
        a38 <- a38+1
      }else if(poznan$area[v[i]] == "39") {
        a39 <- a39+1
      }else if(poznan$area[v[i]] == "40") {
        a40 <- a40+1
      }else if(poznan$area[v[i]] == "41") {
        a41 <- a41+1
      }else if(poznan$area[v[i]] == "42") {
        a42 <- a42+1
      }
    }

    #do wieku i plci dodana jest waga aby zwiekszyc nacisk na te kryteria
    ret <- ret + (N_MAN18-man18)^2*10 + (N_WOMAN18-woman18)^2*10 + (N_MAN25-man25)^2*10 + (N_WOMAN25-woman25)^2*10 + (N_MAN40-man40)^2*10 + (N_WOMAN40-woman40)^2*10 + (N_MAN65-man65)^2*10 + (N_WOMAN65-woman65)^2*10 + (N_PRIMARY-primary)^2 + (N_MEDIUM-medium)^2 + (N_HIGHER-higher)^2 + (NC_1 -c1)^2 +(NC_2-c2)^2+(NC_3-c3)^2+(NC_4-c4)^2+(NC_5-c5)^2+(N_A_1-a1)^2+(N_A_2-a2)^2+(N_A_3-a3)^2+(N_A_4-a4)^2+(N_A_5-a5)^2+(N_A_6-a6)^2+(N_A_7-a7)^2+(N_A_8-a8)^2+(N_A_9-a9)^2+(N_A_10-a10)^2+(N_A_11-a11)^2+(N_A_12-a12)^2+(N_A_13-a13)^2+(N_A_14-a14)^2+(N_A_15-a15)^2+(N_A_16-a16)^2+(N_A_17-a17)^2+(N_A_18-a18)^2+(N_A_19-a19)^2+(N_A_20-a20)^2+(N_A_21-a21)^2+(N_A_22-a22)^2+(N_A_23-a23)^2+(N_A_24-a24)^2+(N_A_25-a25)^2+(N_A_26-a26)^2+(N_A_27-a27)^2+(N_A_28-a28)^2+(N_A_29-a29)^2+(N_A_30-a30)^2+(N_A_31-a31)^2+(N_A_32-a32)^2+(N_A_33-a33)^2+(N_A_34-a34)^2+(N_A_35-a35)^2+(N_A_36-a36)^2+(N_A_37-a37)^2+(N_A_38-a38)^2+(N_A_39-a39)^2+(N_A_40-a40)^2+(N_A_41-a41)^2+(N_A_42-a42)^2

  }

  if (b) {
    #prezentacja wynikow
    print( poznan$Code[v] )
    print( cat('man18=', man18, ' woman18=', woman18,'man25=', man25, ' woman25=', woman25,'man40=', man40, ' woman40=', woman40,'man65=', man65, ' woman65=', woman65, ' primary=', primary, ' medium=', medium, ' higher=', higher,' climate1=',c1,' climate2=',c2,' climate3=',c3, ' cliamte4=',c4, ' climate5=',c5,' area1=',a1,' area2=',a2,' area3=',a3,' area4=',a4,' area5=',a5,' area6=',a6,' area7=',a7,' area8=',a8,' area9=',a9,' area10=',a10,' area11=',a11,' area12=',a12,' area13=',a13,' area14=',a14,' area15=',a15,' area16=',a16,' area17=',a17,' area18=',a18,' area19=',a19,' area20=',a20,' area21=',a21,' area22=',a22,' area23=',a23,' area24=',a24,' area25=',a25,' area26=',a26,' are27=',a27,' area28=',a28,' area29=',a29,' area30=',a30,' area31=',a31,' area32=',a32,' area33=',a33,' area34=',a34,' area35=',a35,' area36=',a36,' area37=',a37,' area38=',a38,' area39=',a39,' area40=',a40,' area41=',a41,' area42=',a42) )
   #zapis wynikow do pliku
    write.csv(cbind(poznan$ID[v],poznan$Code[v]),'wynik.csv',row.names = FALSE)
  }

  ret
}

# Funkcja oceniajaca bedzie sluzyla do optymalizacji rozwiazania. Chcemy, zeby miala jak najnizsza wartosc.
# Argumentem jest wektor danych (lista ID osob) - poniewaz nam chodzi o zbior 65 osob, wiec poprzez wartosc funkcji
# musimy wykluczyc wektory, gdzie ID sie powtarzaja (damy im bardzo wysoka wartosc).
# Przyjmiemy, ze ciag elementow wektora (czyli ID osob) musi byc rosnacy (co nam zapewnia roznowartosciowosc).

# Bez "as.numeric" wywraca sie z komunikatem "REAL() can only be applied..."
WYNIK <- GenSA(par=as.numeric(sample(1:N)*ROZMIAR_DANYCH/N), fn=funkcja_oceniajaca, lower=as.numeric(seq(1,N)), upper=as.numeric(seq(ROZMIAR_DANYCH-N+1,ROZMIAR_DANYCH)), FALSE, control=list(max.time=1440,smooth=FALSE,verbose=TRUE,temperature=50.0))
print(WYNIK)

#wynik
funkcja_oceniajaca(WYNIK$par, TRUE)


suppressPackageStartupMessages(library(kazaam))

if (comm.rank() == 0){
  x = matrix(1:30, 10)

  lt1 = x < 10
  lt2 = 10 < x
  lt3 = x < x

  gt1 = x > 10
  gt2 = 10 > x
  gt3 = x > x

  le1 = x <= 10
  le2 = 10 <= x
  le3 = x <= x

  ge1 = x >= 10
  ge2 = 10 >= x
  ge3 = x >= x

  eq1 = x == 10
  eq2 = 10 == x

  ne1 = x != 10
  ne2 = 10 != x
  ne3 = x != x
} else {
  x = NULL
}

dx = expand(x)

lt1_t = collapse(dx < 10)
lt2_t = collapse(10 < dx)
lt3_t = collapse(dx < dx)
comm.print(all.equal(lt1, lt1_t))
comm.print(all.equal(lt2, lt2_t))
comm.print(all.equal(lt3, lt3_t))

gt1_t = collapse(dx > 10)
gt2_t = collapse(10 > dx)
gt3_t = collapse(dx > dx)
comm.print(all.equal(gt1, gt1_t))
comm.print(all.equal(gt2, gt2_t))
comm.print(all.equal(gt3, gt3_t))

le1_t = collapse(dx <= 10)
le2_t = collapse(10 <= dx)
le3_t = collapse(dx <= dx)
comm.print(all.equal(le1, le1_t))
comm.print(all.equal(le2, le2_t))
comm.print(all.equal(le3, le3_t))

ge1_t = collapse(dx >= 10)
ge2_t = collapse(10 >= dx)
ge3_t = collapse(dx >= dx)
comm.print(all.equal(ge1, ge1_t))
comm.print(all.equal(ge2, ge2_t))
comm.print(all.equal(ge3, ge3_t))

eq1_t = collapse(dx == 10)
eq2_t = collapse(10 == dx)
comm.print(all.equal(eq1, eq1_t))
comm.print(all.equal(eq2, eq2_t))

ne1_t = collapse(dx != 10)
ne2_t = collapse(10 != dx)
ne3_t = collapse(dx != dx)
comm.print(all.equal(ne1, ne1_t))
comm.print(all.equal(ne2, ne2_t))
comm.print(all.equal(ne3, ne3_t))

finalize()


## Set Script variables
title = 'HSR MEPS 2019' # Input basic title
descriptive = '- Sample Study for HSR Resource Repository' # Input descriptive title
author = 'Andrew S. Cistola, MPH' # Input author information
GH = 'https://github.com/andrewcistola/HSR' # Input GitHub repository
name = 'HSR_MEPS_2019_alpha' # Input generic file name with repo, project, subject, and version
project = 'MEPS/' # Input project file name inside repository
repo = 'HSR/' # Input repository filename
user = 'Andrew S. Cistola, MPH; https://github.com/andrewcistola' # Input name and GitHub profile of user
local = '/home/drewc/GitHub/' # Input local path to repository
directory = paste(local, repo, project, sep = "") # Set wd to project repository using variables
day = Sys.Date() # Save dimple date as string
stamp = date() # Save Date and timestamp

## Set working directory
setwd(directory) # Set wd to project repository

## Import data
df_meps = read.csv('MEPS_2019_raw.csv') # Import dataset from _data folder
df_meps = df_meps[which(df_meps$AGE19X >= 65), ] # based on variable values
head(df_meps) # Print mini table with first 6 observations
nrow(df_meps) # Number of rows

## Create subset table
df_XY = df_meps[c('PID', # ID
                    # Diagnoses
                    'DIABDX_M18', # Diabetes Diagnosis
                    'STRKDX', # 2 = stroke diagnosis
                    'EMPHDX', # 2 = emphezema diagnosis
                    'CHDDX', # 2 = Coronary heart disease diagnosis
                    'ANGIDX', # 2 = Angina diagnosis
                    'CANCERDX', # 2 = Cancer Diagnosis
                    # Social determinants
                    'HIDEG', # 1-3 = HS or less
                    'EMPST53', # 4 = Not employed
                    'HRWG31X', # Hourly wage, -10 >= 96.15
                    'RETPLN31', # 2 = No Pension Plan at retirement age
                    'HWELLSPK', # 3+ = Speak english not well
                    'MCDEV19', # Ever Medicaid in 2019
                    'RACETHX', # 3 = Non-Hispanic Black
                    'NWK31', # 3 = Does not work due to disability
                    'EVRETIRE', # 1 = Retired
                    # Confounders and fixed effects
                    'REGION19', # Census region
                    'AGE19X', # Age in years
                    'MCRPHO19', # 1 = MA, 2 = FFS, 3 = Not Medicare
                    # Outcomes
                    'ERTOT19', # Total ED visits
                    'IPNGT19', # Total Inpatient nights
                    'IPDIS19', # Total Inpatient discharges
                    'OBDRV19', # Total office based physician visits
                    'OPDRV19' # Total outpaitnet physician visits
                    )] #
df_XY = replace(df_XY, df_XY <= 0, 0) # Replace all values below 0 with 0
head(df_XY)# Print mini table with first 6 observations

## Create Predictor table
df_X = df_XY[c('DIABDX_M18', # Diabetes Diagnosis
                        'STRKDX', # 2 = stroke diagnosis
                        'EMPHDX', # 2 = emphezema diagnosis
                        'CHDDX', # 2 = Coronary heart disease diagnosis
                        'ANGIDX', # 2 = Angina diagnosis
                        'CANCERDX', # 2 = Cancer Diagnosis
                        'AGE19X'
                        )] #
df_X = replace(df_X, df_X == 2, 0) # Replace all values below 0 with 0
df_X = replace(df_X, df_X == NA, 0) # Replace all values below 0 with 0
df_X$CHRCMI = df_X$DIABDX_M18 + df_X$STRKDX + df_X$EMPHDX + df_X$CHDDX + df_X$ANGIDX + df_X$CANCERDX*6 # Calculate Charlson comorbidity index
summary(df_X) # Print mini table with first 6 observations
head(df_X)# Print mini table with first 6 observations

### Create SDOH predictor table
df_S = df_XY[c('HIDEG', # 1-3 = HS or less
                        'EMPST53', # 4 = Not employed
                        'HRWG31X', # Hourly wage, 0.17 - 96.15
                        'RETPLN31', # 2 = No Pension Plan at retirement age
                        'HWELLSPK', # 3+ = Speak english not well
                        'MCDEV19', # 1 = Ever Medicaid in 2019
                        'RACETHX', # 3 = Non-Hispanic Black
                        'NWK31' # 3 = Does not work due to disability
                        )] #
df_S$HIDEG[df_S$HIDEG < 3] <- 1 # Create new column based on conditions
df_S$EMPST53[df_S$EMPST53 == 4] <- 1 # Create new column based on conditions
df_S$HRWG31X[df_S$HRWG31X < 15] <- 1 # Create new column based on conditions
df_S$RETPLN31[df_S$RETPLN31 == 2] <- 1 # Create new column based on conditions
df_S$HWELLSPK[df_S$HWELLSPK > 3] <- 1 # Create new column based on conditions
df_S$MCDEV19[df_S$MCDEV19 == 1] <- 1 # Create new column based on conditions
df_S$RACETHX[df_S$RACETHX == 3] <- 1 # Create new column based on conditions
df_S$NWK31[df_S$NWK31 == 3] <- 1 # Create new column based on conditions
df_S = replace(df_S, df_S == NA, 0) # Replace all values below 0 with 0
df_S = replace(df_S, df_S > 1, 0) # Replace all values below 0 with 0
df_S = replace(df_S, df_S < 1, 0) # Replace all values below 0 with 0
df_S$SDOH = df_S$HIDEG + df_S$EMPST53 + df_S$HRWG31X + df_S$RETPLN31 + df_S$HWELLSPK + df_S$MCDEV19 + df_S$RACETHX + df_S$NWK31
summary(df_S) # Print mini table with first 6 observations
head(df_S)# Print mini table with first 6 observations

## Create outcome table
df_Y = df_XY[c('IPNGT19')] # Select columns of dataframe
df_Y = replace(df_Y, df_Y == NA, 0) # Replace all values below 0 with 0
summary(df_Y) # Print mini table with first 6 observations

### Create final table
df_F = merge(df_X, df_S, by = 0, keep = FALSE) # Join dataframes by index
df_F = merge(df_F, df_Y, by = 0, keep = FALSE) # Join data frames by index
df_F = df_F[c('CHRCMI', 'SDOH', 'IPNGT19', 'AGE19X')] # Select final varibales for model
df_F$INT = df_F$CHRCMI * df_F$SDOH
head(df_F)# Print mini table with first 6 observations
summary(df_F) # Print mini table with first 6 observations

### OLS Model
y <- df_F$IPNGT19
x1 <- df_F$CHRCMI
x2 <- df_F$SDOH
x3 <- df_F$AGE19X
x4 <- df_F$INT
model = lm(y ~ x1 + x2 + x3 + x4)
res = resid(model)

### Utt's Rainbox Test
library(lmtest)
raintest(y ~ x1 + x2 + x3 + x4)

### Residuals Plot
library(ggplot2)
png(paste(name, '_res.png'))
plot(fitted(model), res)
abline(0,0)
dev.off()

### Histogram
library(ggplot2)
png(paste(name, '_hist.png'))
plot(fitted(model), res)
abline(0,0)
dev.off()


# This scripts constructs both a weighted and unweighted GRS
rm(list = ls())

# Read in dosage file
load(file="/home/benb/projects/sib_bmi2/data/harm_geno.Rda")

# Need the harmonised dat file from MR-Base
load(file="/home/benb/projects/sib_bmi2/data/harm_snp_weights.Rda")

# Output directory
output_file_harm_geno_grs <- "/home/benb/projects/sib_bmi2/data/harm_geno_grs.Rda"

# Vector of betas for each SNV in order of dosage file
order <- names(geno[, -1])
weights <- unlist(dat[match(order, dat$SNP),][c("beta.exposure")])

# Create a dosage file to weight
dose <- geno[, -1]

# Weight each allele and sum all rows
dose.w <- data.frame(mapply(`*`, dose, weights))
dose.w$grs <- rowSums(dose.w)

# Sum all columns but not IID to create an unweighted GRS
geno$cnt.bmi.69 <- rowSums(geno[, -1])

# Column bind the grs to geno
geno <- data.frame(cbind(geno, dose.w$grs))
names(geno)[names(geno) == 'dose.w.grs'] <- 'grs.bmi.69'

save(geno, file = output_file_harm_geno_grs)


# user options

#year window, first and last year
f.year<-2003
l.year<-2007

dev<-'screen'
nox<-1; noy<-3;

# use survey obs for the year after the last assessment year (assuming the survey is conducted the 1. January.)
# 0=no use, 1=yes, use extended survey series
extend.survey<-0

######   end user options  ###################
cleanup()

setwd(data.path)
bio.interact<-FALSE

# retrospective runs are made in a separate dirictory
retro.dir<-"retro"

dir.create(retro.dir,showWarnings = FALSE)

SMS.files.single<-c("natmor.in","canum.in","west.in","weca.in","propmat.in","fleet_catch.in","fleet_names.in","fleet_info.dat","just_one.in")

for (from.file in SMS.files.single) {
  to.file<-file.path(data.path,retro.dir,from.file)
  file.copy(from.file, to.file, overwrite = TRUE)
}

# read data and options into FLR objects
control<-read.FLSMS.control()
#stock<-SMS2FLStocks(read.input=TRUE,read.output=FALSE,bio.interact=FALSE,control=control)
indices<-SMS2FLIndices(control)

old.dir<-getwd()
setwd(retro.dir)

#FLStocks2SMS(FLStock=stock,control=control,bio.interact=bio.interact)
FLIndices2SMS(indices=indices,control=control)

write.FLSMS.control(control,write.multi=bio.interact)

for (y in (l.year:f.year)){

    for (j in 1:length(indices))
    {
      min.yr <- min(as.numeric(dimnames(indices[[j]]@index)$year))
      max.yr <- max(as.numeric(dimnames(indices[[j]]@index)$year))
      if (y < min.yr) stop("year.range is outside indices year range")
      indices[[j]] <- trim(indices[[j]],year=min.yr:(min(max.yr,y+extend.survey)))

    }
    FLIndices2SMS(indices=indices,control=control)

    control@last.year.model<-y
    control@read.HCR<-0
    write.FLSMS.control(control,write.multi=bio.interact)

    shell(paste( file.path(root,"program","sms.exe"),"-nox -nohess",sep=" "), invisible = TRUE)
    if (!file.copy("summary.out", paste("summary",y,".out",sep=""), overwrite = TRUE)) stop(paste("Retro stopped: something went wrong in copying summary.dat for year:",y))
    file.remove("summary.out")
}

av.F.age<-control@avg.F.ages

lab<-paste('Retrospective anlysis:',f.year,'-',l.year)

for (y in(l.year:f.year)) {
  file<-paste('summary',y,'.out',sep='')
  s<-read.table(file,header=TRUE)
  s<-data.frame(Species=control@species.names[s$Species.n],s)
  s<-subset(s,Z>-1)
  rec<-subset(s,Quarter==control@rec.season & Age==control@first.age )
  rec<-tapply(rec$N,list(rec$Species.n,rec$Year),sum)/1000

  s1<-subset(s,Quarter==1)
  ssb<-tapply(s1$SSB,list(s1$Species.n,s1$Year),sum)/1000
  if (y==l.year) {
   SSB<-array(NA,dim=c(nsp,dim(ssb)[2],l.year-f.year+1),
         dimnames=list(control@species.names,seq(control@first.year,l.year),(l.year:f.year)))
   FI<-SSB
   REC<-SSB # copy structure
  }
  SSB[,1:dim(ssb)[2],l.year-y+1]<-ssb
  REC[,1:dim(ssb)[2],l.year-y+1]<-rec

  F.at.age<-tapply(s$F,list(s$Year,s$Age,s$Species.n),sum,na.rm=T)
  for (sp in (1:nsp)){
    FI[,1:dim(ssb)[2],l.year-y+1]<-apply(F.at.age[ ,(av.F.age[1]-fa+1):(av.F.age[2]-fa+1),sp],c(1),mean)  ### kun med en art-- fejl
  }
}

noxy<-nox*noy
i<-0
newplot(dev,nox,noy)

plot.retro<-function(x,label,legend.x=0.15,legend.y=1) {
yr<-as.numeric(dimnames(x)[[2]])
nyr<-l.year-f.year+1
for (sp in (1:nsp)) {
  if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
  plot(yr,x[sp,,1],xlab='',ylab=label,main=lab,type='b',
    ylim=c(0,max(x[sp,,],na.rm=T)),lwd=2,pch=1)
   legend(x=max(yr)-legend.x*(max(y)-min(yr)),y=max(x)*legend.y,legend=as.character(seq(f.year,l.year)),
    pch=seq(1,nyr),col=1)

  i<<-i+1
  if (nyr>1) for (y in ((f.year+1):(l.year))) {
    yy<-y-f.year+1
    lines(yr,x[sp,,yy],type='b',pch=yy,col=1,lwd=2)
  }
}
}

plot.retro(SSB,'SSB',legend.x=0.15)
plot.retro(FI,expression(bar(F)),legend.x=0.4)
plot.retro(REC,"recriuts 10^6",legend.x=0.4)

setwd(data.path)


# customized by Xiaoqing Rong-Mullins.
# all the ', silent = FALSE' were added by xqrm

modlist <- function(
  x,
  cyc = 1,
  fluo = NULL,
  model = l4,
  check = "uni2",
  checkPAR = parKOD(),
  remove = c("none", "fit", "KOD"),
  exclude = NULL,
  labels = NULL,
  norm = FALSE,
  # baseline = c("none", "mean", "median", "lin", "quad", "parm"), # ori
  baseline, # xqrm
  basecyc = 1:8,
  basefac = 1,
  min_reliable_cyc, # xqrm
  fallback = NULL, # xqrm
  smooth = NULL,
  smoothPAR = NULL,
  factor = 1,
  opt = FALSE,
  optPAR = list(sig.level = 0.05, crit = "ftest"),
  verbose = TRUE,
  ...
)
{
  # xqrm: start counting for running time
  func_name <- 'modlist'
  start_time <- proc.time()[['elapsed']]

  # xqrm:
  num_cycles <- dim(x)[1]
  if (num_cycles < min_reliable_cyc) {
    pcrfit_weights <- rep(1, times=num_cycles)
  } else {
    pcrfit_weights <- c(rep(0, times=min_reliable_cyc-1), rep(1, times=dim(x)[1]-min_reliable_cyc+1)) }
  if (fallback == 'parm') stop('`fallback` cannot be \'parm\'.')

  options(expressions = 50000)
  remove <- match.arg(remove)
  # if (!is.numeric(baseline)) baseline <- match.arg(baseline) # ori

  ## convert from single fit
  if (class(x)[1] == "pcrfit") {
    model <- x$MODEL
    x <- x$DATA
  }

  if (is.null(fluo)) fluo <- 2:ncol(x)

  ## version 1.3-5: define label vector
  if (!is.null(labels)) {
    LABNAME <- deparse(substitute(labels))
    LABELS <- labels
    if (length(LABELS) != length(fluo)) stop("Number of labels and runs do not match!")
  } else {
    LABELS <- 1:length(fluo)
    LABNAME <- "lab"
  }

  CYCLES <- x[, cyc]
  allFLUO <- x[, fluo, drop = FALSE]
  NAMES <- colnames(x)[fluo]

  ## version 1.3-6: exclude columns with no (default) or specific column names
  if (!is.null(exclude)) {
    if (exclude == "") SEL <- which(NAMES == "")
    else SEL <- grep(exclude, NAMES)
    if (length(SEL) > 0) {
      allFLUO <- allFLUO[, -SEL]
      NAMES <- NAMES[-SEL]
    }
  }

  ## pre-allocate model list
  modLIST <- vector("list", length = ncol(allFLUO))

  # xrqm
  # bl_list <- list()
  fluo_add_list <- list() # fluo value after addition to adjust negative values for baseline 'parm'
  blmod_list <- list()
  blcor_list <- list()

  for (i in 1:ncol(allFLUO)) {

    # xqrm: start counting for running time
    start_time_for <- proc.time()[['elapsed']]

    #FLUO  <- allFLUO[, i] # ori
    FLUO_ori <- allFLUO[, i] # xqrm
    NAME <- NAMES[i]

    # xqrm
    baseline_looped <- baseline # Within the 'for' loop, all `baseline` parameter after this point is changed to `baseline_looped` by xqrm

    while (TRUE) { # xqrm

      ## version 1.4-0: baselining with first cycles using 'baseline' function

      # xqrm: adjust fluorescence value if no value in FLUO_ori > 0, so lm.fit won't fail on '0 (non-NA) cases'
      if (all(FLUO_ori <= 0)) {
        addition <- -min(FLUO_ori)
        FLUO_ori <- FLUO_ori + addition # for design flaw in (sigmoid)model$ssFct
        message('\nFluorescence values are all negative, added ',
                round(addition, 2),
                ' before baseline subtraction.')
        }

      #if (baseline != "none" & baseline != "parm") { # ori
      if (baseline_looped != "parm") { # xqrm
        #FLUO <- baseline(cyc = CYCLES, fluo = FLUO, model = NULL, baseline = baseline, # ori

        # xqrm
        blmod <- NA # baseline subtraction is not thru 'parm', thus no sigmoid model to output

        # xqrm
        if (baseline_looped == "none") {
          FLUO <- FLUO_ori
        } else if (grepl('^auto_', baseline_looped)) {
          # # method 1
          # start_list <- NULL # method 1.1
          # # start_list <- as.list(rnorm(length(model$parname))) # method 1.2
          # fitted_model <- tryCatch(pcrfit(cbind(CYCLES, FLUO_ori), 1, 2, model, start = start_list, verbose = FALSE, ...),
                                   # error=err_e)
          # method 2
          fitting_not_done <- TRUE
          FLUO_4blfit <- FLUO_ori
          i_rf <- 0
          fo_uniq <- unique(FLUO_ori)
          min2nd_fo <- fo_uniq[order(fo_uniq)[2]] # min(FLUO_ori) will be 0 after addition upon all negative fluo values
          amf <- abs(min2nd_fo) # absolute value of 2nd minimal FLUO_ori value
          # # method 2.1
          # ssVals <- model$ssFct(CYCLES, FLUO_ori)
          # start_list <- as.list(ssVals)
          while (fitting_not_done) {
            fitted_model <- tryCatch(
                pcrfit(cbind(CYCLES, FLUO_4blfit), 1, 2, model, weights = pcrfit_weights, verbose = FALSE, ...),
                error=err_e)
            if ('error' %in% class(fitted_model) &&
                fitted_model$message %in% c(
                    'singular gradient matrix at initial parameter estimates',
                    'Non-finite (or null) value for a parameter specified!')) {
                if (i_rf >= 10) {
                    message('Re-fitted 10 times, quit with error as model.')
                    break}
                i_rf <- i_rf + 1
                message(sprintf(
                    'Fitting for baseline failed, re-fitting iteration %i with fluorescence values plus %f * %i',
                    i_rf, amf, i_rf))
                FLUO_4blfit <- FLUO_4blfit + amf # attempt to alleiviate problem caused by design flaw in model$ssFct where only positive fluo values are used to initiate coefficients 'b' and 'e'
                # # method 2.1
                # message('fitting again...')
                # ssVals['c'] <- ssVals['c'] - min(FLUO_ori) # resulted in fitted `coef(model)[['b']] > 0`
                # start_list <- as.list(ssVals)
            } else fitting_not_done <- FALSE }
          # end: methods
          FLUO <- baseline(cyc = CYCLES, fluo = FLUO_ori,
                           model = fitted_model,
                           baseline = baseline_looped, basefac = basefac,
                           min_reliable_cyc = min_reliable_cyc)
        } else {
          FLUO <- baseline(cyc = CYCLES, fluo = FLUO_ori, model = NULL, baseline = baseline_looped, # xqrm
                           basecyc = basecyc, basefac = basefac,
                           min_reliable_cyc = min_reliable_cyc) } # xqrm
        # bl_out <- baseline(cyc = CYCLES, fluo = FLUO, model = NULL, baseline = baseline,
                           # basecyc = basecyc, basefac = basefac)
        # FLUO <- bl_out[['bl_corrected']]
        blcor <- FLUO
        # message('\'', baseline_looped, '\'', ' was used as the final method for baseline subtraction.') # for testing

      } else { # if (baseline_looped == "parm")
        FLUO <- FLUO_ori }

      ## normalization
      if (norm) FLUO <- rescale(FLUO, 0, 1)

      ## version 1.3-8: smoothing
      if (!is.null(smooth)) {
        smooth <- match.arg(smooth, c("lowess", "supsmu", "spline", "savgol", "kalman", "runmean", "whit", "ema"))
        FLUO <- smoothit(FLUO, smooth, smoothPAR)
      }

      ## changing magnitude
      if (factor != 1) FLUO <- FLUO * factor

      # xqrm
      fluo_add_list[[i]] <- FLUO

      ## fit model
      DATA <- data.frame(Cycles = CYCLES, Fluo = FLUO)

      if (verbose) cat("Making model for ", NAME, " (", model$name, ")\n", sep= "")
      flush.console()

      #fitOBJ <- try(pcrfit(DATA, 1, 2, model, verbose = FALSE, ...), silent = TRUE) # ori
      # xqrm
      t1 <- Sys.time() # time
      fitOBJ <- try(pcrfit(DATA, 1, 2, model, weights = pcrfit_weights, verbose = FALSE, ...), silent=FALSE)
      td <- Sys.time() - t1 # time
      message('First sigmoid fitting took ', round(as.numeric(td), digits=2), ' seconds. (prior to baseline subtraction for \'auto_*\' and \'parm\', after for other options)') # time

      ## version 1.4-0: baselining with 'c' parameter using 'baseline' function
      if (baseline_looped == "parm") { #fitOBJ <- baseline(model = fitOBJ, baseline = baseline) # ori

        # if baseline == 'parm' (model automatically not NULL) and sigmoid fitting of pre-subtracted amplifcation data fails (determined by 'modlist_R1.r')

        # xqrm
        ori_dist2x <- median(FLUO) # define original distance to x-axis as the median of FLUO values across all the cycles
        fallback_conditions <- c(
                                 'fitting_failed' = (inherits(fitOBJ, "try-error")), # sigmoid fitting failed. `class(fitOBJ) == 'try-error'` was evaluated element-wise therefore cannot be used here.
                                 'b > 0' = try(coef(fitOBJ)[['b']] > 0), # fitted curve is downward
                                 'bad c' = try(abs(ori_dist2x - coef(fitOBJ)[['c']]) >= abs(ori_dist2x)) # subtracting 'c' from fluo values moved the curve further away from x-axis
                                 )

        # xqrm
        if (any(fallback_conditions)) {

          baseline_looped <- fallback
          message('Baseline subtraction method falls back from \'parm\' to \'', fallback, '\'.')
          message('Fallback reason:')

          if (fallback_conditions['fitting_failed']) {
            # reference in 'modlist_R1.r':
              # line 117: fitOBJ <- try(pcrfit(DATA, 1, 2, model, verbose = FALSE, ...), silent=FALSE) # xqrm
              # line 120: if (baseline == "parm") { #fitOBJ <- baseline(model = fitOBJ, baseline = baseline)
            message('Sigmoid fitting failed for amplifcation data before baseline subtraction.')
          } else if (fallback_conditions['b > 0']) {
            message('There is a downward trend for the fitted sigmoid curve on amplifcation data before baseline subtraction.')
          } else if (fallback_conditions['bad c']) {
            message('Subtracting \'c\' from fluo values moved the curve further away from x-axis.') }

          next }

        # xqrm
        blmod <- fitOBJ
        t1 <- Sys.time() # time
        bl_out <- baseline(model = fitOBJ, baseline = baseline_looped, min_reliable_cyc = min_reliable_cyc)
        td <- Sys.time() - t1 # time
        message('Baseline subtraction with \'parm\' took ', round(as.numeric(td), digits=2), ' seconds.') # time
        fitOBJ <- bl_out[['newMODEL']]
        blcor <- bl_out[['blcor']]
        # message('\'parm\' was used as the final method for baseline subtraction.') # for testing
        }

      break

    } # xqrm: end: while

    # xrqm
    # bl_list[[i]] <- unlist(bl_out['bl'])
    blmod_list[[i]] <- blmod
    blcor_list[[i]] <- blcor

    ## tag names if fit failed
    if (inherits(fitOBJ, "try-error")) {
      fitOBJ <- list()
      if (verbose) cat(" => Fitting failed. Tagging name of ", NAME, "...\n", sep = "")
      flush.console()
      NAME <- paste("*", NAME, "*", sep = "")
      fitOBJ$DATA <- DATA
      fitOBJ$isFitted <- FALSE
      fitOBJ$isOutlier <- FALSE
      class(fitOBJ) <- "pcrfit"
    } else {
      if (verbose) cat(" => Fitting passed...\n", sep = "")
      flush.console()
      fitOBJ$isFitted <- TRUE
      fitOBJ$isOutlier <- FALSE
    }

    ## optional model selection  # xqrm: use `mselect` to choose model for sigmoid fitting of amplification curve
    if (opt) {
      fitOBJ2 <- try(mselect(fitOBJ, verbose = FALSE, sig.level = optPAR$sig.level, crit = optPAR$crit), silent = FALSE) # xqrm added ', silent = FALSE'
      if (inherits(fitOBJ2, "try-error")) {
        if (verbose) cat(" => Model selection failed! Using original model...\n", sep = "")
        fitOBJ$isFitted <- TRUE
        fitOBJ$isOutlier <- FALSE
        flush.console()
      } else {
        if (verbose) cat(" => Model selection passed...", sep = "")
        flush.console()
        fitOBJ <- fitOBJ2
        fitOBJ$isFitted <- TRUE
        fitOBJ$isOutlier <- FALSE
        if (verbose) cat(" => ", fitOBJ$MODEL$name, "\n", sep = "")
        flush.console()
      }
    }

    if (verbose) cat("\n")

    fitOBJ$call2$model <- fitOBJ$MODEL

    modLIST[[i]] <- fitOBJ
    modLIST[[i]]$names <- NAME

    # xqrm: report time cost for this function
    end_time_for <- proc.time()[['elapsed']]
    message('iteration ', i, ' took ', round(end_time_for - start_time_for, 2), ' seconds.\n')

  } # xqrm: end: 'for' loop

  # xqrm
  well_names <- colnames(x)[2:ncol(x)]
  # bl_info <- do.call(cbind, bl_list)
  # colnames(bl_info) <- well_names

  # xqrm
  # fluo_add for adjusted fluo values when baseline == 'parm'
  if (length(fluo_add_list) > 0) {
    fluo_add <- do.call(cbind, fluo_add_list)
    colnames(fluo_add) <- well_names
  } else fluo_add <- NULL

  # xqrm
  # baseline corrected fluo values
  bl_corrected <- do.call(cbind, blcor_list)
  colnames(bl_corrected) <- well_names
  #try(colnames(bl_corrected) <- well_names, silent=FALSE) # old

  ## version 1.3-5: sigmoidal outlier detection by KOD
  ## version 1.3-8: turn off check with several models that are not sigmoid
  nsMODELS <- c("linexp", "mak2", "mak2i", "mak3", "mak3i", "lin2", "cm3", "spl3")
  if (model$name %in% nsMODELS) {
    isNS <- TRUE
    cat("Model '", model$name, "' can not be checked by outlier methods. Setting 'check = NULL'...\n", sep = "")
  } else isNS <- FALSE

  if (!is.null(check) & !isNS) {
    class(modLIST) <- c("modlist", "pcrfit")
    OUTL <- KOD(modLIST, method = check, par = checkPAR, plot = FALSE)
    modLIST <- OUTL
  }

  ## version 1.3-5: remove failed fits and update label vector
  if (remove != "none") {
    logVEC <- vector("numeric", length = length(modLIST))

    ## set failed fits to 1
    if (remove %in% c("fit", "KOD")) {
      SEL <- sapply(modLIST, function(x) x$isFitted)
      logVEC[SEL == FALSE] <- 1
    }

    ## set KOD's to 1
    if (remove == "KOD") {
      SEL <- sapply(modLIST, function(x) x$isOutlier)
      logVEC[SEL == TRUE] <- 1
    }

    ## remove and update LABELS vector
    SEL <- which(logVEC == 1)

    if (length(SEL) > 0) {
      if (verbose) cat(" => Removing from fit:", NAMES[SEL], "... \n", sep = " ")
      flush.console()
      modLIST <- modLIST[-SEL]
      if (verbose) cat(" => Updating", LABNAME, "and writing", paste(LABNAME, "_mod", sep = ""), "to global environment...\n\n", sep = " ")
      flush.console()
      LABELS <- LABELS[-SEL]
    }
  }

  class(blmod_list) <- c("modlist", "pcrfit") # xqrm
  class(modLIST) <- c("modlist", "pcrfit")
  #invisible(modLIST) # ori

  # xqrm: report time cost for this function
  end_time <- proc.time()[['elapsed']]
  message('`', func_name, '` took ', round(end_time - start_time, 2), ' seconds.')

  # xqrm
  return(list('ori'=modLIST,
              'fluoa'=fluo_add, 'blmods'=blmod_list,
              'bl_corrected'=bl_corrected)) # , 'bl_info'=bl_info))
}


#' float32
#'
#' A \code{float32} class constructor. For developers only.
#'
#' @details
#' Wraps the integer-type data in the \code{float32} S4 class, so that the data
#' will be interpreted as 32-bit floats.
#'
#' If instead you merely want to convert numeric/double data to float type,
#' instead you should call \code{fl(x)}.
#'
#' @param x
#' Input data of type integer.
#'
#' @return
#' A \code{float32} class object.
#'
#' @export
float32 = function(x)
{
  if (!is.integer(x))
    stop("data must have integer storage; did you mean to call fl(x)?")

  new("float32", Data=x)
}

#' float
#'
#' An analogue to \code{integer()} and \code{double()} for preallocation.
#'
#' @details
#' If both of \code{nrow} and \code{ncol} are specified, then \code{length} is
#' ignored, and the retor is a matrix. If one (but not the other) of \code{nrow}
#' or \code{ncol} is given, then the function errors. Otherwise, a vector of
#' length \code{length} is returned.
#'
#' @param length
#' Input data of type integer.
#' @param nrow,ncol
#' Number of rows/columns if a matrix return is desired. See details section for
#' more information.
#'
#' @return
#' A float vector/matrix of 0's.
#'
#' @examples
#' library(float)
#'
#' float(10)
#' float(nrow=2, ncol=3)
#'
#' @export
float = function(length=0, nrow, ncol)
{
  if (!missing(nrow) && !missing(ncol))
    isamat = TRUE
  else if (!missing(nrow) || !missing(ncol))
    stop("either both or neither 'nrow' and 'ncol' must be specified")
  else
    isamat = FALSE

  if (isamat)
    length = nrow*ncol

  x = integer(length)

  if (isamat)
    dim(x) = c(nrow, ncol)

  float32(x)
}


p_vap <- function(t, rh) {
    .Call('biometeoR_p_vap', PACKAGE = 'biometeoR', t, rh)
}


##### dowload data from https://www2.census.gov/programs-surveys/acs/data/pums/

library(survey)
library(tidyverse)

varNames <- tolower(c('ST','SERIALNO','AGEP','DDRS','DEAR','DEYE','DOUT','DPHY','DRATX','DREM','FDEARP','ESR','SCHL','RAC1P','HISP','SEX','PERNP','PINCP','SSIP','WKHP','WKW','ADJINC','PWGTP','INTP', 'OIP', 'PAP', 'RETP', 'SEMP',  'SSP', 'WAGP','RELP','REL',paste0('pwgtp',1:80)))

makeDes <- function(YR,DIR=dataFolder){

    print(YR)

    yr <- if(is.integer(YR)){ if(YR<10) paste0('0',YR) else(paste0(YR)) } else YR
    firstTry <- read_csv(paste0(DIR,'ss',yr,'pusa.csv'), n_max=5)
    colTypes <- paste(ifelse(tolower(names(firstTry))%in%varNames,'i','-'),collapse='')

    datA <- read_csv(paste0(DIR,'ss',yr,'pusa.csv'),col_types=colTypes)
    names(datA) <- tolower(names(datA))
    #stopifnot(all.equal(sort(names(datA)),sort(varNames)))

    datB <- read_csv(paste0(DIR,'ss',yr,'pusb.csv'),col_types=colTypes)
    names(datB) <- tolower(names(datB))

    if(!setequal(names(datA),names(datB)))
     warning(paste('datA and datB variable names differ:',
      paste(c(setdiff(names(datA),names(datB)),setdiff(names(datB),names(datA))),collapse='\n')))

    dat <- bind_rows(datA,datB)

    rm(datA,datB); gc()

    names(dat) <- toupper(names(dat))
    names(dat)[grep('PWGTP[0-9]+',names(dat))] <- tolower( names(dat)[grep('PWGTP[0-9]+',names(dat))])

    if(is.element('REL',names(dat))& !is.element('RELP',names(dat))) dat$RELP <- dat$REL

    print('read')

    des <-  svrepdesign(variables=~DEAR+AGEP+ST+RELP+
                            #DEYE+DOUT+DPHY+DRATX+DREM+  ## right now they're not asking for this
                            SEX+RAC1P+HISP+SCHL+FDEARP,weight=~PWGTP,repweights='pwgtp[0-9]+',scale=4/80,rscales=rep(1,80),mse=TRUE,type='JK1',data=dat)
    des$mse <- TRUE

    rm(dat); gc()
    des
}

prepDes <- function(des){
    des <- subset(des,AGEP>=25)
    des <- subset(des,AGEP<65)

    des <- subset(des,RELP!=16)

    des <- subset(des,ST!=72)

    des <- update(des,attain = cut(SCHL,breaks=c(0,15,17,19,20,21,Inf),
                                   labels=c('No HS','HS','Some College','Associates','Bachelors','>Bachelors'),
                                   ordered=TRUE))
    des$variables$SCHL <- NULL

    des <- update(des,raceEth=ifelse(HISP>1,"Hispanic",
                              ifelse(RAC1P==2,"African American",
                              ifelse(RAC1P==6| RAC1P==7,"Asian/PacIsl",
                              ifelse(RAC1P%in%c(3,4,5),'American Indian',
                              ifelse(RAC1P==1,"White","Other"))))))

    des <- update(des,ageRange = cut(AGEP,breaks=seq(24,65,10),#include.lowest=TRUE,
                                     labels=c('25-34','35-44','45-54','55-64'),ordered=TRUE))

    des
}

## for(year in c('08','09','10','11','12','13','14','15','16','17')){
##     start <- proc.time()
##     des <- makeDes(year)
##     print('design made')
##     print(proc.time()-start)

##     des <- prepDes(des)
##     save(des,file=paste0('../../data/byYear/design',year,'.RData'))
##     rm(des); gc()

##     print((proc.time()-start)/60)
## }

#setwd('deafCenter/changeOverTime25.34')


library(ape)

args = commandArgs(trailingOnly=TRUE)
file=args[1]
file_out=args[2]
terrace_size=as.numeric(args[3])

y=min(terrace_size,5)
x=ceiling(terrace_size/5)

if(terrace_size>1){
    pdf(paste(file_out,"-plot_trees.pdf",sep=""),w=y*3,h=x*3)
    par(mfrow=c(x,y),oma=c(0,0,0,0))
    for(i in 1:terrace_size){
        t=read.tree(paste(file,i,sep=""))
        plot.phylo(t,type="unrooted",no.margin=TRUE,cex=1)
        #title(paste("T",i,sep=""),cex.main=1)
    }
    invisible(dev.off())
}else{
    pdf(paste(file_out,"-plot_trees.pdf",sep=""),w=3,h=3)
    par(oma=c(1,1,1,1))
    i=1
    t=read.tree(paste(file,i,sep=""))
    plot.phylo(t,type="unrooted",no.margin=TRUE,cex=0.5)
    invisible(dev.off())
}


require(graphics)
require(Matrix)

pdf(file="plots/Experiment3a.pdf",
  width=4.5, height=4.0, family="serif", pointsize=14)

datasets = c("Adult", "Covtype", "USCensus", "KDD98")
plot_colors <- c("orangered", "black", "orange", "cornflowerblue")

data = matrix(0, 5, 7); #dataset x params
data[1,] = as.matrix(c(0.36,0.68,0.84,0.92,0.96,0.98,0.99))

for(i in 1:(nrow(data)-1)) {
  for(j in 1:ncol(data)) {
    fname = paste("results/Experiment3_",datasets[i],"_a",data[1,j],".dat",sep="")
    if( file.exists(fname) ) {
      data[i+1,j] = as.matrix(read.table(fname, sep=","))[1,1]
    }
    else {
      print(paste(fname," does not exist"))
    }
  }
}

data[1,] = 1-data[1,]

plot(   data[1,], data[5,],
        type="o",
        pch=19,
        cex=1.1,
        col=plot_colors[4],
        ylim = c(0,25),
        xlab="",
        ylab="",
        axes=FALSE,
        bg=plot_colors[4],
        log="x",
        lwd=1.1,
        lty=1
  )

axis(2, las=2)
axis(1, las=1, at=c(0.01,0.02,0.04,0.08,0.16,0.32,0.64),
      labels=c("0.99",".98",".96",".92",".84",".68",".36"))
mtext(2, text="Top-1 Slice Score", line=2.3)
mtext(1, text=expression(paste("Weight Parameter ",alpha)), line=2)

lines(data[1,2:7], data[2,2:7], type="o", pch=15, lty=1, lwd=1.1, col=plot_colors[1], bg=plot_colors[1], cex=1.0)
lines(data[1,2:7], data[3,2:7], type="o", pch=17, lty=1, lwd=1.1, col=plot_colors[2], bg=plot_colors[2], cex=1.0)
lines(data[1,2:7], data[4,2:7], type="o", pch=25, lty=1, lwd=1.1, col=plot_colors[3], bg=plot_colors[3], cex=1.0)

box()

legend( "topright",
       c("USCensus","Adult", "KDD98", "Covtype"), col=plot_colors[c(3,1,4,2)],
       pch=c(25,15,19,17), lty=c(1), lwd=c(1.1), bty="n", pt.bg=plot_colors[c(3,1,4,2)]);

text(0.02, 9, expression(paste(sigma," = 0.01n")))

dev.off()


#3g_Annotation_Pathway.R

rm(list=ls()); options(stringsAsFactors = F)
library(pSI); library(gProfileR); library(gplots); library(biomaRt); library(WGCNA); library(stringr); library(GENIE3)

load("Chinese-Signed-networkConstruction-auto.RData")
load("Chinese_human_brain_Adjust_Expr&Meta.rdata")
load("BrainGVEx_human_brain_AdjustCombatandCovariants.rdata")
load("../overlapgenes.rdata")
datExpr <- datExpr[genes,]

eigmat = MEs; colnames(eigmat) = gsub("ME","",colnames(eigmat))
kME = signedKME(t(datExpr), MEs); colnames(kME) = gsub("kME", "", colnames(kME))

ensembl = useMart("ENSEMBL_MART_ENSEMBL",dataset="hsapiens_gene_ensembl", host="feb2014.archive.ensembl.org")
bm = getBM(attributes = c("ensembl_gene_id", "external_gene_id"), filters = "ensembl_gene_id", values = a$gene, mart=ensembl)
datProbes = data.frame()
datProbes = data.frame(ensg=rownames(datExpr))
datProbes = data.frame(ensg=rownames(datExpr), symbol=bm$external_gene_id[match(rownames(datExpr), bm$ensembl_gene_id)])
rownames(datProbes) <- rownames(datExpr)

## Calculate GO enrichment of Race-associated modules
resultsGO = data.frame()
for (m in c("pink" )) {
  me_name = paste("ME", m, sep="")
  i = which(m == unique(moduleColors))

  ## GO Enrichment
  query = rownames(datExpr)[moduleColors==m]
  go = gprofiler(query, organism="hsapiens", ordered_query = F, significant = T, exclude_iea = F, region_query = F,max_p_value = 1,correction_method = "fdr", custom_bg = rownames(datExpr),
                 max_set_size = 2000,hier_filtering = "moderate", domain_size = "annotated",
                 numeric_ns = "", include_graph = F,src_filter = c("GO", "KEGG"))
  go = go[order(go$p.value),]

  num_to_plot=10
  par(oma=c(0,10,0,0))
  bp = barplot(-log10(as.numeric(go$p.value[num_to_plot:1])), main=paste("\n\n\n\n\n",m, "- GO, KEGG"), horiz=T, yaxt='n', col=m, xlab='-log10(FDR)\n',cex.main=0.7, cex.axis = .7)
  axis(2,at=bp,labels=str_wrap(go$term.name[num_to_plot:1]),tick=FALSE,las=2,cex.axis=.8);
  abline(v=-log10(0.01), col="red", lwd=2,lty=2)

  resultsGO = rbind(resultsGO, cbind(m, go))
}
write.csv(file="../NetworkComparision/ModuleTrait/Caucasian-Signed-network_gProfiler_resultsGO022619.csv", resultsGO)

resultsGOsub2 = data.frame()
for(c in sort(c("pink" ))) {
  idx = which(resultsGO$m==c)
  resultsGOsub2 = rbind(resultsGO[idx[5:1],],resultsGOsub2)
}

pdf("../NetworkComparision/ModuleTrait/Chinese-Signed-specificity-Module-GO-pink.pdf",width = 4,height=2)
par(oma=c(0,6,0,0), mar=c(5,4,2,2))
bp = barplot(-log10(resultsGOsub2$p.value), main="Chinese-Signed-Pathway-Enrichment", horiz=T, yaxt='n', col=resultsGOsub2$m, xlab='-log10(p)',cex.main=0.5, cex.axis =0.5, border=NA)
axis(2,at=bp,labels=str_wrap(resultsGOsub2$term.name,width=45),tick=FALSE,las=2,cex.axis=0.5);
abline(v=-log10(0.01), col="black", lwd=2,lty=2)
dev.off()

# Calculate Cell-Type specificity of modules
#Zhang using pSI
zhang.datExpr = read.csv("../Annotation/datExpr.zhangHuman.avgForPSI.csv",row.names=1)[,-1]
set.seed(100)
pSI.output = specificity.index(pSI.in=zhang.datExpr,bts=100,p_max=.1, e_min=0.3);
pSI.count(pSI.output)

cell.p.zhang = matrix(NA, length(unique(moduleColors)),5);  rownames(cell.p.zhang) = unique(moduleColors)
colnames(cell.p.zhang) = colnames(pSI.output)

for(mod in rownames(cell.p.zhang)) {
    f = fisher.iteration(pSI.output, rownames(datExpr)[moduleColors==mod],p.adjust = F)
    cell.p.zhang[mod,] = f$`0.05 - nominal`
}

cell.p.zhang.fdr = p.adjust(cell.p.zhang,"fdr")
dim(cell.p.zhang.fdr) = dim(cell.p.zhang); dimnames(cell.p.zhang.fdr) = dimnames(cell.p.zhang);
to_plot = cell.p.zhang.fdr[c("black" ,"magenta", "tan" ),]

colnames(eigmat) <- labels2colors(names(eigmat))
dendro.col = as.dendrogram(hclust(as.dist(1-bicor(zhang.datExpr)), method="average"))
denro.row= as.dendrogram(hclust(as.dist(1-bicor(eigmat[,c("black" ,"magenta", "tan" )])),method="average"))

pdf("../NetworkComparision/ModuleTrait/Caucasian-Signed-specificity-Module-CellType.pdf",width=6,height=5)
heatmap.2(-log10(to_plot),col=blueWhiteRed(1000,1)[500:1000],
          scale="none",trace="none",cexRow = 0.8,cexCol = .8, density.info = "none",
          colsep=0:7,rowsep=0:8,sepcolor="grey",sepwidth=c(0.02,0.02),
          srtCol=45,offsetRow=0,offsetCol=-0.5,
          Rowv=denro.row, Colv=dendro.col,
          key=T,key.xlab="-log10(P)", cellnote=signif(to_plot,1), notecex=.8, notecol="black",main="Caucasian-Signed-Enrichment")
dev.off()

out = cell.p.zhang.fdr
colnames(out) = paste("Enrichment.", colnames(out), ".FDR",sep="")
write.csv(out,file="../NetworkComparision/ModuleTrait/Caucasian-Signed-CellType.csv")

## Calculate TFBS enrichment of Disease-associated modules
resultsTFBS = data.frame()
for (m in c("black" ,"magenta", "tan" )) {
  me_name = paste("ME", m, sep="")
  i = which(m == unique(moduleColors))

  ## GO Enrichment
  query = rownames(datExpr)[moduleColors==m]
  go = gprofiler(query, organism="hsapiens", ordered_query = F, significant = T, exclude_iea = F, region_query = F,max_p_value = 1,correction_method = "fdr", custom_bg = rownames(datExpr),
                 hier_filtering = "strong", domain_size = "annotated", numeric_ns = "", include_graph = F,src_filter = c("TF"))
  go = go[order(go$p.value),]

  resultsTFBS = rbind(resultsTFBS, cbind(m, go[1:min(nrow(go),20),]))
}
write.csv(resultsTFBS,file="../NetworkComparision/ModuleTrait/Caucasian-Signed-TableS2-TFBS.csv")

colnames(kME) <- labels2colors(names(kME))
## Identify hub genes transcription factors
hubGenes = data.frame(Module=NA, Gene=NA, Symbol=NA,Rank=NA)
for (m in c("black" ,"magenta", "tan" )) {
  mod = rownames(datExpr)[moduleColors==m]
  mod = mod[order(kME[mod,m],decreasing = T)[1:20]]
  sym = datProbes[mod,2]
  hubGenes=rbind(hubGenes, data.frame(Module=m, Gene=mod, Symbol = sym, Rank=1:20))
}
hubGenes = hubGenes[-1,]

ensembl = useMart("ENSEMBL_MART_ENSEMBL",dataset="hsapiens_gene_ensembl", host="feb2014.archive.ensembl.org")
a=listAttributes(ensembl);f=listFilters(ensembl)
bm = getBM(attributes = c("ensembl_gene_id", "go_id", "go_linkage_type","goslim_goa_accession","goslim_goa_description"), filters = "ensembl_gene_id", values = hubGenes$Gene, mart=ensembl)
bm = bm[grep("transcription factor",bm$goslim_goa_description),]
hubGenes$TF = bm$goslim_goa_description[match(hubGenes$Gene, bm$ensembl_gene_id)]

write.csv(hubGenes,file="../NetworkComparision/ModuleTrait/Caucasian-Signed-HubGeneTFs.csv", row.names = F)

# incorporates TF information to construct a regulatory network
moduleLink = data.frame()
for (m in c("black" ,"magenta", "tan" )) {
  me_name = paste("ME", m, sep="")
  i = which(m == unique(moduleColors))

  ## GENIE3 Enrichment
  query = rownames(datExpr)[moduleColors==m]
  genieExpr = datExpr[query,]
  set.seed(123)
  weightMat <- GENIE3(genieExpr, regulators = intersect( hubGenes$Gene[which(hubGenes$Module==m)], hubGenes$Gene[which(hubGenes$TF!="NA")]), verbose=TRUE)
  linkList <- getLinkList(weightMat, threshold=0.3)
  moduleLink <- rbind(moduleLink,data.frame(linkList,module=m))
}
moduleLink <- data.frame(moduleLink,regulatory.symbol=datProbes$symbol[match(moduleLink$regulatoryGene,datProbes$ensg)],target.symbol=datProbes$symbol[match(moduleLink$targetGene,datProbes$ensg)])
write.csv(moduleLink,file="../NetworkComparision/ModuleTrait/Caucasian-Signed-DirectNetwork.csv", row.names = T)

#disease genes enrichment
eRNAnetwork <- read.csv("../Annotation/DiseaseGeneList.csv",header=T)
source("../Annotation/fisher_overlap.R")
table.p = matrix(NA, nrow=1, ncol=dim(eRNAnetwork)[2])
rownames(table.p) = "pink";
colnames(table.p) = colnames(eRNAnetwork)
table.or = table.p
hgnc = rownames(datExpr)
m="pink"
for(e in (1:ncol(table.p))) {
	x = length(intersect(hgnc[moduleColors=="pink"],eRNAnetwork[,e]))
	d = length(hgnc)-length(eRNAnetwork[,e])
	n = length(eRNAnetwork[,e][which(eRNAnetwork[,e]!="")])
	k = length(hgnc[moduleColors==m])
    f = dhyper(x,n,d,k)
    table.or[m,e] = length(intersect(hgnc[moduleColors==m],eRNAnetwork[,e]))
    table.p[m,e] = as.numeric(f)
}

table.p.fdr = p.adjust(table.p,"fdr")
dim(table.p.fdr) = dim(table.p); dimnames(table.p.fdr) = dimnames(table.p)
table.p.fdr[table.or<1] = 1

to_plot = as.data.frame(table.p.fdr)

p=ggplot(melt(to_plot),aes(x=variable,y=-log10(value),fill="pink")) +
  geom_bar(stat="identity",position=position_dodge(),color="black") +
  ggtitle("Chinese Signed Disorder Genes Enrichment") + theme_classic() +
  geom_abline(intercept=-log10(0.05),slope=0,lty=2) + labs(x="",y="log10(P.fdr)") +
  theme(axis.text.x=element_text(angle=55, size=10, hjust=1),legend.position = "none")
p

ggsave(p, filename = "../NetworkComparision/ModuleTrait/Chinese-Signed-specificity-Module-DisorderGene-pink.pdf",width=12,height=5)


###############################################################
# MAIN PROGRAM (local calls to several datasets at once)
###############################################################

library(ggplot2,quietly=TRUE)
library(phyloseq)
# Warnings with ggplot2 before phyloseq (I hope it is not a problem later)
#Warning messages:
#  1: replacing previous import ‘BiocGenerics::Position’ by ‘ggplot2::Position’ when loading ‘phyloseq’
#  2: replacing previous import ‘S4Vectors::Position’ by ‘ggplot2::Position’ when loading ‘DESeq2’
library(lattice,quietly=TRUE)
library(cluster,quietly=TRUE)
library(fpc,quietly=TRUE)
library(reshape2,quietly=TRUE) # Load the reshape2 package (for the melt() function)

source('robust.clustering.metagenomics.functions.r')

#######################################
# OPTION 1: Only one call per datasets
#######################################
robust.clustering.all.steps("~/RobustClustering/David2014","~/RobustClustering/David2014/data.norm_David2014.RData",'David2014',"COLLECTION_DAY")

robust.clustering.all.steps("~/RobustClustering/Ballou2016","~/RobustClustering/Ballou2016/data.norm_Ballou2016.RData",'Ballou2016',"age")

robust.clustering.all.steps("~/RobustClustering/Gajer2012","~/RobustClustering/Gajer2012/data.norm_Gajer2012.RData",'Gajer2012',"Time.in.study")

robust.clustering.all.steps("~/RobustClustering/LaRosa2014","~/RobustClustering/LaRosa2014/data.norm_LaRosa2014.RData",'LaRosa2014',"age")

# Calls for taxa subset, with different dominant percentage, with Ballou2016 dataset:
robust.clustering.all.steps("Dominant0.5perc","data.norm_Ballou2016.RData",'Ballou2016',"age","dominant",0.5)
robust.clustering.all.steps("Dominant0.5perc","data.norm_Ballou2016.RData",'Ballou2016',"age","nonDominant",0.5)
robust.clustering.all.steps("Dominant0.5perc","data.norm_Gajer2012.RData",'Gajer2012',"Time.in.study","dominant",0.5)
robust.clustering.all.steps("Dominant0.5perc","data.norm_Gajer2012.RData",'Gajer2012',"Time.in.study","nonDominant",0.5)
robust.clustering.all.steps("Dominant0.5perc","data.norm_LaRosa2014.RData",'LaRosa2014',"age","dominant",0.5)
robust.clustering.all.steps("Dominant0.5perc","data.norm_LaRosa2014.RData",'LaRosa2014',"age","nonDominant",0.5)
robust.clustering.all.steps("Dominant0.5perc","data.norm_David2014.RData",'David2014',"COLLECTION_DAY","dominant",0.5)
robust.clustering.all.steps("Dominant0.5perc","data.norm_David2014.RData",'David2014',"COLLECTION_DAY","nonDominant",0.5)

# Calls for taxa subset, with David2014 dataset:
# Subset dominant taxa:
robust.clustering.all.steps("~/RobustClustering/David2014","~/RobustClustering/David2014/data.norm_David2014.RData",'David2014',"COLLECTION_DAY",'dominant',1)
# Subset nonDominant taxa:
robust.clustering.all.steps("~/RobustClustering/David2014","~/RobustClustering/David2014/data.norm_David2014.RData",'David2014',"COLLECTION_DAY",'nonDominant')
# Subset all taxa at genes level:
robust.clustering.all.steps("~/RobustClustering/David2014","~/RobustClustering/David2014/data.norm_David2014.RData",'David2014',"COLLECTION_DAY",'all','genus')
# Subset dominant taxa at genes level:
robust.clustering.all.steps("~/RobustClustering/David2014","~/RobustClustering/David2014/data.norm_David2014.RData",'David2014',"COLLECTION_DAY",'dominant','genus')
# Subset nonDominant taxa at genes level:
robust.clustering.all.steps("~/RobustClustering/David2014","~/RobustClustering/David2014/data.norm_David2014.RData",'David2014',"COLLECTION_DAY",'nonDominant','genus')

###########################################################
# OPTION 2: Call to the independent functions, step by step
###########################################################
# A) ROBUST CLUSTERING COMPUTATION
setwd("RobustClustering/David2014")
load('data.norm_David2014.RData')
list.results <- robust.clustering(data.norm,"COLLECTION_DAY","David2014")
rm(data.norm)

setwd("RobustClustering/Ballou2016")
load('data.norm_Ballou2016.RData')
list.results <- robust.clustering(data.norm,"age","Ballou20106")
rm(data.norm)

setwd("RobustClustering/Gajer2012")
load('data.norm_Gajer2012.RData')
list.results <- robust.clustering(data.norm,"Time.in.study","Gajer2012")
rm(data.norm)

setwd("RobustClustering/LaRosa2014")
load('data.norm_LaRosa2014.RData')
list.results <- robust.clustering(data.norm,"age","LaRosa2014")
rm(data.norm)

########################################
# B) PLOT GRAPHS
# Using next loop requires you are in a directory where there are a folder named as the dataset (ej. 'RobustClustering/' with subfolders 'David2014', 'Ballou2016', etc). Each subfolder should have at least the RData with the phyloseq object called data.norm (in these examples <data.norm_XXdatasetXX.RData>).
for (dataset in c('David2014','Ballou2016','Gajer2012','LaRosa2014')){
  setwd(dataset)
  load(paste('eval.arrays_',dataset,'.RData',sep=''))
  plot.robust.clustering.all.together.formatted(eval.array4d, eval.SIpoints, eval.Kvalues)
  setwd('..')
} # end-for

########################################
# C) AUTOMATIC CLUSTERING DECISION
for (dataset in c('David2014','Ballou2016','Gajer2012','LaRosa2014')){
  setwd(dataset)
  load(paste('data.norm_',dataset,'.RData',sep=''))
  load(paste('eval.arrays_',dataset,'.RData',sep=''))
  switch(dataset,
         David2014={ var.graph="COLLECTION_DAY" },
         Chicks={ var.graph="age" },
         Gajer2012={ var.graph="Time.in.study" },
         LaRosa2014={ var.graph="age" },
         { var.graph=NULL;
           print('ERROR: dataset without var.color defined!!')}
  ) #end-switch-alg
  data.norm <- robust.clustering.decision(data.norm,eval.array4d,var.graph)
    rm(data.norm)
  setwd('..')
} # end-for


library(GenomicRanges)
library(qvalue)
library(smatr)

##################
# compare to ASE

# data for Albert & Noori ASE data
load("R_jointASEData.RData")
# eQTL table
load("R_allPeaksODPad_161213.RData")
# peak-based effect sizes for eQTL, calculated on uncorrected data to preserve "natural" effect sizes
load("peakModel.RData")

# for pulling LODs at individual genes and genome positions
load("scanoneLODS_OD_stranded.RData") # file is ~1Gb
load("marker.LD.RData") # file is 130Mb

# need to retstrict marker.LD to the set that is present in scanoneLODS
marker.LD.subset <- lapply(marker.LD, function(x){x[rownames(x) %in% colnames(scanoneLODS.OD[[2]]), colnames(x) %in% colnames(scanoneLODS.OD[[2]])]})

# load gene info to make vectors relating systematic to common names
geneAnnotation = read.table("ensemblGenes_ensembl83_160307_MOD.txt", sep="\t", stringsAsFactors=FALSE, head=TRUE)
rownames(geneAnnotation) = geneAnnotation[,1]
allNames <- geneAnnotation[, "geneName"]
names(allNames) <- geneAnnotation[,1]
allNames[which(allNames == "")] <- names(allNames)[which(allNames == "")]
allNamesInv <- names(allNames)
names(allNamesInv) <- allNames

localeQTL <- allPeaksODPad[allPeaksODPad$cis,]
ncol(localeQTL)
# 2969

# if there are more than 1 local eQTL, keep the one closer to the gene
# for each gene, how often is it there:
# table(localeQTL$gene)

# run the filter
localeQTL <- cbind(localeQTL, table(localeQTL$gene)[localeQTL$gene])
colnames(localeQTL)[ncol(localeQTL)] <- "Freq"
throwOutDecider <- rownames(localeQTL[localeQTL$Freq > 1,])
throwOutDeciderBool <- sapply(throwOutDecider, function(x){
    theseeQTL <- localeQTL[localeQTL$gene == localeQTL[x,]$gene, ]
    theseDists <- abs(theseeQTL$marker.gcoord - theseeQTL$gene.gcoord)
    abs(localeQTL[x,]$marker.gcoord - localeQTL[x,]$gene.gcoord) != min(theseDists)
})
localeQTL <- localeQTL[!rownames(localeQTL) %in% names(throwOutDeciderBool[throwOutDeciderBool]),]
# 2969 going in, 2884 coming out

# the peak table above uses lm.coeffs from scaled data
# add lm.coeffs from peakModel that was fit using the covariates in the same model
# these should be on the proper, "natural" scale for comparison to ASE
naturalLMCoeff <- sapply(localeQTL$gene, function(x){
    thisPM <- peakModel[[x]]
    thisRowName <- rownames(localeQTL)[which(localeQTL$gene == x)]
    print(thisRowName)
    thisPM[thisRowName, "lm.coeff"]
})
# sanity check
cor.test(naturalLMCoeff, localeQTL$"lm.coeff")
# r = 0.69, rho = 0.94

pdf("ASE_lmCoeffsScaledVsNatural.pdf")
plot(naturalLMCoeff, localeQTL$"lm.coeff", xlab="natural scale", ylab="scaled", col="#00000022")
abline(0, 1, col="grey", lwd=2, lty=2)
dev.off()
# interesting - the "natural" ones are much more compressed (i.e., mostly smaller), but have a few big outliers

localeQTL <- cbind(localeQTL, naturalLMCoeff)

# width of the local eQTL:
summary(
    sapply(localeQTL$CI.r, function(x){as.numeric(strsplit(strsplit(x, ":")[[1]][2], "_")[[1]][1])})
    - sapply(localeQTL$CI.l, function(x){as.numeric(strsplit(strsplit(x, ":")[[1]][2], "_")[[1]][1])})
)
#Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
#0    5054   16208   76858   45540 1338215

############
# some ASE data wrangling

qVals <- apply(jointASEData[,c("NooriB", "AlbertB")], 2, function(x){
    ret <- rep(1, length(x))
    ret[x < 1] <- qvalue(x[x< 1])$q
    ret
})

# make an average ASE between the two ASE datasets
jointFC <- apply(jointASEData, 1, function(x){mean(c(x[1], x[2]))})

# make a decider for significance (Bonferroni)
sigDecider <- rep(0, nrow(jointASEData))
names(sigDecider) <- rownames(jointASEData)
sigDecider[jointASEData[,"NooriB"] < 0.05/nrow(jointASEData) | jointASEData[,"AlbertB"] < 0.05/nrow(jointASEData)] <- 1
sigDecider[jointASEData[,"NooriB"] < 0.05/nrow(jointASEData) & jointASEData[,"AlbertB"] < 0.05/nrow(jointASEData)] <- 2

# FDR-based threshold (not used in paper)
sigDeciderFDR <- rep(0, nrow(jointASEData))
names(sigDeciderFDR) <- rownames(jointASEData)
sigDeciderFDR[qVals[,"NooriB"] < 0.05 | qVals[,"AlbertB"] < 0.05] <- 1
sigDeciderFDR[qVals[,"NooriB"] < 0.05 & qVals[,"AlbertB"] < 0.05] <- 2

# append the ASE info to the eQTL data

# !!!****NOTE that we need to invert the ASE sign to make consistent with eQTL data***!!!
# previous ASE data was polarized as "positive = higher in BY"
# current eQTL are other way around

localeQTL <- cbind(localeQTL, -jointFC[localeQTL$gene], sigDecider[localeQTL$gene], sigDeciderFDR[localeQTL$gene])
colnames(localeQTL)[(ncol(localeQTL)-2): ncol(localeQTL)] <- c("ASE", "sigDeciderBonferroni", "sigDeciderFDR")

#save(localeQTL, file="R_localeQTL_170222.RData")

############
# load the previously saved table here, as the basis for the remaining analyses
load("R_localeQTL_170222.RData")
rownames(localeQTL) <- localeQTL$gene

# for every local eQTL, pull the ASE signal

pdf("ASE_vs_eQTLFC.pdf", width=12, height=12)
plotCol <- rep("#00000022", nrow(localeQTL))
plotCol[localeQTL$gene %in% names(sigDecider)[sigDecider == 1]] <- "#FF000022"
plotCol[localeQTL$gene %in% names(sigDecider)[sigDecider == 2]] <- "red"
names(plotCol) <- localeQTL$gene

par(mfrow=c(2,2))

plot(localeQTL$ASE, localeQTL$"naturalLMCoeff" * 2, pch=19, col=plotCol, ylab="local eQTL fold change", xlab="log2(ASE signal)", main="significant eQTL")
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
abline(0, 1, lwd=2, lty=2, col="grey")

plot(localeQTL$ASE, localeQTL$"naturalLMCoeff" * 2, pch=19, col=plotCol, ylab="local eQTL fold change", xlab="log2(ASE signal)", main="significant eQTL", xlim=c(-2, 2), ylim=c(-2, 2))
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
abline(0, 1, lwd=2, lty=2, col="grey")

plot(-jointFC[localeQTL$gene], localeQTL$"naturalLMCoeff" * 2, pch=19, col=plotCol, ylab="local eQTL fold change", xlab="log2(ASE signal)", type="n", main="significant ASE and eQTL")
for(i in localeQTL$gene){
    if (i %in% rownames(jointASEData) & sigDecider[i] > 0){
        lines(-jointASEData[i, c("NooriFC", "AlbertFC")], rep(localeQTL[localeQTL$gene == i, "naturalLMCoeff"] * 2, 2), col=plotCol[i])
    }
}
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
abline(0, 1, lwd=2, lty=2, col="grey")

plot(-jointFC[localeQTL$gene], localeQTL$"naturalLMCoeff" * 2, pch=19, col=plotCol, ylab="local eQTL fold change", xlab="log2(ASE signal)", type="n", main="significant ASE and eQTL")
for(i in localeQTL$gene){
    if (i %in% rownames(jointASEData)){
        lines(-jointASEData[i, c("NooriFC", "AlbertFC")], rep(localeQTL[localeQTL$gene == i, "naturalLMCoeff"] * 2, 2), col=plotCol[i])
    }
}
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
abline(0, 1, lwd=2, lty=2, col="grey")

dev.off()

# SMA analysis
xForLM <- -jointFC[localeQTL$gene]
yForLM <- localeQTL$"naturalLMCoeff" * 2
sma(yForLM ~ xForLM, na.action="na.omit")
#slope=0.95 (0.91-0.98)

# overall numbers for agreement:
# how many genes have ASE?
length(which(sigDecider == 2))
# Bonferroni: 121 both, 598 either

# how many genes have a local eQTL and are included in the ASE dataset?
nrow(localeQTL[!is.na(localeQTL$sigDeciderBonferroni),])
# 1974

# how many local eQTL have ASE in at least one (both) datasets?
nrow(localeQTL[!is.na(localeQTL$sigDeciderBonferroni) & localeQTL$sigDeciderBonferroni > 0,])
# Bonferroni: > 0: 451, 2: 100

# how many local eQTL have NO ASE in at least one (both) datasets?
nrow(localeQTL[!is.na(localeQTL$sigDeciderBonferroni) & localeQTL$sigDeciderBonferroni == 0,])
# Bonf: 1523

# are sig ASE and local eQTL enriched:
# the universe in these tests is the genes with measured ASE
fisher.test(cbind(
    c(length(names(sigDecider)[sigDecider > 0 & names(sigDecider) %in% localeQTL$gene]),
        length(names(sigDecider)[sigDecider == 0 & names(sigDecider) %in% localeQTL$gene])),
    c(length(names(sigDecider)[sigDecider > 0 & !(names(sigDecider) %in% localeQTL$gene)]),
        length(names(sigDecider)[sigDecider == 0 & !(names(sigDecider) %in% localeQTL$gene)])))
)
# Bonf: p < 2.2e-16, odds = 2.5

fisher.test(cbind(
    c(length(names(sigDecider)[sigDecider == 2 & names(sigDecider) %in% localeQTL$gene]),
        length(names(sigDecider)[sigDecider < 2 & names(sigDecider) %in% localeQTL$gene])),
    c(length(names(sigDecider)[sigDecider == 2 & !(names(sigDecider) %in% localeQTL$gene)]),
        length(names(sigDecider)[sigDecider < 2 & !(names(sigDecider) %in% localeQTL$gene)])))
)
# p = 2.5e-8, odds = 3.4

# do eQTL with/without ASE differ in effect size?
wilcox.test(
abs(2 * localeQTL[!is.na(localeQTL$sigDeciderBonferroni) & localeQTL$sigDeciderBonferroni == 1, "naturalLMCoeff"]),
abs(2 * localeQTL[!is.na(localeQTL$sigDeciderBonferroni) & localeQTL$sigDeciderBonferroni == 2, "naturalLMCoeff"])
)
# 0 vs >=0, 0 vs 1, 0 vs 2: p<2.2e-16
# 2 vs 1: p = 5e-7

pdf("eQTLFCByASESignificance.pdf")
boxplot(list(
    abs(2 * localeQTL[!is.na(localeQTL$sigDeciderBonferroni) & localeQTL$sigDeciderBonferroni == 0, "naturalLMCoeff"]),
    abs(2 * localeQTL[!is.na(localeQTL$sigDeciderBonferroni) & localeQTL$sigDeciderBonferroni == 1, "naturalLMCoeff"]),
    abs(2 * localeQTL[!is.na(localeQTL$sigDeciderBonferroni) & localeQTL$sigDeciderBonferroni == 2, "naturalLMCoeff"])
), names=0:2, xlab="number of significant ASE datasets", ylab="absolute eQTL log2(fold change)", main="", ylim=c(0,3))
for(i in 0:2){
    points(jitter(rep(i+1, length(which(!is.na(localeQTL$sigDeciderBonferroni) & localeQTL$sigDeciderBonferroni == i))), amount=0.3), abs(2 * localeQTL[!is.na(localeQTL$sigDeciderBonferroni) & localeQTL$sigDeciderBonferroni == i, "naturalLMCoeff"]), col="#0000FF22", pch=19, cex=0.5)
}
dev.off()

#################################
# plot all ASE with eQTL r, irrespective of eQTL sig

# use Josh's recomputed local FCs at all genes (irrespective of local eQTL significance):
load("cisModel.effects.RData")

# compare these to the ones in the eQTL table (which have background QTL)
pdf("ASE_cisEffectComparison_170324.pdf")
plot(localeQTL$naturalLMCoeff, cisModel.effects[localeQTL$gene], col="#00000022")
abline(0, 1, lwd=2, lty=2, col="grey")
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
dev.off()
# there's a handful of cases where the new cis effects are more extreme than the local eQTL
# probably because closeness to a trans eQTL is not considered here

# plot all genes, irrespective of eQTL or ASE sig (but can color in)
allFCs <- cbind(-jointFC, 2*cisModel.effects[names(jointFC)])
colnames(allFCs) <- c("ASE_fc", "eQTL_fc")

plotColsASESig <- rep("green", nrow(allFCs)) # to verify the data selection works. THere should be no green on the plot
plotColsASESig[sigDecider[rownames(allFCs)] == 2] <- "red"
plotColsASESig[sigDecider[rownames(allFCs)] == 1] <- "#FF000022"
names(plotColsASESig) <- rownames(allFCs)

pdf("ASE_all_FCs.pdf", width=12, height=12)
par(mfrow=c(2,2))
plot(allFCs, col="#00000022", xlab="log2(ASE fold change)", ylab="log2(eQTL fold change)", pch=19, main="all genes")
abline(0, 1, lwd=2, lty=2, col="grey")
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")

plot(allFCs[sigDecider[rownames(allFCs)] > 0,], col=plotColsASESig[sigDecider[rownames(allFCs)] > 0], xlab="log2(ASE fold change)", ylab="log2(eQTL fold change)", pch=19, main="genes with significant ASE")
points(allFCs[sigDecider[rownames(allFCs)] > 0 & !rownames(allFCs) %in% localeQTL$gene,])
abline(0, 1, lwd=2, lty=2, col="grey")
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")
legend("topleft", box.lty=0,
col=c("red", "#FF000022", "black"),
legend=c("2 significant ASE datasets", "1 significant ASE dataset", "no local eQTL"),
pch=c(19, 19, 1))

textDecider <- (sigDecider[rownames(allFCs)] == 2 & !rownames(allFCs) %in% localeQTL$gene & abs(allFCs[,1]) >= 1) #| (sigDecider[rownames(allFCs)] >0 & !rownames(allFCs) %in% localeQTL$gene & sign(jointASEData[,"NooriFC"])[rownames(allFCs)] == sign(jointASEData[,"AlbertFC"])[rownames(allFCs)] & abs(allFCs[,1]) > 0.5)

text(allFCs[textDecider,], labels = allNames[rownames(allFCs)[textDecider]], pos=2)

plot(allFCs[sigDecider[rownames(allFCs)] > 0,], col=plotColsASESig[sigDecider[rownames(allFCs)] > 0], xlab="log2(ASE fold change)", ylab="log2(eQTL fold change)", pch=19, main="genes with significant ASE")
abline(0, 1, lwd=2, lty=2, col="grey")
abline(h=0, lwd=2, lty=2, col="grey")
abline(v=0, lwd=2, lty=2, col="grey")

for(i in rownames(allFCs)[sigDecider[rownames(allFCs)] > 0]){
    lines(-jointASEData[i,c("AlbertFC", "NooriFC")], rep(allFCs[i, 2], 2), col=plotColsASESig[i])
}
points(allFCs[sigDecider[rownames(allFCs)] > 0 & !rownames(allFCs) %in% localeQTL$gene,])

dev.off()

###################
# prepare table for paper

paralogInfo <- read.table("paralogs_ygob_2012.txt", stringsAsFactors=FALSE, head=TRUE, sep="\t", quote="\"")

# extend the "allFC" object with eQTL info
# need to look up local LODs
# at every gene, pull the closest marker and calculate a fold change
getClosestMarker <- function(markerDat, thisChr, thisPosition){
    thesePositions <- sapply(colnames(markerDat[[thisChr]]), function(x){as.integer(strsplit(strsplit(x, ":")[[1]][2], "_")[[1]][1])})
    colnames(markerDat[[thisChr]])[which.min(abs(thesePositions - thisPosition))][1]
}

allLocalLODs <- sapply(rownames(allFCs)[geneAnnotation[rownames(allFCs),"chr"] != "chrM"], function(thisGene){
    ret <- NA
    print(thisGene)
    thisClosestMarker <- getClosestMarker(marker.LD.subset, geneAnnotation[thisGene, "chr"], mean(as.numeric(geneAnnotation[thisGene, c("start", "end")])))
    print(thisClosestMarker)
    try({
        ret <- scanoneLODS.OD[[2]][thisGene,thisClosestMarker]
    })
    ret
})

allFCsWithSig <- data.frame(allNames[rownames(allFCs)], allFCs, sigDecider[rownames(allFCs)], allLocalLODs[rownames(allFCs)], jointASEData[rownames(allFCs),1:4])
colnames(allFCsWithSig)[1:5] <- c("geneName", "ASE_fc", "eQTL_fc", "numberSig_ASESets", "local_eQTL_LOD")
# set NA LODs to -1 to avoid having to test for !is.na
allFCsWithSig$eQTL_LOD[is.na(allFCsWithSig$local_eQTL_LOD)] <- -1

# also attach paralogy info
allFCsWithSig <- cbind(allFCsWithSig,
as.numeric(sapply(rownames(allFCsWithSig), function(x){paralogInfo[paralogInfo[,"Gene1"] == x | paralogInfo[,"Gene2"] == x, "AA_percent_id"]})),
    sapply(rownames(allFCsWithSig), function(x){
        ret=NA
        if(x %in% paralogInfo[,"Gene1"]){ret=allNames[paralogInfo[paralogInfo[,"Gene1"] == x, "Gene2"]]}
        if(x %in% paralogInfo[,"Gene2"]){ret=allNames[paralogInfo[paralogInfo[,"Gene2"] == x, "Gene1"]]}
        ret
    })
)
colnames(allFCsWithSig)[(ncol(allFCsWithSig)-1):ncol(allFCsWithSig)] <- c("paralogIdentity", "paralogGene")

save(allFCsWithSig, file="R_allFCsWithSig_170324.RData")

# table for paper
write.table(allFCsWithSig, file="ASE_table4paper_170324.txt", col.names=TRUE, row.names=TRUE, quote=FALSE, sep="\t")

############################################
# variant density in promoter

# load variant numbers per gene
load("R_promoterVariantsPerGene_171020.RData")

pdf("ASE_promoterVariantsVseQTL.pdf", width=10, height=5)
par(mfrow=c(1,2))
plot(promoterVariantsPerGene[rownames(allFCs)], abs(allFCs[,1]), xlab="number of promoter variants", ylab="abs(log2(ASE fold change))", col="#00000022")
plot(promoterVariantsPerGene[rownames(allFCs)], abs(allFCs[,2]), xlab="number of promoter variants", ylab="abs(log2(eQTL fold change))", col="#00000022")
dev.off()

cor.test(promoterVariantsPerGene[rownames(allFCs)], abs(allFCs[,1]), method="s")
# rho=0.04, p=0.014

cor.test(promoterVariantsPerGene[rownames(allFCs)], abs(allFCs[,2]), method="s")
# rho=0.23, p < 2.2e-16


dat = read.csv('Results.csv')

dev.new()
setEPS()

postscript("graph.eps")

plot(y=dat$Baseline, x=dat$NumRecs,	xlim=c(1,4), ylim=c(0,1), col="red", pch=19, yaxt="n", xaxt="n", ylab="Success Rate",
	xlab="Number of Recommendations", main="Success Rate by Number of Recommendations")

pos = c(1,2,3,4)
vals = c(1,3,5,10)

axis(1, at=pos, labels=vals)

pos2 = c(0.2, 0.4, 0.6, 0.8)
vals = c("20%", "40%", "60%", "80%")

axis(2, at=pos2, labels=vals)

abline(h=pos2,v=pos, col="gray",lty=3)

lines(y=dat$Baseline, x=dat$NumRecs, col="red")

points(y=dat$UserBased10, x=dat$NumRecs, col="darkorchid4", pch=19)
lines(y=dat$UserBased10, x=dat$NumRecs, col="darkorchid4")

points(y=dat$UserBased20, x=dat$NumRecs, col="darkgreen", pch=19)
lines(y=dat$UserBased20, x=dat$NumRecs, col="darkgreen")

points(y=dat$ItemBased, x=dat$NumRecs, col="blue", pch=19)
lines(y=dat$ItemBased, x=dat$NumRecs, col="blue")

legend("bottomright", "Algorithm", bg="white", c("User Based 10", "User Based 20", "Baseline", "Item Based"),
	inset=.03, fill=c("darkorchid4","darkgreen","red","blue"))

dev.off()

graphics.off()