#!/usr/bin/Rscript

## bootstrap.r -- runs a bootstrap process across a genotype file

## Author: David Eccles (gringer), 2009 <programming@gringer.org>

## simplegt-formatted input file
genotypes.inFile = "";
## columns of genotype file to consider cases/controls
## (first value is ignored, so can be used as a group identifier)
casecontrolColumns.inFile = "cases_controls.txt";

## number of subsamples to use for bootstrapping
replicates.proportion = 0.50;
replicates.cases = NULL; # if NULL, will be replicates.proportion or 5 less, whichever is smaller
replicates.controls = replicates.cases;
rep.case.outFile = "";
rep.control.outFile = "";
createReplicates = TRUE; # if false, use existing replicate data
## number of bootstraps to carry out
bootstrap.count = 100;

## file to place bootstrapped results into
bootstraps.outFile = "bootstrap_results.csv";

## should the output values be sorted within each marker?
sortValues <- FALSE;

## controls are on the first line of this file (normally expect cases first)
controlsFirst <- FALSE;

## method to use for calculating results
## current options are Adelta, GTdelta, Chisqmax
processMethod <- "Adelta";

## consider complementary alleles to be the same (allows different
## genotyping methods for the same mutation to be combined)
combineComplementary <- TRUE;

## keep zero counts separate when calculating chi^2 (produces invalid
## results when zero counts are observed for any genotype)
strictChi <- FALSE;

usage <- function(){
  cat("usage: ./bootstrap.r",
      "<case/control column file> [options]\n");
  cat("\nOther Options:\n");
  cat("-help               : Only display this help message\n");
  cat("-input              : File containing genotype data\n");
  cat("-controlfile        : File containing column data for cases/controls\n");
  cat("-repfiles <f1> <f2> : Files containing replicate columns (for repeat experiments)\n");
  cat("-controlsfirst      : case/control file has controls as first line\n");
  cat("-count              : Number of bootstrapts to carry out\n");
  cat("-casereps           : case subpopulation size for boostraps (overrides proportion)\n");
  cat("-controlreps        : control subpopulation size for boostraps (overrides proportion)\n");
  cat("-proportion         : proportion of individuals for boostraps (currently ", replicates.proportion,")\n", sep="");
  cat("-sort               : sort bootstrap results by value\n");
  cat("-strictGT           : Keep complementary alleles separate (don't combine)\n");
  cat("-strictChi          : Respect zero counts in chi^2 table, creates null results\n");
  cat("-output             : output file for results\n");
  cat("-method             : method to use for calculating results\n");
  cat("                      (Adelta, GTdelta, gChisq, Chisqmax, ChisqmaxAll, ShowValues)\n");
  cat("\n");
}

argLoc <- 1;

argLoc <- grep("--args",commandArgs()) + 1; # hack to get around R v2.4
                                            # issue stopping
                                            # commandArgs(TRUE) from
                                            # working
while(!is.na(commandArgs()[argLoc])){
  if(file.exists(commandArgs()[argLoc])){ # file existence check
    casecontrolColumns.inFile <- commandArgs()[argLoc];
  } else {
    if(commandArgs()[argLoc] == "-help"){
      usage();
      quit(save = "no", status=0);
    }
    else if(commandArgs()[argLoc] == "-input"){
      genotypes.inFile <- commandArgs()[argLoc+1];
      argLoc <- argLoc + 1;
    }
    else if(commandArgs()[argLoc] == "-controlfile"){
      casecontrolColumns.inFile <- commandArgs()[argLoc+1];
      argLoc <- argLoc + 1;
    }
    else if(commandArgs()[argLoc] == "-repfiles"){
      rep.case.outFile <- commandArgs()[argLoc+1];
      rep.control.outFile  <- commandArgs()[argLoc+2];
      createReplicates <- FALSE;
      argLoc <- argLoc + 2;
    }
    else if(commandArgs()[argLoc] == "-controlsfirst"){
      controlsFirst <- TRUE;
    }
    else if(commandArgs()[argLoc] == "-sort"){
      sortValues <- TRUE;
    }
    else if(commandArgs()[argLoc] == "-strictGT"){
      combineComplementary <- FALSE;
    }
    else if(commandArgs()[argLoc] == "-strictChi"){
      strictChi <- TRUE;
    }
    else if(commandArgs()[argLoc] == "-proportion"){
      replicates.proportion <- as.numeric(commandArgs()[argLoc+1]);
      cat(file=stderr(), "setting proportion to", replicates.proportion,
          "(",replicates.proportion*100,"% )\n");
      argLoc <- argLoc + 1;
    }
    else if(commandArgs()[argLoc] == "-casereps"){
      replicates.cases <- as.numeric(commandArgs()[argLoc+1]);
      argLoc <- argLoc + 1;
    }
    else if(commandArgs()[argLoc] == "-count"){
      bootstrap.count <- as.numeric(commandArgs()[argLoc+1]);
      argLoc <- argLoc + 1;
    }
    else if(commandArgs()[argLoc] == "-controlreps"){
      replicates.controls <- as.numeric(commandArgs()[argLoc+1]);
      argLoc <- argLoc + 1;
    }
    else if(commandArgs()[argLoc] == "-output"){
      bootstraps.outFile <- commandArgs()[argLoc+1];
      argLoc <- argLoc + 1;
    }
    else if(commandArgs()[argLoc] == "-method"){
      processMethod <- commandArgs()[argLoc+1];
      argLoc <- argLoc + 1;
    }
    else {
      cat("Error: Argument '",commandArgs()[argLoc],
          "' is not understood by this program\n\n", sep="");
      usage();
      quit(save = "no", status=0);
    }
  }
  argLoc <- argLoc + 1;
}

if(!file.exists(casecontrolColumns.inFile)){
  cat("Error: No valid case/control column file given\n\n");
  usage();
  quit(save = "no", status=1);
}

if((bootstraps.outFile != "") && (file.exists(bootstraps.outFile))){
  cat("Error: Output file (", bootstraps.outFile,
      ") exists, please delete it before running this program\n\n",sep="");
  usage();
  quit(save = "no", status=1);
}

if(!createReplicates && (!file.exists(rep.case.outFile) || !file.exists(rep.control.outFile))){
  cat("Error: Replicate files do not exist\n\n");
  usage();
  quit(save = "no", status=1);
}

## carries out a chisquare test of a vector, assuming entries 1..n/2
## are observed, n/2+1..n are expected counts.
vector.chisq <- function(in.vector){
  if(!is.vector(in.vector)){
    stop("Can only be called on a vector");
  }
  if(length(in.vector) %% 2 == 1){
    stop("observed, expected must be same length");
  }
  obs <- in.vector[seq(1,length(in.vector)/2)];
  exp <- in.vector[seq(length(in.vector)/2+1,length(in.vector))];
  ## last section taken (and simplified) from chisq.test code
  ## rescale expected values to same totals as observed values
  E = sum(obs) * exp / sum(exp);
  chisq.values <- (obs-E)^2/E;
  ## !is.nan removes NaN values from result, so cells with zero
  ## !expected counts are ignored
  if(!strictChi){
    return(sum(chisq.values[!is.nan(chisq.values)]));
  }  else {
    return(sum((obs-E)^2/E));
  }
  ## don't warn about counts < 5 -- it will flood the output with
  ## warnings for markers in a whole genome
}

GTCalc <- function(in.genotypes, columns.pop1, columns.pop2, method = "Adelta"){
  num.reps <- dim(columns.pop1)[2];
  ## make everything upper case (simplifies search expressions)
  in.genotypes <- toupper(in.genotypes);
  if(combineComplementary){
    ## substitute complementary alleles
    in.genotypes <- gsub("T","A",in.genotypes);
    in.genotypes <- gsub("G","C",in.genotypes);
    in.genotypes <- gsub("CA","AC",in.genotypes);
  }
  ## calculate major/minor alleles
  gt.counts <- table(in.genotypes);
  if(sum(gt.counts) == 0){ # no individuals
    return(rep(NA, num.reps));
  }
  allele.names <- unique(sub("(A|C|G|T)","",names(gt.counts)));
  homozygous.counts <- sort(gt.counts[paste(allele.names, allele.names, sep="")]);
  if(sum(homozygous.counts) == 0){ # no homozygous individuals
    return(rep(NA, num.reps));
  }
  minor.allele <- substr(names(homozygous.counts[1]),1,1);
  major.allele <- substr(names(homozygous.counts[length(homozygous.counts)]),1,1);
  if(major.allele == minor.allele){ # no minor allele (from homozygous counts)
    het.potentials <- names(gt.counts[grep(major.allele,names(gt.counts))]);
    if(length(het.potentials) == 1){ # no heterozygotes found, so no minor allele
      minor.allele <- "";
#      return(rep(NA, num.reps));
    } else {
      het.name <- het.potentials[het.potentials !=
                                 paste(major.allele, major.allele, sep="")];
      minor.allele <- sub(major.allele, "", het.name);
    }
  }
  ## recode tables as Major/minor (as plink says it *should* be doing)
  ## by substituting alleles for M/m
  ## Note: everything that isn't M/m is considered an invalid
  ## genotype, so if mutation is trimorphic or tetramorphic, then only
  ## the most frequent homozygotes and least frequent homozygotes will
  ## be counted
  if(minor.allele != ""){
    in.genotypes <- gsub(major.allele,"M",gsub(minor.allele,"m",in.genotypes));
  } else {
    in.genotypes <- gsub(major.allele,"M",in.genotypes);
  }
  in.genotypes <- sub("Mm","mM",in.genotypes); # make heterozygotes consistently mM
  in.genotypes <- factor(in.genotypes, levels = c("MM","mM","mm", NA));
  ## generate table based on genotype frequencies
  table1 <- apply(columns.pop1, 2, function(x){table(in.genotypes[x], exclude = NULL)})
  table2 <- apply(columns.pop2, 2, function(x){table(in.genotypes[x], exclude = NULL)})
  ## replace <NA> row name with "XX"
  rownames(table1)[is.na(rownames(table1))] <- "XX";
  rownames(table2)[is.na(rownames(table2))] <- "XX";
  ## return NA if there are no [non-null] genotypes for either population
  if((sum(table1[c("MM","mM","mm"),]) == 0) ||
     (sum(table2[c("MM","mM","mm"),]) == 0)){
    return(rep(NA, num.reps));
  }
  ## at this point, table1/2 will look like the following:
  ##    [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
  ## MM   12   11   10   10   11   12   12   12   11    11
  ## mM   41   42   44   43   42   43   42   43   44    43
  ## mm   32   32   31   32   32   30   31   30   30    31
  ## XX    0    0    0    0    0    0    0    0    0     0
  ## table1: cases, table2: controls
  ## Rows are genotypes, columns are bootstrap number. MM,mM,mm are
  ## the raw genotype counts, XX is a null/bad genotype.
  ## Next step, calculate appropriate statistic
  if(method == "GTdelta") { # genotype freq based delta
    ## remove null values, scale for number of individuals
    table1a <- table1[c("MM","mM","mm"),]/
      colSums(as.matrix(table1[c("MM","mM","mm"),]));
    table2a <- table2[c("MM","mM","mm"),]/
      colSums(as.matrix(table2[c("MM","mM","mm"),]));
    retVal <-
      colSums(abs(table1a - table2a))/2;
  } else if(method == "Adelta") { # allele freq based delta
    ## convert to allele frequencies, scale for number of [non-null]
    ## individuals
    table1a <- (table1["MM",]+table1["mM",]/2) /
      colSums(as.matrix(table1[c("MM","mM","mm"),]));
    table2a <- (table2["MM",]+table2["mM",]/2) /
      colSums(as.matrix(table2[c("MM","mM","mm"),]));
    ## note: if only two alleles, then comparing one allele is the
    ## same as comparing both and dividing by two
    retVal <-
      abs(table1a - table2a);
  } else if((method == "Chisqmax")|| # Max chi square
            (method == "ChisqmaxAll")||
            (method == "gChisq")||
            (method == "ShowValues")) {

    ## calculations for observed, expected derived from plink code
    obs.1 <- colSums(as.matrix(table1[c("mm","mM","MM"),]));
    obs.2 <- colSums(as.matrix(table2[c("mm","mM","MM"),]));
    obs.all <- obs.1+obs.2;
    obs.mm <- (table1["mm",] + table2["mm",]);
    obs.mM <- (table1["mM",] + table2["mM",]);
    obs.MM <- (table1["MM",] + table2["MM",]);
    obs.m <- 2*obs.mm + obs.mM;
    obs.M <- 2*obs.MM + obs.mM;
    exp.1.m <- (obs.1 * obs.m) / obs.all;
    exp.1.M <- (obs.1 * obs.M) / obs.all;
    exp.2.m <- (obs.2 * obs.m) / obs.all;
    exp.2.M <- (obs.2 * obs.M) / obs.all;
    exp.1.mm <- (obs.1 * obs.mm) / obs.all;
    exp.1.mM <- (obs.1 * obs.mM) / obs.all;
    exp.1.MM <- (obs.1 * obs.MM) / obs.all;
    exp.2.mm <- (obs.2 * obs.mm) / obs.all;
    exp.2.mM <- (obs.2 * obs.mM) / obs.all;
    exp.2.MM <- (obs.2 * obs.MM) / obs.all;

    ## calculate genotype statistics for each homozygote vs others

    ## Dominant -DOM.CHISQ (testing major allele genotypes vs other)
    ## i.e. minor allele is dominant
    dom.test <- rbind(table1["mm",]+table1["mM",],
                      table1["MM",],
                      table2["mm",]+table2["mM",],
                      table2["MM",],
                      exp.1.mm+exp.1.mM,
                      exp.1.MM,
                      exp.2.mm+exp.2.mM,
                      exp.2.MM);
                                        #    cat("dom.chisq =",mean(apply(dom.test,2,vector.chisq)));

    ## Recessive -REC.CHISQ (testing minor allele genotypes vs other)
    ## i.e. minor allele is recessive
    rec.test <- rbind(table1["mm",],
                      table1["MM",]+table1["mM",],
                      table2["mm",],
                      table2["MM",]+table2["mM",],
                      exp.1.mm,
                      exp.1.MM+exp.1.mM,
                      exp.2.mm,
                      exp.2.MM+exp.2.mM);
                                        #    cat(", rec.chisq =",mean(apply(rec.test,2,vector.chisq)));

    ## CA trend test -TREND.CHISQ
    ## Note: this assumes allele 1: minor, allele 2: Major
    CA <- ((obs.2/obs.all * table1["mM",]) - (obs.1/obs.all * table2["mM",])) +
      2 * ((obs.2/obs.all * table1["MM",]) - (obs.1/obs.all * table2["MM",]));
    var.CA <- obs.1 * obs.2 *
      (( obs.all * ( obs.mM + 4 * obs.MM )
        - ( obs.mM + 2 * obs.MM )^2 )
       / (obs.all^3));
    CA.chisq <- (CA^2) / var.CA;
                                        #    cat(", CA.chisq =",mean(CA.chisq));
    if ((method == "ChisqmaxAll") || (method == "ShowValues") || (method == "gChisq")) {
      geno.test <- rbind(table1["mm",],
                         table1["mM",],
                         table1["MM",],
                         table2["mm",],
                         table2["mM",],
                         table2["MM",],
                         exp.1.mm,
                         exp.1.mM,
                         exp.1.MM,
                         exp.2.mm,
                         exp.2.mM,
                         exp.2.MM);
                                        #      cat(", geno.chisq =",mean(apply(geno.test,2,vector.chisq)));

      ## Multiplicative / Allelic (actually testing allele quantities of m vs M)
      mult.test <- rbind(2*table1["mm",]+table1["mM",],
                         2*table1["MM",]+table1["mM",],
                         2*table2["mm",]+table2["mM",],
                         2*table2["MM",]+table2["mM",],
                         exp.1.m,
                         exp.1.M,
                         exp.2.m,
                         exp.2.M);
                                        #      cat(", mult.chisq =",mean(apply(mult.test,2,vector.chisq)),"\n");
    }
    ## -1 needed in apply to avoid warnings
    if(method == "Chisqmax"){
      retVal <-
        apply(rbind(
                    CA.chisq,
                    apply(dom.test,2,vector.chisq),
                    apply(rec.test,2,vector.chisq),
                    -Inf),2,max, na.rm = TRUE);
    } else if (method == "gChisq") {
      retVal <-
        apply(geno.test,2,vector.chisq);
    } else if (method == "ChisqmaxAll") {
      retVal <-
        apply(rbind(
                    CA.chisq,
                    apply(geno.test,2,vector.chisq),
                    apply(mult.test,2,vector.chisq),
                    apply(dom.test,2,vector.chisq),
                    apply(rec.test,2,vector.chisq),
                    -Inf),2,max, na.rm = TRUE);
    } else if (method == "ShowValues") {
      retVal <-
        apply(rbind(
                    CA.chisq,
                    apply(geno.test,2,vector.chisq),
                    apply(mult.test,2,vector.chisq),
                    apply(dom.test,2,vector.chisq),
                    apply(rec.test,2,vector.chisq)),2,paste, collapse = ",");
    }
  } else {
    retVal <- NULL;
  }
  ## retVal should be a vector of values, with length equal to the
  ## number of bootstraps
  return(retVal);
}

## matmap -- maps a vector onto a matrix of indexes to the vector
matmap <- function(vector.in, matrix.indices){
  if(max(matrix.indices) > length(vector.in)){
    cat("Error: maximum index greater than vector length\n", file = stderr());
  }
  res <- vector.in[matrix.indices];
  if(is.null(dim(matrix.indices))){
    dim(res) <- c(length(matrix.indices),1);
  } else {
    dim(res) <- dim(matrix.indices);
  }
  return(res);
}

## carries out allele frequency based delta on a single line of simplegt input
processLine <-
  function(marker.name, genotypes, popSamples1, popSamples2, output.file = "",
           append = TRUE, GTmethod = "Adelta", sortbyValue = FALSE){
#  cat(dim(popSamples1), "\n", file=stderr());
  if(length(marker.name) > 1){
    stop("Cannot process more than one line at a time");
  }
  if((length(marker.name) == 0) || (marker.name == "")){
    stop("Empty input: input is not valid");
  }
  bs.results <-
    GTCalc(genotypes,popSamples1,popSamples2,GTmethod);
  ## output 1 line per result
  if(sortValues){
    bs.order <- rev(order(bs.results));
  } else {
    bs.order <- 1:length(bs.results);
  }
  if((GTmethod == "ShowValues") && (append == FALSE)){
    cat("marker,bs.run,CA.chisq,geno.test,mult.test,dom.test,rec.test\n",
        file = output.file, append = FALSE);
    write.table(data.frame(marker = marker.name, bs.run = bs.order,
                           bs.value = bs.results[bs.order]),
                output.file, sep = ",", quote = FALSE, append = TRUE,
                col.names = FALSE, row.names = FALSE);
  } else {
    write.table(data.frame(marker = marker.name, bs.run = bs.order,
                           bs.value = bs.results[bs.order]),
                output.file, sep = ",", quote = FALSE, append = append,
                col.names = !append, row.names = FALSE);
  }
}

casecontrolColumns.con <- file(casecontrolColumns.inFile);
open(casecontrolColumns.con);

if(controlsFirst){
  controls.columns <-
    as.numeric((strsplit(readLines(casecontrolColumns.con, n = 1)," ")[[1]])[-1]);
  cases.columns <-
    as.numeric((strsplit(readLines(casecontrolColumns.con, n = 1)," ")[[1]])[-1]);
} else {
  cases.columns <-
    as.numeric((strsplit(readLines(casecontrolColumns.con, n = 1)," ")[[1]])[-1]);
  controls.columns <-
    as.numeric((strsplit(readLines(casecontrolColumns.con, n = 1)," ")[[1]])[-1]);
}
close(casecontrolColumns.con);

if(is.null(replicates.cases)){
  replicates.cases <- min(length(cases.columns) - 5,
                          trunc(length(cases.columns)*replicates.proportion));
}

if(is.null(replicates.controls)){
  replicates.controls <- min(length(controls.columns) - 5,
                          trunc(length(controls.columns)*replicates.proportion));
}

## generate bootstrap replicates first. This improves speed and
## maintains a consistent population subsample across multiple SNPs.
## note: this is sampling with replacement
## file to place subsample columns into
cases.samples <- NULL;
controls.samples <- NULL;
if(createReplicates){
  rep.case.outFile = paste("caseReplicates",bootstraps.outFile,sep="_");
  rep.control.outFile = paste("controlReplicates",bootstraps.outFile,sep="_");
  cases.samples <- replicate(bootstrap.count,
                             sample(cases.columns,replicates.cases));
  controls.samples <- replicate(bootstrap.count,
                                sample(controls.columns,replicates.controls));
  ## write out replicates to a file, in case validation is needed
  write.table(t(cases.samples),rep.case.outFile, quote = FALSE,
              col.names = FALSE);
  write.table(t(controls.samples),rep.control.outFile, quote = FALSE,
              col.names = FALSE);
} else {
  cases.samples <- t(read.table(rep.case.outFile, row.names = 1));
  controls.samples <- t(read.table(rep.control.outFile, row.names = 1));
  dcc <- c(dim(cases.samples), dim(controls.samples));
  cat(sprintf("Retrieved data for %d bootstraps (cases %d x %d, controls %d x %d)\n",
             dcc[2], dcc[1], dcc[2], dcc[3], dcc[4]), file = stderr());
}

if(genotypes.inFile != ""){
  genotypes.con <- gzfile(genotypes.inFile);
  open(genotypes.con)
} else {
  genotypes.con <- file("stdin");
  open(genotypes.con)
}

input.line <- scan(genotypes.con, what = character(), nlines = 1, quiet = TRUE);
while((length(input.line)>0) && (substr(input.line[1],1,1) == "#")){
  input.line <- scan(genotypes.con, what = character(), nlines = 1, quiet = TRUE);
}

num.indivs <- length(input.line[-1]);
if(num.indivs != (length(cases.columns) + length(controls.columns))){
  cat(sprintf("Warning: number of individuals detected on first line (%d) is not the same as number of cases (%d) + number of controls (%d)\n", num.indivs, length(cases.columns), length(controls.columns)), file = stderr());
}

## process line *without* append (creates header)
processLine(input.line[1], input.line[-1], cases.samples, controls.samples,
            append = FALSE, output.file = bootstraps.outFile,
            GTmethod = processMethod, sortbyValue = sortValues);
input.line <- scan(genotypes.con, what = character(), nlines = 1, quiet = TRUE);
while((length(input.line)>0) && (substr(input.line[1],1,1) == "#")){
  input.line <- scan(genotypes.con, what = character(), nlines = 1, quiet = TRUE);
}
line.number <- 1;
while(length(input.line) > 0){
  ## process line *with* append (no header)
  processLine(input.line[1], input.line[-1], cases.samples, controls.samples,
              append = TRUE, output.file = bootstraps.outFile,
              GTmethod = processMethod, sortbyValue = sortValues);
  line.number <- line.number+1;
  if(line.number %% 1000 == 0){
    cat(".", file = stderr());
  }
  input.line <- scan(genotypes.con, what = character(), nlines = 1, quiet = TRUE);
  while((length(input.line)>0) && (substr(input.line[1],1,1) == "#")){
    input.line <- scan(genotypes.con, what = character(), nlines = 1, quiet = TRUE);
  }
}
if(genotypes.inFile != ""){
  close(genotypes.con);
}

if(line.number > 1){
  cat("(",line.number," lines processed)\n", file = stderr(), sep = "");
} else {
  cat("(",line.number," line processed)\n", file = stderr(), sep = "");
}


##################################################################################
# Dynamic + vectorized
# This code runs a Bonica-like algorithm to provide a longitudinal view of IFE's
# Council General.
# 27 Mar 2021
##################################################################################

library(arm)
library (MCMCpack)
library (foreign)
library (car)
library (gtools)
#library (multicore)
library (R2jags)
library (mcmcplots)
library (sm)
library(lubridate)
#
library (runjags)
library (coda)

# un cambio minimo
rm(list = ls())
workdir <- c("/home/eric/Dropbox/data/rollcall/ife_cg/ife-update/data/")
setwd(workdir)

# Define colors and plotting names
# OJO: en tenure term==10 es a, term==11 es b etc.

ids <- matrix(c(
    ## "Woldenberg",       "woldenberg", "PRI", "23",
    ## "Barrag?n",         "barragan",   "PRD", "23",
    ## "Cant?",            "cantu",      "PRD", "23",
    ## "C?rdenas",         "cardenas",   "PRD", "23",
    ## "Lujambio",         "lujambio",   "PAN", "23",
    ## "Merino",           "merino",     "PRI", "23",
    ## "Molinar",          "molinar",    "PAN", "2" ,
    ## "Peschard",         "peschard",   "PRI", "23",
    ## "Zebad?a",          "zebadua",    "PRD", "2" ,
    ## "Rivera",           "rivera",     "PRI",  "3",
    ## "Luken",            "luken",      "PAN",  "3",
    #
    "Ugalde",           "ugalde",      "PRI",  "4",
    "Albo",             "albo",        "PAN",  "456",
    "Andrade",          "andrade",     "PRI",  "4567",
    "Gmz. Alc?ntar",    "alcantar",    "PVEM", "4567",
    "Glez. Luna",       "glezluna",    "PAN",  "456",
    "Latap?",           "latapi",      "PRI",  "45",
    "L?pez Flores",     "lopezflores", "PRI",  "456",
    "Morales",          "morales",     "PAN",  "45",
    "S?nchez",          "sanchez",     "PAN",  "4567c",
    "Vald?s",           "valdes",      "PRD",    "6789a",
    "Ba?os",            "banos",       "PRI",    "6789abcde",
    "Nacif",            "nacif",       "PAN",    "6789abcde",
    "Elizondo",         "elizondo",    "PAN",     "789a",
    "Figueroa",         "figueroa",    "PRD",     "789a",
    "Guerrero",         "guerrero",    "PRI",     "789a",
    "C?rdova",          "cordova",     "PRD",       "9abcdef",
    "Garc?a Rmz.",      "garcia",      "PRI",       "9"  ,
    "Marv?n",           "marvan",      "PAN",       "9ab",
    "E. Andrade",       "andrade2",    "",             "cde",
    "Favela",           "favela",      "",             "cdef",
    "Santiago",         "santiago",    "",             "c",
    "Galindo",          "galindo",     "",             "c",
    "Murayama",         "murayama",    "",             "cdef",
    "Ruiz Salda?a",     "ruiz",        "",             "cdef",
    "San Mart?n",       "snmartin",    "",             "cde",
    "Santiago",         "santiago",    "",             "c",
    "Ravel",            "ravel",       "",              "def",
    "J. Rivera",        "rivera2",     "",              "def",
    "Zavala",           "zavala",      "",              "def",
    "De la Cruz",       "magana",      "",                "f",
    "Faz",              "faz",         "",                "f",
    "Humphrey",         "humphrey",    "",                "f",
    "Kib Espadas",      "kib",         "",                "f"),
    ncol = 4,
    byrow = TRUE)
#
ids <- as.data.frame(ids, stringsAsFactors = FALSE)
colnames(ids) <- c("name", "column", "pty", "tenure")
#ids$tenure <- as.numeric(ids$tenure)
ids <- within(ids, party <- ifelse (pty=="PRI", 1,
                            ifelse (pty=="PAN", 2,
                            ifelse (pty=="PRD", 3,
                            ifelse(pty=="PVEM", 4, 5)))))
ids <- within(ids, color <- ifelse (pty=="PRI", "red",
                            ifelse (pty=="PAN", "blue",
                            ifelse (pty=="PRD", "gold",
                            ifelse(pty=="PVEM", "green", "orangered4")))))
ids # inspect

####################################################################
## select terms for analysis, e.g. for 4-11(b) "[456789ab]" works ##
####################################################################
tees <- c("6","7","8","9","a")
tees.grep <- "[6789a]"
T <- length(tees)
#
sel    <- grep(pattern = tees.grep, ids$tenure)
name   <- ids$name[sel]
party  <- ids$party[sel]
color  <- ids$color[sel]
column <- ids$column[sel]

## rgb.23 <- c(length=11)
## rgb.23[c(1,6,8,10)] <- rgb(1,       0, 0, 0.6) #red
## rgb.23[c(2:4,9)]    <- rgb(1, 215/255, 0, 0.6) #gold
## rgb.23[c(5,7,11)]   <- rgb(0,       0, 1, 0.6) #blue

############################################
## Read votes                             ##
## exported to disk by code/data-prep.r   ##
############################################
#vot23  <- read.csv("v23.csv"        ,  header=TRUE)
vot4on <- read.csv(  "v456789ab.csv",  header=TRUE)
# choose what votes will be analyzed
#vot <- vot23  # Woldenberg
vot <- vot4on # Ugalde-Vald?s-C?rdova
#colnames(vot)
# subset to votes in chosen periods
sel.r <- which(vot$term %in% tees)
drop.c <- ids$column[grep(pattern = tees.grep, ids$tenure)] # column names not in terms selected
drop.c <- setdiff(ids$column, drop.c)
drop.c <- which(colnames(vot) %in% drop.c)
if (length(drop.c)>0) vot <- vot[sel.r, -drop.c]
colnames(vot)
# total members
J <- length(name); J

########################
## recode vote values ##
########################
vs <- vot[,1:J]
#table(v$albo, useNA = "always")
vs[vs==0] <- NA    ## Version probit requiere 0s y 1s
vs[vs>2]  <- NA
vs[vs==2] <- 0

# format dates
vot$date <- ymd(vot$date)
# summarize then drop uncontested votes
table(factor(vot$dunan, labels = c("contested","not")), vot$term, useNA = "ifany")
table(factor(vot$dunan, labels = c("contested","not")), useNA = "ifany")
sel <- which(vot$dunan==1)
if (length(sel)>0){
    vot <- vot[-sel,] # drop uncontested votes
    vs  <- vs [-sel,] # drop uncontested votes
}

## ###########
## ## MODEL ##
## ###########
## model1Dj.irt <- function() {
##     for (j in 1:J){        ## loop over respondents
##         for (i in 1:I){## loop over items
##             v[j,i] ~ dbern(p[j,i]); ## voting rule
##             probit(p[j,i]) <- mu[j,i]; ## sets 0<p<1 as function of mu
##             mu[j,i] <- signal[i]*x[j] - difficulty[i];              ## utility differential
## 		}
## 	}
## 	## priors ################
## 	for (j in 1:J){
## 		x[j] ~ dnorm (x.mean[j], x.tau[j]);
## 	}
## 	for (i in 1:I){
## 		signal[i] ~ dnorm(0, 0.1);
## 		difficulty[i] ~ dnorm(0, 0.25);
## 	}
## 	for (p in 1:4){ # need 5 when morena also considered
##             partyPos[p] <- mean (x[sponsors[p]]); # 4mar21: should be median, unknown function in bugs?
## 	}
## }
## #end model##############

###########
## MODEL ##
###########
## alpha is vote's   difficulty
## beta  is vote's   signal strength
## theta is member's ideal point
ife.vector <- "model {
    for (n in 1:n.obs) {
        y[n] ~ dbern (pi[n])
        probit(pi[n]) <- beta[vote[n]]*theta[member[n]] - alpha[vote[n]]
    }
    # PRIORS
    for (j in 1:n.item){
        alpha[j] ~ dnorm(0, 0.25);
        beta [j] ~ dnorm(0, 0.1)
    }
    for (p in 1:4){ # need 5 when morena also considered
        partyPos[p] <- mean (x[sponsors[p]]); # 4mar21: should be median, unknown to jags?
    }
    # IDEAL POINTS, auto-regressive process --- 31mar21 DUDO QUE LE GUSTE north==NA CUANDO OCURRA
    for(i in setdiff(1:n.members, c(north, south))){
        theta[i] ~ dnorm ( x.mean[i], x.tau[i] )
    }
    theta[north] ~ dnorm ( x.mean[north], x.tau[north] ) T(0, ) # truncated positive normal
    theta[south] ~ dnorm ( x.mean[south], x.tau[south] ) T( ,0) # truncated negative normal
}"
### END MODEL ######

# Center on vote (for date), extend windows to both sides
I <- nrow (vot)
item <- 1:I  # Need to define I before
inicio <- item-15; inicio[inicio<0] <- 1
final  <- item+15; final[final>I] <- I
item.date <- vot$date #ymd(vot$yr*10000+vot$mo*100+vot$dy)
S <- length(inicio)

# We need a matrix showing whether each councilor is actually in IFE the moment the vote takes place --- will be subset to J below
IsCouncilor <- matrix (1, ncol=18, nrow=S)
IsCouncilor[ vot$term < 4 | vot$term >  4,1 ] <- NA  #      ugalde  1
IsCouncilor[ vot$term < 4 | vot$term >  6,2 ] <- NA  #        albo  2
IsCouncilor[ vot$term < 4 | vot$term >  7,3 ] <- NA  #     andrade  3
IsCouncilor[ vot$term < 4 | vot$term >  7,4 ] <- NA  #    alcantar  4
IsCouncilor[ vot$term < 4 | vot$term >  6,5 ] <- NA  #    glezluna  5
IsCouncilor[ vot$term < 4 | vot$term >  5,6 ] <- NA  #      latapi  6
IsCouncilor[ vot$term < 4 | vot$term >  6,7 ] <- NA  # lopezflores  7
IsCouncilor[ vot$term < 4 | vot$term >  5,8 ] <- NA  #     morales  8
IsCouncilor[ vot$term < 4 |(vot$term >  7 & vot$term!=12),9 ] <- NA  # sanchez  9
IsCouncilor[ vot$term < 6 | vot$term > 10,10] <- NA  #      valdes 10
IsCouncilor[ vot$term < 6 | vot$term > 14,11] <- NA  #       banos 11
IsCouncilor[ vot$term < 6 | vot$term > 14,12] <- NA  #       nacif 12
IsCouncilor[ vot$term < 7 | vot$term > 10,13] <- NA  #    elizondo 13
IsCouncilor[ vot$term < 7 | vot$term > 10,14] <- NA  #    figueroa 14
IsCouncilor[ vot$term < 7 | vot$term > 10,15] <- NA  #    guerrero 15
IsCouncilor[ vot$term < 9 | vot$term > 15,16] <- NA  #     cordova 16
IsCouncilor[ vot$term < 9 | vot$term >  9,17] <- NA  #  garcia rmz 17
IsCouncilor[ vot$term < 9 | vot$term > 11,18] <- NA  #      marvan 18
####################################################
## vector to select members present in estimation ##
####################################################
sel.members <- which(ids$name %in% name)
IsCouncilor <- IsCouncilor[, sel.members]

# Round 1 ideal points to anchor ideological space
# (later entrants at party mean)
#                 1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
#                 u  a  a  a  g  l  l  m  s  v  b  n  e  f  g  c  g  m  a  f  g  m  r  s  s
#                 g  l  n  l  l  a  p  o  a  a  a  a  l  i  u  o  a  a  n  a  a  u  u  n  a
#                 a  b  d  c  z  t  z  r  n  l  ?  c  i  g  e  r  r  r  d  v  l  r  i  m  n
#                 l  o  r  a  l  a  f  a  c  d  o  i  z  u  r  d  c  v  r  e  i  a  z  a  t
x.location <-   c(0, 0, 0, 2, 0, 0, 0, 0,-2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)[sel.members] # sel = members in estimation
x.precision  <- c(1, 1, 1, 4, 1, 1, 1, 1, 4, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)[sel.members]
#x.location <-   c(1, 0, 0, 2,-2, 0, 0, 2,-2, 0, 2,-1,-2, 0, 2,-2, 2,-2, 0, 0, 0, 2, 0, 0, 0)[sel.members] # sel = members in estimation
#x.precision  <- c(4, 1, 1, 4, 4, 4, 1, 4, 4, 1, 4, 4, 4, 1, 4, 4, 4, 4, 1, 1, 1, 4, 1, 1, 1)[sel.members]
# x.location and x.precision are manipulated by loop, keep a version to use as prior for new entrants instead of party mean
x.prior.location <-  x.location
x.prior.precision <- x.precision
#
window.results <- list () ## WILL ADD SESSION'S RESULTS TO OBJECT HOLDING ALL RESULTS
partyPlacement <- rep (NA,J)
x.mean <- numeric ()
x.tau  <- numeric ()

for (s in 1:S){        # <= loop over S windows
    #
    #s <- 1 # debug
    councilor.in <- apply (IsCouncilor[inicio[s]:final[s],], 2, invalid)
    councilors   <- name [councilor.in==FALSE] # window's info
    abbrev       <- column [councilor.in==FALSE] # window's info
    sponsors     <- party[councilor.in==FALSE] # window's info
    #
    for (c in 1:J){ # does it for all councilors whther or not present in window (hence J)
# 5mar21: this uses partyPlacement for new entrants
#        x.mean[c] <- ifelse (!is.na(x.location[c]),  x.location[c],  partyPlacement[sponsors[c]])
#        x.tau[c]  <- ifelse (!is.na(x.precision[c]), x.precision[c], 4)
# 5mar21: this uses fixed x0 prior for new entrants
        x.mean[c] <- ifelse (!is.na(x.location [c]), x.location [c], x.prior.location [c])
        x.tau[c]  <- ifelse (!is.na(x.precision[c]), x.precision[c], x.prior.precision[c])
    }
    #
    v <- vs[inicio[s]:final[s], 1:J][, councilor.in==FALSE]; ## EXTRACT 30 VOTES EACH TIME
    v <- as.data.frame(t(v))        ## ROLL CALLS NEED ITEMS IN COLUMNS, LEGISLATORS IN ROWS
    #
    ###################
    ## Vectorization ##
    ###################
    #J <- nrow(v); I <- ncol(v)      ## SESSION TOTALS
    member.index  <- 1:nrow(v)
    vote.index <- 1:ncol(v)

    ## Melt RC
    rc <- as.data.frame (v)
    colnames (rc) <- vote.index
    rc$member <- member.index
    #
    # determine north/south indexes in vote window
    north <- which(rownames(rc)=="alcantar")
    north <- ifelse (length(north)==0, NA, north) # NA if member absent, else her index
    south <- which(rownames(rc)=="sanchez")
    south <- ifelse (length(south)==0, NA, south) # NA if member absent, else her index
    #
    molten.rc <- reshape2::melt(rc, id.vars="member", variable.name="vote", value.name="rc")
    #molten.rc$rc <- car::recode (molten.rc$rc, "0=NA")
    molten.rc <- na.omit (molten.rc)
    #molten.rc$rc <- car::recode (molten.rc$rc, "2=0; c(3,4,5)=NA")
    #
    ife.data.vector <- dump.format(list(
        y         = molten.rc$rc
      , n.members = max(member.index)
      , n.item    = max(vote.index)
      , n.obs     = nrow(molten.rc)
      , vote      = molten.rc$vote
      , member    = molten.rc$member
      , north     = north
      , south     = south
      , x.mean    = x.mean
      , x.tau     = x.tau
      , sponsors  = sponsors
    ))
    #
    ife.parameters = c("theta", "alpha", "beta", "partyPos", "deviance")
    #
    ife.inits <- function() {
        dump.format(
            list(
                theta = rnorm(max(member.index))
                #theta = c(rnorm(3), NA, rnorm(4), NA, rnorm(max(member.index)-9)) # NAs s?lo en caso de spike priors, correcto?
              , alpha = rnorm(max(vote.index))
              , beta = rnorm(max(vote.index))
              , '.RNG.name'="base::Wichmann-Hill"
              , '.RNG.seed'= 1971)   #randomNumbers(n = 1, min = 1, max = 1e+04,col=1))
        )
    }
    #
    ife.model.v <- run.jags(
        model   = ife.vector,
        monitor = ife.parameters,
        method  = "parallel",
        data    = ife.data.vector,
        inits   = list (ife.inits(), ife.inits()),
        n.chains=2, thin=50, burnin=10000, sample=200,
        #n.chains=1, thin=5,  burnin=200,   sample=3,
        check.conv=FALSE, plots=FALSE
    )
    #
    chainsIFE.v <- mcmc.list(list (ife.model.v$mcmc[[1]], ife.model.v$mcmc[[2]]))
    gelman.diag (chainsIFE.v, multivariate=F)
    #
    Alpha.v <- rbind ( chainsIFE.v[[1]][,grep("alpha", colnames(chainsIFE.v[[1]]))]
                    , chainsIFE.v[[2]][,grep("alpha", colnames(chainsIFE.v[[2]]))])
    Beta.v <- rbind ( chainsIFE.v[[1]][,grep("beta", colnames(chainsIFE.v[[1]]))]
                   , chainsIFE.v[[2]][,grep("beta", colnames(chainsIFE.v[[2]]))])
    Theta.v <- rbind ( chainsIFE.v[[1]][,grep("theta", colnames(chainsIFE.v[[1]]))]
                    , chainsIFE.v[[2]][,grep("theta", colnames(chainsIFE.v[[2]]))])
    #
    plot (colMeans (Alpha.v))  # difficulties
    plot (colMeans (Beta.v))   # signal
    #
    par (las=2, mar=c(7,3,2,2))
    plot (1:length(vot$date), colMeans (Beta.v)
        , type="n"
        , axes=F, ylim=c(-1,1)
        , xlab="", ylab="Ideal point")
    axis (1, at=seq(1,length(vot$date),8)
        , labels=vot$date[seq(1,length(vot$date),8)], cex=0.8)
    par (las=0)
    mtext (side=1, line=6, text="Dates")
    axis (2)
    for (i in 1:ncol(Theta.v)){
        segments (x0=min (c(1:length(vot$date))[vot[,i] != 0])
                , x1=max (c(1:length(vot$date))[vot[,i] != 0])
                , y0=colMeans (Theta.v)[i]
                , y1=colMeans (Theta.v)[i]
                , col=ids$color[i], lwd=3)
    }
	# ADD COUNCILOR NAMES AND VOTE INFO TO RESULTS OBJECT
        results <- c(results, councilors=list(councilors), abbrev=list(abbrev));
        results <- c(results, folio.date=list(vot[s,c("folio","dy","mo","yr")])); # add vote on which window is centered
        window.results <- c(window.results, list(results)); ## ADD SESSION'S RESULTS TO OBJECT HOLDING ALL RESULTS
#        results[[4]] <- GHconv; rm (GHconv)
#
	# Update location of ideal point at time s, to be used as location prior at time s+1
	x.location  <- rep (NA, J)
	x.precision <- rep (100, J)
#	locs <- apply( rbind (results[[1]]$BUGSoutput$sims.list$x, results[[2]]$BUGSoutput$sims.list$x), 2, median)
#	partyPlacement <- apply( rbind (results[[1]]$BUGSoutput$sims.list$partyPos, results[[2]]$BUGSoutput$sims.list$partyPos), 2, median)
	locs <- apply( results$BUGSoutput$sims.list$x, 2, median)
	partyPlacement <- apply( results$BUGSoutput$sims.list$partyPos, 2, median)
	for (n in 1:J){
		if (length( which(councilors==name[n]) )==0) {               # if councilor not member current round
			x.location[n] <- NA                                  # then prior for next round set to NA
			x.precision[n] <- NA                                 # (and line above sets it to party placement)
		}
		else { x.location[n] <-  locs[which (councilors==name[n])] } # councilor's prior for next round is current x
	}
	# Precision prior is always constant at 100, implying standard deviation = sqrt (1/100) = 0.1
}  # <---   END OF LOOP OVER WINDOWS

# plot results
tit <- "Terms 67 (Vald?s 2007-2010), Bonica method"
source("../code/plot-posteriors.r")
x

# rename object with posterior sims
summary(window.results[[190]])
window.results.67 <- window.results
rm(window.results)

# clean
ls()
rm(c, s, n, v, sel, ife.inits, ife.parameters, ife.data)
rm(councilors, sponsors, inicio, final, councilor.in)
rm(x.location, x.mean, x.precision, x.tau, item, results, item.date)
rm(color, column, locs, name, party, partyPlacement)

# save
summary(window.results.67)
#summary(window.results[[232]]) # 11 members, overlap
save.image(file = "posterior-samples/vald67-window-results-compress.RData", compress = "xz")
#save(window.results.23, file = "posterior-samples/wold23-window-results-compress.RData")
x

# Save window.results, containing all chains from all runs
# save (window.results, file="DynUgaldeBonicaMarch21.RData") # With more anchors
# save (window.results, file="DynUgaldeBonicaMarch19.RData")
# save (window.results, file="DynUgaldeBonica.RData")

source("http://rtm.wustl.edu/code/sendEmail.R")
#sendEmail (subject="Ugalde et al esta listo", text="", address="rosas.guillermo@gmail.com")
sendEmail (subject="Ugalde et al esta listo", text="", address="emagar@gmail.com")

# RData file with runs carried out in Mexico, early March
# load ("DynUgaldeBonica.RData")

# RData file with runs carried out in Wash U, March 19
# These runs omit non-sitting Councilors and party precisions for new Councilors
load ("DynUgaldeBonicaMarch21.RData")

S <- length (semester.results)
multiGelman.hat <- numeric ()
for (i in 1:S){
	chainsConv <- mcmc.list(list (as.mcmc (semester.results[[i]][[2]]$BUGSoutput$sims.list$x), as.mcmc (semester.results[[i]][[1]]$BUGSoutput$sims.list$x)))
	tmp <- gelman.diag (chainsConv)[[2]]
	multiGelman.hat <- c(multiGelman.hat, tmp)
}
rm (tmp, chainsConv)

nonConverged <- ifelse (multiGelman.hat > 2, 1, 0)  # Should be 0

CouncilorIn <- matrix (1, nrow=J, ncol=S)
CouncilorIn[1,  all45678901$date > 20071217] <- NA
CouncilorIn[2,  all45678901$date > 20080814] <- NA
CouncilorIn[3,  all45678901$date > 20101027] <- NA
CouncilorIn[4,  all45678901$date > 20101027] <- NA
CouncilorIn[5,  all45678901$date > 20080814] <- NA
CouncilorIn[6,  all45678901$date > 20071217] <- NA
CouncilorIn[7,  all45678901$date > 20080814] <- NA
CouncilorIn[8,  all45678901$date > 20071217] <- NA
CouncilorIn[9,  all45678901$date > 20101027] <- NA
CouncilorIn[10,  all45678901$date < 20080215] <- NA
CouncilorIn[11,  all45678901$date < 20080215] <- NA
CouncilorIn[12,  all45678901$date < 20080215] <- NA
CouncilorIn[13,  all45678901$date < 20080829] <- NA
CouncilorIn[14,  all45678901$date < 20080829] <- NA
CouncilorIn[15,  all45678901$date < 20080829] <- NA
#CouncilorIn[16,  all45678901$date < 20111215] <- NA
#CouncilorIn[17,  all45678901$date < 20111215] <- NA
#CouncilorIn[18,  all45678901$date < 20111215] <- NA

# If using DynUgaldeBonica.RData, use the following code to extract ideal points
ideal.points <- matrix (NA, nrow=S, ncol=J)
for (i in 1:S){
	ideal.points[i,] <- apply (rbind (semester.results[[i]][[1]]$BUGSoutput$sims.list$x, semester.results[[i]][[2]]$BUGSoutput$sims.list$x), 2, median)
}

# If using DynUgaldeBonicaMarch19.RData or DynUgaldeBonicaMarch21.RData, use the following code to extract ideal points
ideal.points <- matrix (NA, nrow=S, ncol=J)
ideal.points.var <- matrix (NA, nrow=S, ncol=J)
for (i in 1:S){
	for (j in 1:J){
		councilor <- names45678901[j]
		num <- which (semester.results[[i]][[3]]==councilor)
		if ( length (num)==0 ) {
			ideal.points[i,j] <- 1
			ideal.points.var[i,j]  <- 0
		} else {
				ideal.points[i,j] <- median (c (semester.results[[i]][[1]]$BUGSoutput$sims.list$x[,num], semester.results[[i]][[2]]$BUGSoutput$sims.list$x[,num]))
				ideal.points.var[i,j]  <- var (c (semester.results[[i]][[1]]$BUGSoutput$sims.list$x[,num], semester.results[[i]][[2]]$BUGSoutput$sims.list$x[,num]))
		}
	}
}

# Plot different individual councilor paths:
# There is definitely a problem at different spots of the estimation:
# Between i=200 and i=500 and after i=600
# The problem really obtains when we get new guys in
# Valdes, Banos, Nacif, Elizondo, Figueroa, Guerrero come in in quick succession and destroy everything
# Maybe the best solution is to break down estimation of this very long period in two or three chunks
# Or maybe we need to combine priors on ideal points with priors on item parameters
k <-  12
plot (ideal.points[ideal.points.var[,k] != 0, k], type="l")

# Get SDs of estimates, the width should be useful to plot thickness of data points
ideal.points.var <- sqrt (ideal.points.var)

# Non-smoothed ideal point time-paths
setwd ("/Users/grosas/Dropbox/ifesharedge/graphs")
pdf ("UgaldeEtAlNonSmooth.pdf", h=7, w=9)
plot(c(1:S), ideal.points[1:S,1], main="", ylim=c(-3,3), type="n", xlab="", ylab="Ideal points")
for (j in 1:J){
# 	lines(ideal.points[1:S,j], lwd=3, col=color45678901[j])
	lines(CouncilorIn[j,1:S] * ideal.points[1:S,j], lwd=3, col=rgb.45678901[j])
}
dev.off()

# Smoothed ideal point time-paths
# pdf ("UgaldeEtAlSmooth.pdf", h=7, w=9)
pdf ("UgaldeEtAlSmoothMarch21.pdf", h=7, w=9)
plot(c(1:S), ideal.points[1:S,1], main="", ylim=c(-3,3), type="n", xlab="", ylab="Ideal points")
for (j in 1:J){
	lines(smooth.spline(c(1:S)[!is.na(CouncilorIn[j,1:S])], ideal.points[!is.na(CouncilorIn[j,1:S]),j], df=10), lwd=3, col=rgb.45678901[j])
# 	lines(smooth.spline(c(1:S), ideal.points[,j], df=10), lwd=3, col=color45678901[j])
}
dev.off()

setwd ("/Users/grosas/Dropbox/ifesharedge/graphs/animBits/ugalde/")

# Smoothed ideal point time-paths, daily change movie
Smooth <- list ()
for (j in 1:J){
	Smooth[[j]] <- smooth.spline(c(1:S), ideal.points[,j], df=10)
}

for (j in 1:J){
	Smooth[[j]]$y[is.na(CouncilorIn[j,1:S])] <- NA
}

snapshot <- seq (1, 1091, by=10)
for (s in snapshot){
	which.s <- which (snapshot==s)
	if (which.s < 10) {name = paste('Ugalde00', which.s,'plot.png',sep='')}
	if (which.s >= 10 && which.s < 100) {name = paste('Ugalde0', which.s,'plot.png', sep='')}
	if (which.s >= 100) {name = paste('Ugalde', which.s,'plot.png', sep='')}

	jpeg (name, quality=100, height=500, width=500)

	plot(c(1:S), ideal.points[1:S,1], main="", ylim=c(-3,3), type="n", xlab="", ylab="Ideal points")
	for (j in 1:J){
		lines ( Smooth[[j]]$x[1:s], Smooth[[j]]$y[1:s], lwd=6, col=rgb.45678901[j])
	}
	# Eric: Creo que t? tienes m?s informaci?n para hacer los cambios en las siguientes tres l?neas
	legend ("topright", bty="n", legend=paste ("vote", s, sep=" ")) #Change the legend for the date of the vote
	# Add vertical lines for elections here, but only for some realizations of S
	# Add names of councilors here as well, but only for some realizations of S
	dev.off()
}

# Make a short film
# system("convert -loop 1 -delay 40 *.png IFEwolden.gif")
system("convert -loop 1 -delay 20 *.png IFEugaldeSofis.gif")
# The number after loop controls the number of automatic replays (0 stands for infinite loop)
# The number after delay determines length of transition between slides)


#' svaPrep
#'
#' prepare data for sva and/or isva analysis
#'
#' @param variable Independent variable vector.
#' @param covariates Covariates data frame to include in regression model,
#' one row per sample, one column per covariate (Default: NULL).
#' @param beta.sva Methylation levels matrix, one row per CpG site, one column per sample.
#' @param featureset Name from \code{\link{meffil.list.featuresets}()}  (Default: NA).
#' one row per sample, one column per covariate (Default: NULL).
#' @param most.variable Apply (Independent) Surrogate Variable Analysis to the
#' given most variable CpG sites (Default: 50000).
svaPrep <- function(variable,covariates,beta.sva,featureset,most.variable){
	autosomal.sites <- meffil.get.autosomal.sites(featureset)
	autosomal.sites <- intersect(autosomal.sites, rownames(beta.sva))
	if (length(autosomal.sites) < most.variable) {
		warning("Probes from the sex chromosomes will be used to calculate surrogate variables.")
	} else {
		beta.sva <- beta.sva[autosomal.sites,]
	}
	var.idx <- order(rowVars(beta.sva, na.rm=T), decreasing=T)[1:most.variable]
	beta.sva <- impute.matrix(beta.sva[var.idx,,drop=F])

	if (!is.null(covariates)) {
		cov.frame <- model.frame(~., data.frame(covariates, stringsAsFactors=F), na.action=na.pass)
		mod0 <- model.matrix(~., cov.frame)
	}
	else
		mod0 <- matrix(1, ncol=1, nrow=length(variable))
	mod <- cbind(mod0, variable)
	res <- list("mod" = mod, "beta.sva"=beta.sva)
	return(res)
}

#' svaIsva
#'
#' Constructs function calls to surrogate variable analysis or independent surrogate variable analysis
#'
#' @param beta.sva Methylation levels matrix, one row per CpG site, one column per sample.
#' @param covariates Covariates data frame to include in regression model,
#' one row per sample, one column per covariate (Default: NULL).
#' @param random.seed Value with which to seed the pseudo random number generator for reproducible results
#' @param mod model matrix form \code{\link{svaPrep}}
#' @param n.sv Number of surrogate variables
#' @param mode Do sva or isva analysis, accepts values "sv" or "isv"
#' @param verbose Set verbosity of isva function
svaIsva <- function(beta.sva,covariates,random.seed,mod,n.sv,mode="sv",verbose){
	set.seed(random.seed)
	if(mode=="sv"){
		sva.ret <- sva(beta.sva, mod=mod, mod0=mod[,1,drop=F], n.sv=n.sv)
	}
	else if (mode=="isv"){
		sva.ret <- isva(beta.sva, mod, ncomp=n.sv, verbose=verbose)
	}
	if (!is.null(covariates))
		svaRes <- data.frame(covariates, sva.ret[[mode]], stringsAsFactors=F)
	else
		svaRes <- as.data.frame(sva.ret[[mode]])
	return(svaRes)
}

#' outliers
#'
#' selects outliers based on the value of "outlier.iqr.factor"
#' @param beta Methylation levels matrix, one row per CpG site, one column per sample.
#' @param outlier.iqr.factor For each CpG site, prior to fitting regression models,
#' set methylation levels less than
#' \code{Q1 - outlier.iqr.factor * IQR} or more than
#' \code{Q3 + outlier.iqr.factor * IQR} to NA. Here IQR is the inter-quartile
#' range of the methylation levels at the CpG site, i.e. Q3-Q1.
#' Set to NA to skip this step (Default: NA)
outliers <- function(beta,outlier.iqr.factor) {
	q <- rowQuantiles(beta, probs = c(0.25, 0.75), na.rm = T)
	iqr <- q[,2] - q[,1]
	too.hi <- which(beta > q[,2] + outlier.iqr.factor * iqr, arr.ind=T)
	too.lo <- which(beta < q[,1] - outlier.iqr.factor * iqr, arr.ind=T)
	if (nrow(too.hi) > 0) beta[too.hi] <- NA
	if (nrow(too.lo) > 0) beta[too.lo] <- NA
	res <- list("too.lo"=too.lo,"too.hi"=too.hi)
	return(res)
}

#' Epigenome-wide association study
#'
#' Test association with each CpG site.
#'
#' @param beta Methylation levels matrix, one row per CpG site, one column per sample.
#' @param variable Independent variable vector. - NB only handles discrete 2 catagory variables
#' @param covariates Covariates data frame to include in regression model,
#' one row per sample, one column per covariate (Default: NULL).
#' @param batch Batch vector to be included as a random effect (Default: NULL).
#' @param weights Non-negative observation weights.
#' Can be a numeric matrix of individual weights of same dimension as \code{beta},
#' or a numeric vector of weights with length \code{ncol(beta)},
#' or a numeric vector of weights with length \code{nrow(beta)}.
#' @param cell.counts Proportion of cell counts for one cell type in cases
#' where the samples are mainly composed of two cell types (e.g. saliva) (Default: NULL).
#' @param isva Apply Independent Surrogate Variable Analysis (ISVA) to the
#' methylation levels and include the resulting variables as covariates in a
#' regression model (Default: TRUE).
#' @param sva Apply Surrogate Variable Analysis (SVA) to the
#' methylation levels and covariates and include
#' the resulting variables as covariates in a regression model (Default: TRUE).
#' @param n.sv Number of surrogate variables to calculate (Default: NULL).
#' @param winsorize.pct Apply all regression models to methylation levels
#' winsorized to the given level. Set to NA to avoid winsorizing (Default: 0.05).
#' @param robust Test associations with the 'robust' option when \code{\link{limma::eBayes}}
#' is called (Default: TRUE).
#' @param rlm Test assocaitions with the 'robust' option when \code{\link{limma:lmFit}}
#' is called (Default: FALSE).
#' @param outlier.iqr.factor For each CpG site, prior to fitting regression models,
#' set methylation levels less than
#' \code{Q1 - outlier.iqr.factor * IQR} or more than
#' \code{Q3 + outlier.iqr.factor * IQR} to NA. Here IQR is the inter-quartile
#' range of the methylation levels at the CpG site, i.e. Q3-Q1.
#' Set to NA to skip this step (Default: NA).
#' @param most.variable Apply (Independent) Surrogate Variable Analysis to the
#' given most variable CpG sites (Default: 50000).
#' @param featureset Name from \code{\link{meffil.list.featuresets}()}  (Default: NA).
#' @param random.seed Value with which to seed the pseudo random number generator for reproducible results
#' @param verbose Set to TRUE if status updates to be printed (Default: FALSE).
#'
#' @export
meffil.ewas <- function(beta, variable,
						covariates=NULL, batch=NULL, weights=NULL,
						cell.counts=NULL,
						isva=T, sva=T, ## cate?
						n.sv=NULL,
						isva0=F,isva1=F, ## deprecated
						winsorize.pct=0.05,
						robust=TRUE,
						rlm=FALSE,
						outlier.iqr.factor=NA, ## typical value = 3
						most.variable=min(nrow(beta), 50000),
						featureset=NA,
						random.seed=20161123,
						verbose=F) {
	## depreciated Args
	if (isva0 || isva1)
		stop("isva0 and isva1 are deprecated and superceded by isva and sva")
	# warn and set isva, sva values rather than kill?

	if (is.na(featureset))
		featureset <- guess.featureset(rownames(beta))
	features <- meffil.get.features(featureset)

	## data Validation / type checks
	stopifnot(length(rownames(beta)) > 0 && all(rownames(beta) %in% features$name))
	stopifnot(ncol(beta) == length(variable))
	stopifnot(is.null(covariates) || is.data.frame(covariates) && nrow(covariates) == ncol(beta))
	stopifnot(is.null(batch) || length(batch) == ncol(beta))
	stopifnot(is.null(weights)
			|| is.numeric(weights) && (is.matrix(weights) && nrow(weights) == nrow(beta) && ncol(weights) == ncol(beta)
										|| is.vector(weights) && length(weights) == nrow(beta)
										|| is.vector(weights) && length(weights) == ncol(beta)))
	stopifnot(most.variable > 1 && most.variable <= nrow(beta))
	stopifnot(!is.numeric(winsorize.pct) || winsorize.pct > 0 && winsorize.pct < 0.5)

	## cache var and covars
	original.variable <- variable
	original.covariates <- covariates
	if (is.character(variable))
		variable <- as.factor(variable)

	stopifnot(!is.factor(variable) || is.ordered(variable) || length(levels(variable)) == 2)

	msg("Simplifying any categorical variables.", verbose=verbose)
	variable <- simplify.variable(variable)
	if (!is.null(covariates))
		covariates <- do.call(cbind, lapply(covariates, simplify.variable))

	## Getting samples without missing values
	sample.idx <- which(!is.na(variable))
	if (!is.null(covariates))
		sample.idx <- intersect(sample.idx, which(apply(!is.na(covariates), 1, all)))

	msg("Removing", ncol(beta) - length(sample.idx), "missing case(s).", verbose=verbose)

	if (is.matrix(weights))
		weights <- weights[,sample.idx]
	if (is.vector(weights) && length(weights) == ncol(beta))
		weights <- weights[sample.idx]

	beta <- beta[,sample.idx]
	variable <- variable[sample.idx]

	if (!is.null(covariates))
		covariates <- covariates[sample.idx,,drop=F]

	if (!is.null(batch))
		batch <- batch[sample.idx]

	if (!is.null(cell.counts))
		cell.counts <- cell.counts[sample.idx]

	if (!is.null(covariates)) {
		pos.var.idx <- which(apply(covariates, 2, var, na.rm=T) > 0)
		msg("Removing", ncol(covariates) - length(pos.var.idx), "covariates with no variance.",
			verbose=verbose)
		covariates <- covariates[,pos.var.idx, drop=F]
	}

	## ewas setup
	### Declace list to hold different covariate sets ewas results
	covariate.sets <- list(none=NULL)
	if (!is.null(covariates))
		covariate.sets$all <- covariates

	### winsorisation
	if (is.numeric(winsorize.pct))  {
		msg(winsorize.pct, "- winsorizing the beta matrix.", verbose=verbose)
		beta <- winsorize(beta, pct=winsorize.pct)
	}

	### outliers
	too.hi <- too.lo <- NULL
	if (is.numeric(outlier.iqr.factor)) {
		outliersRes <- outliers(beta,outlier.iqr.factor)
		too.hi <- outliersRes$too.hi
		too.lo <- outliersRes$too.lo
	}

	## sva/isva
	if (isva || sva) {
		beta.sva <- beta
		res <- svaPrep(variable,covariates,beta.sva,featureset,most.variable)
		mod <- res$mod
		beta.sva <- res$beta.sva

		if (isva) {
			msg("ISVA.", verbose=verbose)
			covariate.sets$isva <- svaIsva(beta.sva,covariates,random.seed,mod,n.sv,mode="isv",verbose)
			cat("\n")
		}

		if (sva) {
			msg("SVA.", verbose=verbose)
			covariate.sets$sva <- svaIsva(beta.sva,covariates,random.seed,mod,n.sv,mode="sv",verbose)
			cat("\n")
		}
	}

	## run EWASs
	analyses <- sapply(names(covariate.sets), function(name) {
		msg("EWAS for covariate set", name, verbose=verbose)
		covariates <- covariate.sets[[name]]
		ewas(variable,
			 beta=beta,
			 covariates=covariates,
			 batch=batch,
			 weights=weights,
			 cell.counts=cell.counts,
			 winsorize.pct=winsorize.pct,
			 robust=robust,
			 rlm=rlm)
	}, simplify=F)

	## extract results
	p.values <- sapply(analyses, function(analysis) analysis$table$p.value)
	coefficients <- sapply(analyses, function(analysis) analysis$table$coefficient)
	rownames(p.values) <- rownames(coefficients) <- rownames(analyses[[1]]$table)

	for (name in names(analyses)) {
		idx <- match(rownames(analyses[[name]]$table), features$name)
		analyses[[name]]$table$chromosome <- features$chromosome[idx]
		analyses[[name]]$table$position <- features$position[idx]
	}

	## Return results
	list(class="ewas",
		 version=packageVersion("meffil"),
		 samples=sample.idx,
		 variable=original.variable[sample.idx],
		 covariates=original.covariates[sample.idx,,drop=F],
		 winsorize.pct=winsorize.pct,
		 robust=robust,
		 rlm=rlm,
		 outlier.iqr.factor=outlier.iqr.factor,
		 most.variable=most.variable,
		 p.value=p.values,
		 coefficient=coefficients,
		 analyses=analyses,
		 random.seed=random.seed,
		 too.hi=too.hi,
		 too.lo=too.lo)
}

#' is.ewas.object
#'
#' @param object a 'meffil' object (not an actual S3/4 R object)
is.ewas.object <- function(object)
	is.list(object) && "class" %in% names(object) && object$class == "ewas"

#' ewas
#'
#' Test associations between \code{variable} and each row of \code{beta}
#' while adjusting for \code{covariates} (fixed effects) and \code{batch} (random effect).
#' NB only handles discrete 2 catagory variables
#' If \code{cell.counts} is not \code{NULL}, then it is assumed that
#' the methylation data is derived from samples with two cell types.
#' \code{cell.counts} should then be a vector of numbers
#' between 0 and 1 of length equal to \code{variable} corresponding
#' to the proportions of cell of a selected cell type in each sample.
#' The regression model is then modified in order to identify
#' associations specifically in the selected cell type (PMID: 24000956).
ewas <- function(variable, beta, covariates=NULL, batch=NULL, weights=NULL, cell.counts=NULL, winsorize.pct=0.05,
				 robust=TRUE, rlm=FALSE, verbose=F) {
	stopifnot(all(!is.na(variable)))
	stopifnot(length(variable) == ncol(beta))
	stopifnot(is.null(covariates) || nrow(covariates) == ncol(beta))
	stopifnot(is.null(batch) || length(batch) == ncol(beta))
	stopifnot(is.null(cell.counts)
			  || length(cell.counts) == ncol(beta)
			  && all(cell.counts >= 0 & cell.counts <= 1))

	method <- "ls"
	if (rlm) method <- "robust"

	if (is.null(covariates))
		design <- data.frame(intercept=1, variable=variable)
	else
		design <- data.frame(intercept=1, variable=variable, covariates)
	rownames(design) <- colnames(beta)

	if (!is.null(cell.counts)) {
		## Irizarray method: Measuring cell-type specific differential methylation
		##	  in human brain tissue
		## Mi is methylation level for sample i
		## Xi is the value of the variable of interest for sample i
		## pi is the proportion of the target cell type for sample i
		## thus: Mi ~ target cell methylation * pi + other cell methylation * (1-pi)
		## and target cell methylation = base target methylation + effect of Xi value
		## and other cell methylation = base other methylation + effect of Xi value
		## thus:
		## Mi = (T + U Xi)pi + (O + P Xi)(1-pi) + e
		##	= C + A Xi pi + B Xi (1-pi) + e
		design <- design[,-which(colnames(design) == "intercept")]

		design <- cbind(design * cell.counts,
						typeB=design * (1-cell.counts))
	}

	msg("Linear regression with limma::lmFit", verbose=verbose)
	fit <- NULL
	batch.cor <- NULL
	if (!is.null(batch)) {
		msg("Adjusting for batch effect", verbose=verbose)
		corfit <- duplicateCorrelation(beta, design, block=batch, ndups=1)
		batch.cor <- corfit$consensus
		msg("Linear regression with batch as random effect", verbose=verbose)
		tryCatch(fit <- lmFit(beta, design, method=method, block=batch, cor=batch.cor, weights=weights),
				 error=function(e) {
					 print(e)
					 msg("lmFit failed with random effect batch variable, omitting", verbose=verbose)
				 })
	}
	if (is.null(fit)) {
		msg("Linear regression with only fixed effects", verbose=verbose)
		batch <- NULL
		fit <- lmFit(beta, design, method=method, weights=weights)
	}

	msg("Empirical Bayes", verbose=verbose)
	if (is.numeric(winsorize.pct) && robust) {
	  fit.ebayes <- eBayes(fit, robust=T, winsor.tail.p=c(winsorize.pct, winsorize.pct))
	} else {
	  fit.ebayes <- eBayes(fit, robust=robust)
	}

	alpha <- 0.975
	std.error <- (sqrt(fit.ebayes$s2.post) * fit.ebayes$stdev.unscaled[,"variable"])
	margin.error <- (std.error * qt(alpha, df=fit.ebayes$df.total))
	n <- rowSums(!is.na(beta))

	list(design=design,
		 batch=batch,
		 batch.cor=batch.cor,
		 cell.counts=cell.counts,
		 table=data.frame(p.value=fit.ebayes$p.value[,"variable"],
			 fdr=p.adjust(fit.ebayes$p.value[,"variable"], "fdr"),
			 p.holm=p.adjust(fit.ebayes$p.value[,"variable"], "holm"),
			 t.statistic=fit.ebayes$t[,"variable"],
			 coefficient=fit.ebayes$coefficient[,"variable"],
			 coefficient.ci.high=fit.ebayes$coefficient[,"variable"] + margin.error,
			 coefficient.ci.low=fit.ebayes$coefficient[,"variable"] - margin.error,
			 coefficient.se=std.error,
			 n=n))
}

#' Epigenome-wide association study (lm)
#'
#' Test association with each CpG site.
#'
#' @param beta Methylation levels matrix, one row per CpG site, one column per sample.
#' @param variable Independent variable vector.
#' @param covariates Covariates data frame to include in regression model,
#' one row per sample, one column per covariate (Default: NULL).
#' @param weights numeric vector of weights to provide to the lm()/glm() function
#' @param family to perform generalised linear modeling with r's glm() function
#' @param isva Apply Independent Surrogate Variable Analysis (ISVA) to the
#' methylation levels and include the resulting variables as covariates in a
#' regression model (Default: TRUE).
#' @param sva Apply Surrogate Variable Analysis (SVA) to the
#' methylation levels and covariates and include
#' the resulting variables as covariates in a regression model (Default: TRUE).
#' @param n.sv Number of surrogate variables to calculate (Default: NULL).
#' @param winsorize.pct Apply all regression models to methylation levels
#' winsorized to the given level. Set to NA to avoid winsorizing (Default: 0.05).
#' @param outlier.iqr.factor For each CpG site, prior to fitting regression models,
#' set methylation levels less than
#' \code{Q1 - outlier.iqr.factor * IQR} or more than
#' \code{Q3 + outlier.iqr.factor * IQR} to NA. Here IQR is the inter-quartile
#' range of the methylation levels at the CpG site, i.e. Q3-Q1.
#' Set to NA to skip this step (Default: NA).
#' @param most.variable Apply (Independent) Surrogate Variable Analysis to the
#' given most variable CpG sites (Default: 50000).
#' @param featureset Name from \code{\link{meffil.list.featuresets}()}  (Default: NA).
#' @param random.seed Value with which to seed the pseudo random number generator for reproducible results
#' @param verbose Set to TRUE if status updates to be printed (Default: FALSE).
#'
#' @export
meffil.ewas.lm <- function(beta, variable,
							covariates=NULL,
							#batch=NULL,
							weights=NULL,
							family=NULL,
							#cell.counts=NULL,
							isva=T, sva=T, ## cate?
							n.sv=NULL,
							isva0=F,isva1=F, ## deprecated
							winsorize.pct=0.05,
							outlier.iqr.factor=NA, ## typical value = 3
							most.variable=min(nrow(beta), 50000),
							featureset=NA,
							random.seed=20161123,
							verbose=F) {
	## depreciated Args
	if (isva0 || isva1)
		stop("isva0 and isva1 are deprecated and superceded by isva and sva")
	# warn and set isva, sva values rather than kill?

	if (is.na(featureset))
		featureset <- guess.featureset(rownames(beta))
	features <- meffil.get.features(featureset)

	phenotype.data <- cbind(variable,covariates)

	varName <- colnames(variable)
	variable <- unlist(variable,use.names = F)

	## data Validation / type checks
	stopifnot(length(rownames(beta)) > 0 && all(rownames(beta) %in% features$name))
	stopifnot(ncol(beta) == length(variable))
	stopifnot(is.null(covariates) || is.data.frame(covariates) && nrow(covariates) == ncol(beta))
	#stopifnot(is.null(batch) || length(batch) == ncol(beta))
	stopifnot(is.null(weights)|| is.numeric(weights))
	stopifnot(most.variable > 1 && most.variable <= nrow(beta))
	stopifnot(!is.numeric(winsorize.pct) || winsorize.pct > 0 && winsorize.pct < 0.5)

	## cache var and covars
	original.variable <- variable
	original.covariates <- covariates

	msg("Simplifying any categorical variables.", verbose=verbose)
	variable <- simplify.variable(variable)
	if (!is.null(covariates))
		covariates <- do.call(cbind, lapply(covariates, simplify.variable))

	## Getting samples without missing values
	# sample.idx = all samples without missing value?s
	sample.idx <- which(!is.na(variable))

	##!! removing missing values from NB phenotype.data !!##
	##!! get rid ot phenotype.data and merge var/covar to data frame and pass to ewas.lm !!##
	phenotype.data[sample.idx,,drop=F]

	if (!is.null(covariates))
		sample.idx <- intersect(sample.idx, which(apply(!is.na(covariates), 1, all)))

	msg("Removing", ncol(beta) - length(sample.idx), "missing case(s).", verbose=verbose)

	if (is.vector(weights) && length(weights) == ncol(beta))
		weights <- weights[sample.idx]

	beta <- beta[,sample.idx]
	variable <- variable[sample.idx]

	if (!is.null(covariates))
		covariates <- covariates[sample.idx,,drop=F]

	# if (!is.null(batch))
	# 	batch <- batch[sample.idx]
	#
	# if (!is.null(cell.counts))
	# 	cell.counts <- cell.counts[sample.idx]

	if (!is.null(covariates)) {
		pos.var.idx <- which(apply(covariates, 2, var, na.rm=T) > 0)
		msg("Removing", ncol(covariates) - length(pos.var.idx), "covariates with no variance.",
			verbose=verbose)
		covariates <- covariates[,pos.var.idx, drop=F]
	}

	## ewas setup
	### Declace list to hold different covariate sets ewas results
	covariate.sets <- list(none=NULL)
	if (!is.null(covariates))
		covariate.sets$all <- covariates

	### winsorisation
	if (is.numeric(winsorize.pct))  {
		msg(winsorize.pct, "- winsorizing the beta matrix.", verbose=verbose)
		beta <- winsorize(beta, pct=winsorize.pct)
	}

	### outliers
	too.hi <- too.lo <- NULL
	if (is.numeric(outlier.iqr.factor)) {
		outliersRes <- outliers(beta,outlier.iqr.factor)
		too.hi <- outliersRes$too.hi
		too.lo <- outliersRes$too.lo
	}

	## sva/isva
	if (isva || sva) {
		beta.sva <- beta
		res <- svaPrep(variable,covariates,beta.sva,featureset,most.variable)
		mod <- res$mod
		beta.sva <- res$beta.sva

		if (isva) {
			msg("ISVA.", verbose=verbose)
			covariate.sets$isva <- svaIsva(beta.sva,covariates,random.seed,mod,n.sv,mode="isv",verbose)
			cat("\n")
		}

		if (sva) {
			msg("SVA.", verbose=verbose)
			covariate.sets$sva <- svaIsva(beta.sva,covariates,random.seed,mod,n.sv,mode="sv",verbose)
			cat("\n")
		}
	}

	## run EWASs
	analyses <- sapply(names(covariate.sets), function(name) {
		msg("EWAS for covariate set", name, verbose=verbose)
		covariates <- covariate.sets[[name]]
		if(!is.null(covariate.sets[[name]])){
			phenotype.data <- cbind(phenotype.data,covariate.sets[[name]]) ##!!
			#phenotype.data <- cbind(variable,covariate.sets[[name]]) ##!! ??
			#colnames(phenotype.data) <- c(varName,colnames(covariates))
		}
		ewas.lm(variable=varName,
				beta=beta,
				covariates=colnames(covariates),
				#batch=batch,
				weights=weights,
				#cell.counts=cell.counts,
				winsorize.pct=winsorize.pct,
				phenotype.data = phenotype.data,
				family=family
		)
	}, simplify=F)

	## extract results
	p.values <- sapply(analyses, function(analysis) analysis$table$p.value)
	coefficients <- sapply(analyses, function(analysis) analysis$table$coefficient)
	rownames(p.values) <- rownames(coefficients) <- rownames(analyses[[1]]$table)

	for (name in names(analyses)) {
		idx <- match(rownames(analyses[[name]]$table), features$name)
		analyses[[name]]$table$chromosome <- features$chromosome[idx]
		analyses[[name]]$table$position <- features$position[idx]
	}

	list(class="ewas",
		version=packageVersion("meffil"),
		samples=sample.idx,
		variable=original.variable[sample.idx],
		covariates=original.covariates[sample.idx,,drop=F],
		winsorize.pct=winsorize.pct,
		#robust=robust,
		#rlm=rlm,
		outlier.iqr.factor=outlier.iqr.factor,
		most.variable=most.variable,
		p.value=p.values,
		coefficient=coefficients,
		analyses=analyses,
		random.seed=random.seed,
		too.hi=too.hi,
		too.lo=too.lo)
}

#' ewas.lm
#'
#' performs EWAS using r's lm()/glm() functions
#'
#' Test associations between \code{variable} and each row of \code{beta}
#' while adjusting for \code{covariates}
ewas.lm <- function(variable, beta, covariates=NULL,
					weights=NULL, winsorize.pct=0.05,
					verbose=F,phenotype.data=NULL,family=NULL) {
	## Data Validation
	stopifnot(is.character(variable))
	#stopifnot(is.character(covariates))
	stopifnot(is.null(phenotype.data) || nrow(phenotype.data) == ncol(beta))
	n <- rowSums(!is.na(beta))

	## Set design
	#(different if no covars)
	design <- NULL
	designFx <- NULL
	if(is.null(covariates)) {
		design <- data.frame(intercept=1, variable=phenotype.data[,variable])
		designFx <- function(variable,covariates) {
			paste0(variable,"~meth.matrix[cpg,]")
		}
	}
	else {
		design <- data.frame(intercept=1, variable=phenotype.data[,variable], covariates=phenotype.data[,covariates])
		designFx <- function(variable,covariates) {
		paste0(variable,"~meth.matrix[cpg,]+",paste0(covariates,collapse="+"))
		}
	}
	rownames(design) <- colnames(beta)

	## Set modeling type - fit glm if family provided
	modFx <- NULL
	if(is.null(family)) {
		modFx <- function(FORM,data,family,weights){
			lm(FORM,data,weights)
		}
	}
	else {
		modFx <- function(FORM,data,family,weights){
		glm(FORM,data,family = family,weights=weights)
		}
	}

	## Model building and parsing function
	model <- function(cpg, meth.matrix, variable, covariates, phenotype.data,family,weights) {
		FORM=formula(designFx(variable,covariates))
		mod= modFx(FORM,data=phenotype.data,family = family,weights=weights)
		res = summary(mod)$coef[2,c("Estimate","Std. Error","Pr(>|t|)")]
	}

	## Run models (in parallel)
	ewas_res <- mclapply(setNames(seq_len(nrow(beta)),dimnames(beta)[[1]]),
						model,
						meth.matrix=beta,
						variable=variable,
						covariates=covariates,
						phenotype.data=phenotype.data,
						family=family,
						weights=weights)

	ewas_res <- data.frame(t(sapply(ewas_res,c)))

	colnames(ewas_res)<-c("effect.size","std.err","P.value")

	## Return results
	list(design=design,
		#batch=batch,
		#batch.cor=batch.cor,
		#cell.counts=cell.counts,
		table=data.frame(p.value=ewas_res$P.value,
						coefficient=ewas_res$effect.size,
						coefficient.se=ewas_res$std.err,
						n=n))
}


# Copyright 2018 Dominic Davis-Foster, except where noted below
#' v1.1'

#' Clear Terminal Function
#'
#' This function clears the terminal on Unix systems.
#' Does not work on Windows.
#' Run makeActiveBinding("clear", clear, environment())
#'	to be able to type "clear"
#' @keywords clear
#' @export
#' @examples
#' clear()
clear <- function() cat(c("\033[2J","\033[0;0H"));

#' Newline Function
#'
#' This function starts a new line on the terminal.
#' Can also be used to print a blank line.
#' Run makeActiveBinding("newline", newline, environment())
#'	to be able to type "newline
#' @keywords newline
#' @export
#' @examples
#' newline()
newline <- function() cat("\n");

#' Input Prompt Function
#'
#' This function creates an input prompt with customisable text.
#' Multiple inputs are possible with "lines" option".
#'
#' @keywords input
#' @export
#' @examples
#' input("Press [Enter] to Continue")
#' name = input("Enter your name: ", lines=2)
input <- function(text='', lines=1) {
	cat(text);
	a <- readLines("stdin",n=lines);
	return(a)
}

#' Type Function
#'
#' Synonym for builtin "mode" function.
#'
#' @keywords type mode
#' @export
#' @examples
#' type(LETTERS)
#'
type <- function(variable) {
	a <- mode(variable);
	return(a)
}

#' Mode Average Function
#'
#' Function to calculate the modal average.
#'
#' @keywords mode average
#' @export
#' @examples
#' modes(sample(1:10, 10, replace=TRUE))
#'
modes <- function(x) {
  ux <- unique(x)
  tab <- tabulate(match(x, ux))
  ux[tab == max(tab)]
}

#' Capitalise First Letter Function
#'
#' Function to capitalise the first letter of a character string.
#' From https://stackoverflow.com/questions/18509527/first-letter-to-upper-case/18509816
#'
#' @keywords capitalise letter character string
#' @export
#' @examples
#' firstup("rStudio")
#'
firstup <- function(x) {
   substr(x, 1, 1) <- toupper(substr(x, 1, 1))
x
}

#' Shapiro-Wilk Test for Data Frames
#'
#' Function to perform Shapiro-Wilk test for each column of a Data Frame.
#' Can provide interpretation for p-value with "interpret=TRUE".
#' Modified from https://stackoverflow.com/questions/45226457/r-loop-performing-ks-tests-across-data-frame-stored-in-matrix
#'
#' @keywords Shapiro Shapiro-Wilk data.frame normality
#' @export
#' @examples
#' colShapiro(dataframe, interpret=TRUE)
#'
colShapiro <- function(x, print=FALSE, interpret=FALSE) {
	res <- sapply(x, function(y) {
	  shapiro <- shapiro.test(y)
	if (interpret) {
		c(statistic=shapiro$statistic, p.value=shapiro$p.value, normal=shapiro$p.value>0.05)
		setNames(c(shapiro$statistic, shapiro$p.value, normal=shapiro$p.value>0.05), c("statistic", "p.value", "normal"))
	}
	else {
		c(statistic=shapiro$statistic, p.value=shapiro$p.value)
		setNames(c(shapiro$statistic, shapiro$p.value), c("statistic", "p.value"))
	}
	})

	if (print) {
		print("Shapiro-Wilk Test")
	}
	return(res)
}

#' Kolmogorov-Smirnov Normal Distribution Test for Data Frames
#'
#' Function to perform Kolmogorov-Smirnov test for normal distribution
#' on each column of a Data Frame.
#' Can provide interpretation for p-value with "interpret=TRUE".
#' Modified from https://stackoverflow.com/questions/45226457/r-loop-performing-ks-tests-across-data-frame-stored-in-matrix
#'
#' @keywords Kolmogorov-Smirnov data.frame normalty KS
#' @export
#' @examples
#' colKS(dataframe, interpret=TRUE)
#'
colKS <- function(x, print = FALSE, interpret=FALSE) {
	res <- sapply(x, function(y) {
	ks <- ks.test(y, pnorm, mean(y), sd(y))
	if (interpret) {
		c(statistic=ks$statistic, p.value=ks$p.value, normal=ks$p.value>0.05)
		setNames(c(ks$statistic, ks$p.value, normal=ks$p.value>0.05), c("statistic", "p.value", "normal"))
	}
	else {
		c(statistic=ks$statistic, p.value=ks$p.value)
		setNames(c(ks$statistic, ks$p.value), c("statistic", "p.value"))
	}
	})

	if (print) {
		print("Kolmogorov-Smirnov Test")
	}
	return(res)
}

#' Standard Deviation for Data Frames
#'
#' Function to calculate Standard Deviation for each column of a Data Frame.
#' Modified from https://stackoverflow.com/questions/37806387/r-calculate-standard-deviation-in-cols-in-a-data-frame-despite-of-na-values
#'
#' @keywords Standard Deviation std sd stdev data.frame
#' @export
#' @examples
#' colSD(dataframe)
#'
# data frame sd
colSD <- function(x, print=FALSE) {
	if (print) {
		print("Standard Deviation")
	}
	sapply(x, sd, na.rm = TRUE)
}

#' Median for Data Frames
#'
#' Function to calculate Median for each column of a Data Frame.
#' Modified from https://stackoverflow.com/questions/37806387/r-calculate-standard-deviation-in-cols-in-a-data-frame-despite-of-na-values
#'
#' @keywords Median data.frame
#' @export
#' @examples
#' colMedian(dataframe)
#'
# data frame sd
colMedian <- function(x, print=FALSE) {
	if (print) {
		print("Median")
	}
	sapply(x, median, na.rm = TRUE)
}


# Copyright © 2013-2015 Université catholique de Louvain, Belgium - UCL
# All rights reserved.
#
# This file is part of the precall package.
#
# The precall package has been developed by Adrien Dessy [Machine Learning
# Group (MLG) - Institute of Information and Communication Technologies,
# Electronics and Applied Mathematics (ICTEAM)] for the Université catholique de
# Louvain (UCL). The precall package enables to plot precision-recall curves and
# to compute the Area Under Precision-Recall curves.
#
# The precall package is distributed under the terms of the MIT License (MIT).
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is furnished
# to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

#' @importFrom magrittr "%>%"
NULL

#' Plot precision-recall curves
#'
#' \code{plot_precall} creates a ggplot object that represents precision-recall
#' curves corresponding to several rankings.
#'
#' @param scores A matrix or vector of numeric values that specifies the rankings
#' @param labels A vector of logical values that encodes the POSITIVE/NEGATIVE status of data
#' @param print_friendly A boolean
#' @param use_color A boolean
#' @param use_linetype A boolean
#' @param axis_label_size A numeric
#' @param legend_title_size A numeric
#' @param legend_text_size A numeric
#' @param linewidth A numeric
#'
#' @details
#'
#' The \code{labels} encode the POSITIVE/NEGATIVE (\code{TRUE}/\code{FALSE}) status of data
#' while each column of \code{scores} provides scores corresponding to a ranking of those data:
#' a smaller score means a smaller rank.
#'
#' A precision-recall curve is plotted for each column of the \code{scores}. The interpolation
#' between points is done according to the principle of partial acceptance.
#'
#' \code{print_friendly} enables to produce print-friendly plots.
#' If set to \code{TRUE}, the function yields a black and white plot (background and lines)
#' with a different line type for each curve.
#' \code{use_color} and \code{use_linetype}, if present, specifies if the curved should be colored or
#' drawn with different line types.
#' These parameters override the behavior specified by \code{print_friendly}.
#'
#' \code{axis_label_size}, \code{legend_title_size}, \code{legend_text_size} and \code{linewidth} are
#' self-explanatory parameters to tune a few aesthetics.
#' Besides, the function returns a ggplot object which can be modified a posteriori using the ggplot
#' interface.
#'
#' @return A \code{ggplot} object representing precision-recall curves.
#' @examples
#'
#' labels = c(TRUE, FALSE, TRUE, FALSE, TRUE, TRUE, FALSE, FALSE) # 8 pieces of data
#'
#' ranking1 = c(1,1,8,3,7,6,4,5)
#' ranking2 = c(4,6,3,3,2,5,6,6)
#' ranking3 = c(6,-1,3,3,2,4,1,5)
#'
#' scores = cbind(ranking1, ranking2, ranking3)
#' colnames(scores) = c("method a", "method b", "method c")
#'
#' # Default plot
#' plot_precall(labels, scores)
#'
#' # Black and white plot
#' plot_precall(labels, scores, print_friendly=TRUE)
#'
#' # Print-friendly background with colored curves
#' plot_precall(labels, scores, print_friendly=TRUE, use_color=TRUE, use_linetype=FALSE)
#'
#' @export
plot_precall <- function(labels, scores, print_friendly = FALSE, use_color, use_linetype,
                         axis_label_size=15, legend_title_size=13, legend_text_size=10,
                         linewidth=0.7)
{

  if(missing(scores)) scores = matrix(seq_along(labels))
  if(missing(use_color)) use_color = !print_friendly
  if(missing(use_linetype)) use_linetype = print_friendly

  if(scores %>% is.vector) scores = matrix(scores)
  check_arguments(labels, scores)

  # Each column corresponds to the ranking of a method.
  meth_names = paste("ranking", seq_len(ncol(scores)))
  col_names = colnames(scores)
  if(!is.null(col_names)){
    meth_names[col_names != ""] = col_names[col_names != ""]
  }

  coord_matrices = plyr::alply(.data=scores, .margins=2,
                               .fun=precall_interpolation,
                               labels=labels)
  names(coord_matrices) = meth_names
  coord_matrices = lapply(meth_names, FUN=function(n) cbind(coord_matrices[[n]],n))
  coord_matrix = do.call(rbind, coord_matrices)
  coord_matrix = data.frame(coord_matrix)
  colnames(coord_matrix) = c("precision", "recall", "Method")

  # Creating the PR-curve
  aesthetics = ggplot2::aes(x=recall, y=precision, color=Method, linetype=Method)
  if(!use_color)    aesthetics$colour   = NULL
  if(!use_linetype) aesthetics$linetype = NULL

  plot = ggplot2::ggplot(coord_matrix, aesthetics)
  plot = plot + ggplot2::geom_line(size=linewidth)

  plot = plot + ggplot2::scale_x_continuous(limits = c(0,1), name="Recall")
  plot = plot + ggplot2::scale_y_continuous(limits = c(0,1), name="Precision")
  if(print_friendly) plot = plot + ggplot2::theme_bw()
  plot = plot + ggplot2::theme(axis.title   = ggplot2::element_text(size=axis_label_size,   face="bold"))
  plot = plot + ggplot2::theme(legend.title = ggplot2::element_text(size=legend_title_size, face="bold"))
  plot = plot + ggplot2::theme(legend.text  = ggplot2::element_text(size=legend_text_size))

  return(plot)
}

#' Computes the point coordinates of a precision-recall curve
#'
#' @param scores A vector of numeric values
#' @param labels A vector of logical values
#' @param nb_interpolation_points A numeric
precall_interpolation <- function(labels, scores, nb_interpolation_points=30)
{
  unique_scores <- sort(unique(scores), decreasing = FALSE)

  if(length(unique_scores)==1) {
    precision = sum(labels)/length(labels)
    precisions = c(precision, precision)
    recalls = c(0,1)
    return(data.frame(precision = precisions, recall = recalls))
  }

  cumsum_num   = sapply(unique_scores, function(s) sum(scores[ labels] <= s))
  cumsum_denom = sapply(unique_scores, function(s) sum(scores <= s))

  interp_num = sapply(seq_len(length(cumsum_num) - 1), function(i) {
    seq(cumsum_num[i], cumsum_num[i + 1], length = nb_interpolation_points)
  })
  interp_denom = sapply(seq_len(length(cumsum_num) - 1), function(i) {
    seq(cumsum_denom[i], cumsum_denom[i + 1], length = nb_interpolation_points)
  })

  dim(interp_num) = NULL
  dim(interp_denom) = NULL

  precisions = interp_num/interp_denom
  recalls = interp_num/sum(labels)
  precisions = c(precisions[1], precisions)
  recalls = c(0, recalls)

  drop = sapply(2:(length(recalls)-1), function(i) recalls[i-1]==recalls[i+1])
  drop = c(FALSE, drop, FALSE)

  recalls = recalls[!drop]
  precisions = precisions[!drop]

  return(data.frame(precision = precisions, recall = recalls))
}

#' Compute the AUPR for precision-recall curves.
#'
#' Compute the Area Under the Precision-Recall curve (AUPR) for one or multiple precision-recall curves.
#'
#' @param scores A matrix or vector of numeric values that specifies the rankings
#' @param labels A vector of logical values that encodes the POSITIVE/NEGATIVE status of data
#'
#' @return The vector of AUPR's.
#'
#' @details
#'
#' The \code{labels} encode the POSITIVE/NEGATIVE (\code{TRUE}/\code{FALSE}) status of data
#' while each column of \code{scores} provides scores corresponding to a ranking of those data:
#' a smaller score means a smaller rank.
#' A vector can be used as \code{scores} instead of a 1-column matrix to compute the AUPR of
#' only one ranking. If no \code{scores} are provided, it is assumed that the labels are already
#' sorted and the function computes the corresponding AUPR.
#'
#' If \code{scores} is a k-column matrix, the function returns a vector of length k, otherwise it
#' returns a scalar.
#'
#' The area is computed from precision-recall curves interpolated using the principle of partial
#' acceptance (see vignette \code{precall} for more details).
#'
#' @examples
#'
#' labels = c(TRUE, FALSE, TRUE, FALSE, TRUE, TRUE, FALSE, FALSE) # 8 pieces of data
#'
#' ranking1 = c(1,1,8,3,7,6,4,5)
#' ranking2 = c(4,6,3,3,2,5,6,6)
#' ranking3 = c(6,-1,3,3,2,4,1,5)
#'
#' scores = cbind(ranking1, ranking2, ranking3)
#' colnames(scores) = c("method a", "method b", "method c")
#'
#' # Implicit ranking
#' aupr(labels)
#' aupr(labels) == aupr(labels, seq_along(labels)) # is TRUE
#'
#' # Explicit single ranking
#' aupr(labels, ranking1)
#'
#' # Explicit multiple rankings
#' aupr(labels, scores)
#'
#' @export
aupr <- function(labels, scores){

  if(missing(scores)) scores = matrix(seq_along(labels))
  if(scores %>% is.vector) scores = matrix(scores)
  check_arguments(labels, scores)

  apply(scores, 2, function(s) {compute_aupr(labels,s)})
}

compute_aupr <- function(labels, scores){

    unique_scores  <- sort(unique(scores), decreasing = FALSE)
    total_positives <- sum(labels)

    true_positives <- sapply(unique_scores, function(s) sum(scores[labels] <= s))
    positives      <- sapply(unique_scores, function(s) sum(scores <= s))

    if(true_positives[1] != 0){
      area = true_positives[1] / total_positives
      area = area * true_positives[1] / positives[1]
    } else {
      area = 0
    }

    len = length(unique_scores) - 1
    for(i in seq_len(len)){

      tp1 = true_positives[i]
      tp2 = true_positives[i+1]

      if(tp1 == tp2) next

      p1 = positives[i]
      p2 = positives[i+1]

      area = area + .aupr_piece(tp1, tp2, p1, p2, total_positives)
    }

    return(area)
}

#' Computes a partial AUPR
#'
#' Computes a partial AUPR (area under precision-recall curve)
#'
#' @param p Total number of positives
#' @param p1 Number of positives at position 1
#' @param p2 Number of positives at position 2
#' @param tp1 Number of true positives at position 1
#' @param tp2 Number of true positives at position 2
#'
#' @return Return the aupr between position 1 and position 2.
.aupr_piece <- function(tp1, tp2, p1, p2, p){
  area <- log(p2/p1) * (tp1 * p2 - tp2 * p1) / (p1 - p2)^2
  area <- area + (tp1 - tp2)/(p1 - p2)
  area <- area * (tp2-tp1)/p

  return(area)
}

# Check the validity of scores and labels arguments.
check_arguments <- function(labels, scores) {
  assertthat::assert_that(scores %>% is.numeric, msg="scores must be a numeric matrix or vector")
  assertthat::assert_that(scores %>% is.matrix,  msg="scores must be a numeric matrix or vector")
  assertthat::assert_that(labels %>% is.logical, msg="labels must be a vector of logical values")
  assertthat::assert_that(labels %>% is.vector,  msg="labels must be a vector of logical values")

  assertthat::assert_that(length(labels) == nrow(scores),
                          msg="the number of rows of scores must be equal to the length of labels.")
}