#script to create moisture capital map from GCM output

#requires climate data from cru_ts4.zip (via https://crudata.uea.ac.uk/cru/data/hrg/)

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

#read munis.r as latlong
#unzip(zipfile="Data/sim10_BRmunis_latlon_5km.zip",exdir="Data")  #unzip
munis.r <- raster("Data/sim10_BRmunis_latlon_5km.asc")
latlong <- "+proj=longlat +ellps=WGS84 +towgs84=0,0,0,0,0,0,0 +no_defs "
crs(munis.r) <- latlong

#soil is used to calculate plant available water
#read soil texture and set bucket size (see email from Daniel Victoria 2017-11-21)
#unzip(zipfile="Data/soilT_2018-05-01.zip",exdir="Data")  #unzip
soil<-raster("Data/soilT_2018-05-01.asc")

#PAW is Plant Available Water
PAW<-soil
PAW[PAW==1]<-0
PAW[PAW==2]<-0
PAW[PAW==3]<-75
PAW[PAW==4]<-55
PAW[PAW==5]<-35
#plot(PAW)

#this function January to December (NH agricultural year)
nc2raster <- function(ncyear, ncvar)
{
  #this is hacked version of cruts2raster function in library(cruts) see https://rdrr.io/cran/cruts/src/R/import-export.R
  #returns a raster stack of 12 layers for a single year from cru_ts data (e.g. http://data.ceda.ac.uk//badc/cru/data/cru_ts/cru_ts_4.01/data/)
  #needed becase cruts2raster returns same data (year) regardless of timeRange provided

  #ncname is a character string of the ncdf file (e.g."cru_ts4.01.2001.2010.pre.dat.nc")
  #ncyear is an integer indicating which year from the ncdf file is to be returned (so for above file ncyear <- 1 would return data for 2001, ncyear <- 4 would give 2004 etc)
  #ncvar is a character string indicating which variable from the nc file to access (e.g. "pre", "tmp")

  ncname <- fn_fromYearVar(ncyear,ncvar)
  nc <- nc_open(ncname)
  pre_array <- ncvar_get(nc,ncvar)
  lon <- ncvar_get(nc,"lon")
  lat <- ncvar_get(nc,"lat")

  M <- length(lon)
  N <- length(lat)
  dx <- diff(lon[1:2])
  dy <- diff(lat[1:2])

  tr <- y_fromYear(ncyear)
  startmonth <- (tr * 12) - 11

  s1 <- raster(t(pre_array[,,startmonth][,N:1]), xmn=lon[1]-dx/2, xmx=lon[M]+dx/2, ymn=lat[1]-dy/2, ymx=lat[N]+dy/2, crs=CRS("+init=epsg:4326"))

  startmonth <- startmonth + 1
  endmonth <- startmonth + 10

  for(mon in startmonth:endmonth)
  {
    s1 <- stack(s1, raster(t(pre_array[,,mon][,N:1]), xmn=lon[1]-dx/2, xmx=lon[M]+dx/2, ymn=lat[1]-dy/2, ymx=lat[N]+dy/2, crs=CRS("+init=epsg:4326")))
  }

  names(s1) <- c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")

  return(s1)
}

#this function July to June (SH agricultural year)
nc2rasterSH <- function(ncyear, ncvar)
{
  #this is hacked version of cruts2raster function in library(cruts) see https://rdrr.io/cran/cruts/src/R/import-export.R
  #returns a raster stack of 12 layers for a single year from cru_ts data (e.g. http://data.ceda.ac.uk//badc/cru/data/cru_ts/cru_ts_4.01/data/)
  #needed becase cruts2raster returns same data (year) regardless of timeRange provided

  #ncname is a character string of the ncdf file (e.g."cru_ts4.01.2001.2010.pre.dat.nc")
  #ncyear is an integer indicating which year from the ncdf file is to be returned (so for above file ncyear <- 1 would return data for 2001, ncyear <- 4 would give 2004 etc)
  #ncvar is a character string indicating which variable from the nc file to access (e.g. "pre", "tmp")

  #for SH neeed to get two years of data!
  #agricultural year is July ncyear-1 (yrA) to June ncyear (yrB)

  #as long as ncyear is not the first year in a ncdf file (e.g. not 2001) we can use just a single ncdf file
  #otherwise we need to get data two ncdf file (this is handled below by the if statement)

  #so first get the ncdf file in which yrB is located

  ncnameB <- fn_fromYearVar(ncyear,ncvar)
  ncB <- nc_open(ncnameB)  #get data for yrB

  #get these parameters here (if we need to get for another ncdf file we will below)
  pre_arrayB <- ncvar_get(ncB,ncvar)
  lonB <- ncvar_get(ncB,"lon")
  latB <- ncvar_get(ncB,"lat")

  MB <- length(lonB)
  NB <- length(latB)
  dxB <- diff(lonB[1:2])
  dyB <- diff(latB[1:2])

  #need to split the remaining stacking into two loops, one for yrB, one for yrA
  #startmonth becomes July of yrA
  #endmonth of yrA is December

  #startmonth of yrB is January
  #endmonth of yrB is June

  #startmonth <- (ncyear * 12) - 11

  tr <- y_fromYear(ncyear)

  #works as long as ncyear (yrB) is not the first in the ncdf file
  if(tr != 1) {

    startmonth <- (tr * 12) - 17

    s1 <- raster(t(pre_arrayB[,,startmonth][,NB:1]), xmn=lonB[1]-dxB/2, xmx=lonB[MB]+dxB/2, ymn=latB[1]-dyB/2, ymx=latB[NB]+dyB/2, crs=CRS("+init=epsg:4326"))

    startmonth <- startmonth + 1
    endmonth <- startmonth + 10

    for(mon in startmonth:endmonth)
    {
      s1 <- stack(s1, raster(t(pre_arrayB[,,mon][,NB:1]), xmn=lonB[1]-dxB/2, xmx=lonB[MB]+dxB/2, ymn=latB[1]-dyB/2, ymx=latB[NB]+dyB/2, crs=CRS("+init=epsg:4326")))
    }
  }

  #otherwise data for yrA is in an entirely different ncdf file
  else {

    ncnameA <- fn_fromYearVar(ncyear-1, ncvar)
    print(paste0("reading file ",ncnameA))

    ncA <- nc_open(ncnameA)  #get data for this year

    pre_arrayA <- ncvar_get(ncA,ncvar)
    lonA <- ncvar_get(ncA,"lon")
    latA <- ncvar_get(ncA,"lat")

    MA <- length(lonA)
    N.A <- length(latA)
    dxA <- diff(lonA[1:2])
    dyA <- diff(latA[1:2])

    #from earliest nc file get last 6 months
    trA <- y_fromYear(ncyear-1)
    startmonthA <- (trA * 12) - 5

    s1 <- raster(t(pre_arrayA[,,startmonthA][,N.A:1]), xmn=lonA[1]-dxA/2, xmx=lonA[MA]+dxA/2, ymn=latA[1]-dyA/2, ymx=latA[N.A]+dyA/2, crs=CRS("+init=epsg:4326"))

    startmonthA <- startmonthA + 1
    endmonthA <- startmonthA + 4

    for(mon in startmonthA:endmonthA)
    {
      s1 <- stack(s1, raster(t(pre_arrayA[,,mon][,N.A:1]), xmn=lonA[1]-dxA/2, xmx=lonA[MA]+dxA/2, ymn=latA[1]-dyA/2, ymx=latA[N.A]+dyA/2, crs=CRS("+init=epsg:4326")))
    }

    #from later nc file get first 6 months
    startmonth <- 1
    endmonth <- 6

    for(mon in startmonth:endmonth)
    {
      s1 <- stack(s1, raster(t(pre_arrayB[,,mon][,NB:1]), xmn=lonB[1]-dxB/2, xmx=lonB[MB]+dxB/2, ymn=latB[1]-dyB/2, ymx=latB[NB]+dyB/2, crs=CRS("+init=epsg:4326")))
    }

  }

  names(s1) <- c(paste0("Jul",ncyear-1),paste0("Aug",ncyear-1),paste0("Sep",ncyear-1),paste0("Oct",ncyear-1),paste0("Nov",ncyear-1),paste0("Dec",ncyear-1),paste0("Jan",ncyear),paste0("Feb",ncyear),paste0("Mar",ncyear),paste0("Apr",ncyear),paste0("May",ncyear),paste0("Jun",ncyear))

  return(s1)
}

#function to return final digit from a four-digit integer (for use in nc2raster)
y_fromYear <- function(year)
{
  y <- year %% 10
  if(y == 0) { y <- 10 }
  return(y)
}

#function to set climate file name (for use in nc2raster) from a year integer and variable (pre, tmn, tmx)
fn_fromYearVar <- function(year, var)
{
  yr = "Data/cruts/cru_ts4.03.1991.2000."
  if(year > 2000 & year <= 2010) { yr = "Data/cruts/cru_ts4.03.2001.2010."}
  if(year > 2010 & year <= 2018) { yr = "Data/cruts/cru_ts4.03.2011.2018."}

  return(paste0(yr,var,".dat.nc"))
}

#extent object to use in pdf map plots
BRA.ext <- extent(-62.39713, -35.43949, -33.89756, -4.06125)

calcMoistureMaps <- function(munis.r, PAW, year, BRA.e, hemi, season, GS)
{
  #generate timeRange and filenames for this year
  tr <- y_fromYear(year)
  prefn <- fn_fromYearVar(year,"pre") #precipitation,	millimetres per month  see: https://crudata.uea.ac.uk/cru/data/hrg/#info
  tmnfn <- fn_fromYearVar(year,"tmn") #monthly average daily minimum temperature,	degrees Celsiusunits are
  tmxfn <- fn_fromYearVar(year,"tmx") #monthly average daily maximum temperature,	degrees Celsius

  #month labels for plots
  monlab <- c(paste0("Jan",year),paste0("Feb",year),paste0("Mar",year),paste0("Apr",year),paste0("May",year),paste0("Jun",year),paste0("Jul",year),paste0("Aug",year),paste0("Sep",year),paste0("Oct",year),paste0("Nov",year),paste0("Dec",year))
  if(hemi == "S")  monlab <- c(paste0("Jul",year-1),paste0("Aug",year-1),paste0("Sep",year-1),paste0("Oct",year-1),paste0("Nov",year-1),paste0("Dec",year-1),paste0("Jan",year),paste0("Feb",year),paste0("Mar",year),paste0("Apr",year),paste0("May",year),paste0("Jun",year))

  #create season filelabel
  season_label <- paste0(season, collapse="")
  if(hemi == "S" && season_label == "JulAugSepOctNovDecJanFebMarAprMayJun") season_label <- "All"
  if(hemi == "N" && season_label == "JanFebMarAprMayJunJulAugSepOctNovDec") season_label <- "All"

  #for testing
  #print(tr)
  #print(prefn)
  #print(tmnfn)
  #print(tmxfn)

  #read climate files

  #northern hemisphere
  if(hemi == "N") {
    pre <- nc2raster(ncyear=year,ncvar="pre")
    tmn <- nc2raster(ncyear=year,ncvar="tmn")
    tmx <- nc2raster(ncyear=year,ncvar="tmx")
  }

  #souther hemisphere
  if(hemi == "S") {
    pre <- nc2rasterSH(ncyear=year,ncvar="pre")
    tmn <- nc2rasterSH(ncyear=year,ncvar="tmn")
    tmx <- nc2rasterSH(ncyear=year,ncvar="tmx")
  }

  #pdf(paste0("Data/pre",year,".pdf"))
  #plot(pre, ext = BRA.e)
  #dev.off()

  #project and crop bricks to extent we want for Brazil
  pre.b <- projectRaster(pre, munis.r)
  pre.b <- mask(x=pre.b, mask=munis.r)

  tmn.b <- projectRaster(tmn, munis.r)
  tmn.b <- mask(x=tmn.b, mask=munis.r)

  tmx.b <- projectRaster(tmx, munis.r)
  tmx.b <- mask(x=tmx.b, mask=munis.r)

  #caclulate average temperature by month (brick)
  avtemp.b <- 0.36*(3*tmx.b-tmn.b)

  #annual temp raster layer
  Ta<-mean(avtemp.b)

  #total pptn raster layer
  Pa<-sum(pre.b)

  #set params needed to calculate PET
  Days <- list(31,28,31,30,31,30,31,31,30,31,30,31) #list of days in the month
  Idex <- 12*((0.2*Ta)^1.514)#1st regional thermal index
  Adex <- 0.49239+1.7912*10^-2*Idex-7.71*10^-5*Idex^2+6.75*10^-7*Idex^3#2nd regional thermal index
  Ndex <- 12##NEED REAL VALUE

  #initialize PET with mean temperatures
  PET.b <- avtemp.b

  #function to calculate Potential Evapotranspiration (PET)
  calcPET <- function(PET, D, I, a, N)
  {
    #if mean temperature <= 0
    PET[PET<=0]<-0

    #if mean temperature > 26.5
    PET[PET>26.5]<-(-415.85+32.24*PET[PET>26.5]-0.43*(PET[PET>26.5]^2))*(N/12)*(D/30)

    #else
    PET[PET>0&PET<=26.5]<-0.0444*((10*(PET[PET>0&PET<=26.5]/I[PET[]>0&PET[]<=26.5]))^a[PET[]>0&PET[]<=26.5])*N*D

    return(PET)
  }

  #map2 to loop over raster brick (layer per month) and Days list (from purrr, see http://r4ds.had.co.nz/iteration.html)
  #brick needs to passed as a list (see https://geocompr.robinlovelace.net/location.html)
  PET.b <-
    map2(as.list(PET.b), Days, calcPET, I = Idex, a = Adex, N = Ndex) %>%
    stack()  #remember to re-stack the list after function

  names(PET.b) <- monlab

  #see Victoria et al. 2007 DOI: 10.1175/EI198.1 Table 2 for equations
  #initialise water storage variables

  Stoi <- PAW  #Stoii is month i-1 storage
  Stoii <- Stoi #Stoi is month i storage (in first month use same values)

  allmeanStoi <- vector("double", 12)  #vector to hold meanStoi for each month

  #for creating empty rasters and bricks
  nullRaster <- munis.r
  nullRaster[!is.na(nullRaster)] <- 0  #set anywhere that is not 'no data' in munis.r to 0

  DEF.b <- stack(replicate(12, nullRaster)) #empty brick to save all month's DEF
  ET.b <- stack(replicate(12, nullRaster))  #empty brick to save all month's ET

  DEF <- nullRaster #empty layer for temp useage in loop
  ET <- nullRaster #empty layer for temp useage in loop

  #par(mfrow=c(1,1))

  #see loopProofs (need to use loop, cannot use map)
  for(i in 1:12)
  {
    #hold current values of Stoi to set Stoii for next month below (this is why we can't use map)
    tempStoi <- Stoi

    P <- pre.b[[i]]    #get this month's precipitation (for clarity in equations below)
    PET <- PET.b[[i]]  #get this month's PET (for clarity in equations below)

    #if pptn < PET set storage
    Stoi[P<PET] <- Stoii[P<PET] * exp(P[P<PET] - PET[P<PET]/PAW[P<PET])

    #if pptn >= PET set storage
    Stoi[P>=PET] <- Stoii[P>=PET] + (P[P>=PET] - PET[P>=PET])

    #update Stoii ready for next month
    Stoii<-tempStoi

    #where Sto > PAW
    Stoi[Stoi[]>PAW[]] <- PAW[Stoi[]>PAW[]]

    #save mean Stoi value for this month
    allmeanStoi[i] <- cellStats(Stoi, "mean")

    #calculate delta storage
    trSto <- Stoi - Stoii

    #reset ET for this loop
    ET <- nullRaster

    #where pptn < PET
    ET[P<PET] <- P[P<PET] - trSto[P<PET]

    #where P >= PET
    ET[P>=PET] <- PET[P>=PET]

    #reset DEF for this loop
    DEF <- nullRaster

    #where pptn < PET
    DEF[P<PET] <- PET[P<PET] - ET[P<PET]

    #where P >= PET
    DEF[P>=PET]<-0

    #copy DEF to DEF brick
    DEF.b[[i]] <- DEF
    ET.b[[i]] <- ET

  }

  names(DEF.b) <- monlab    #apply month-year names to the layes (for plotting and access below)
  names(ET.b) <- monlab

  si_yr <- lapply(season, paste0, year)  #add the year to month names to match monlab format
  season_indices <- ifelse(monlab %in% si_yr,1,2)  #create index of months to use in stackApply below (1 is in season, 2 is not)

  #calculate Dryness Index
  #avDEF<-mean(DEF.b)#mean annual DEF
  avDEF <- stackApply(DEF.b, season_indices, mean)  #mean DEF (for specified months), #creates a stack of two layers (season months and non-season months)
  #avPET<-mean(PET.b)#mean annual PET
  avPET <- stackApply(PET.b, season_indices, mean)  #mean PET (for specified months), #creates a stack of two layers (season months and non-season months)

  avDi <- (100*avDEF) / avPET  #creates a stack of two layers (season months and non-season months)
  Di <- (100*DEF.b) / PET.b

  #pptn and temp by season if needed
  avPptn <- stackApply(pre.b, season_indices, mean)
  avTemp <- stackApply(avtemp.b, season_indices, mean)

  #Number of months with water deficit - helper function
  countWD <- function(vect, na.rm=T) { return(sum(vect > 5)) }

  #Number of months in the season - helper function
  countMonths <- function(vect, na.rm=T) { return(length(vect)) }

  #calculate various ways of defining water deficif months
  DEFmonths <- stackApply(DEF.b,season_indices, countWD)  #creates a stack of two layers (season months and non-season months)
  allmonths <- stackApply(DEF.b,season_indices, countMonths) #creates a stack of two layers (season months and non-season months)
  DEFmonths_prop <- DEFmonths / allmonths   #proportion,  #creates a stack of two layers (season months and non-season months)

  #Stoidiffc <- allmeanStoi[12] - allmeanStoi[1]  #this does not seem to be used elsewhere...
  #Stoidiffc

  #write data to files
  if(writeClimRast)
  {
    writeRaster(avDEF[["index_1"]], paste0(outputDir,"/",className,"/MeanDEF_",season_label,"_",year,hemi,".asc"), format = 'ascii', overwrite=T)
    writeRaster(avPET[["index_1"]], paste0(outputDir,"/",className,"/MeanPET_",season_label,"_",year,hemi,".asc"), format = 'ascii', overwrite=T)
    writeRaster(avTemp[["index_1"]], paste0(outputDir,"/",className,"/MeanTemp_",season_label,"_",year,hemi,".asc"), format = 'ascii', overwrite=T)
    writeRaster(avPptn[["index_1"]], paste0(outputDir,"/",className,"/MeanPrecip_",season_label,"_",year,hemi,".asc"), format = 'ascii', overwrite=T)
    writeRaster(avDi[["index_1"]], paste0(outputDir,"/",className,"/MeanDI_",season_label,"_",year,hemi,".asc"), format = 'ascii', overwrite=T)
    writeRaster(DEFmonths[["index_1"]], paste0(outputDir,"/",className,"/CountDEFmonths_",season_label,"_",year,hemi,".asc"), format = 'ascii', overwrite=T)
    writeRaster(DEFmonths_prop[["index_1"]], paste0(outputDir,"/",className,"/PropDEFmonths_",season_label,"_",year,hemi,".asc"), format = 'ascii', overwrite=T)
  }

  #write pdfs
  if(writeClimPdf)
  {

    pdf(paste0(outputDir,"/",className,"/DEF_",year,hemi,".pdf"))
    plot(DEF.b, ext = BRA.e)
    dev.off()

    pdf(paste0(outputDir,"/",className,"/PET_",year,hemi,".pdf"))
    plot(PET.b, ext = BRA.e)
    dev.off()

    pdf(paste0(outputDir,"/",className,"/ET_",year,hemi,".pdf"))
    plot(ET.b, ext = BRA.e)
    dev.off()

    pdf(paste0(outputDir,"/",className,"/PPTN_",year,hemi,".pdf"))
    plot(pre.b, ext = BRA.e)
    dev.off()

    pdf(paste0(outputDir,"/",className,"/DI_",year,hemi,".pdf"))
    plot(Di, ext = BRA.e)
    dev.off()

    pdf(paste0(outputDir,"/",className,"/ClimateVariables_",season_label,"_",year,hemi,".pdf"))
    #pdf(paste0(outputDir,"/",className,"/meanDEF_",season_label,"_",year,hemi,".pdf"))
    plot(avDEF[["index_1"]], ext = BRA.e, main=paste("meanDEF",season_label,year,hemi, sep=" "))  #need to use "index_1" to get to months labelled 1 in season_indices
    #dev.off()

    #pdf(paste0(outputDir,"/",className,"/meanPET_",season_label,"_",year,hemi,".pdf"))
    plot(avPET[["index_1"]], ext = BRA.e, main=paste("meanPET",season_label,year,hemi, sep=" "))  #need to use "index_1" to get to months labelled 1 in season_indices
    #dev.off()

    #pdf(paste0(outputDir,"/",className,"/meanDI_",season_label,"_",year,hemi,".pdf"))
    plot(avDi[["index_1"]], ext = BRA.e, main=paste("meanDI",season_label,year,hemi, sep=" "))  #need to use "index_1" to get to months labelled 1 in season_indices
    #dev.off()

    #pdf(paste0(outputDir,"/",className,"/DEFmonths_",season_label,"_",year,hemi,".pdf"))
    plot(DEFmonths[["index_1"]], ext = BRA.e, main=paste("count DEFmonths",season_label,year,hemi, sep=" "))
    #dev.off()

    #pdf(paste0(outputDir,"/",className,"/DEFmonths_prop_",season_label,"_",year,hemi,".pdf"))
    plot(DEFmonths_prop[["index_1"]], ext = BRA.e, main=paste("prop DEFmonths",season_label,year,hemi, sep=" "))
    dev.off()

  }

  #create the Moisture Capital Map
  MoistureCap <- (75 - avDi[["index_1"]]) / 75
  MoistureCap[MoistureCap[]<0]<-0

  if(GS) {
    GSCap <- MoistureCap
    GSCap[munis.r %/% 100000 == 42]<-0    #set SC state to 0
    GSCap[munis.r %/% 100000 == 43]<-0    #set RS state to 0

    pdf(paste0(outputDir,"/",className,"/GSCap_",season_label,"_",year,hemi,".pdf"))
    plot(GSCap, ext = BRA.e, main=paste("GSCap",season_label,year,hemi, sep=" "))  #need to use "index_1" to get to months labelled 1 in season_indices
    dev.off()

    writeRaster(GSCap, paste0(outputDir,"/",className,"/GSCap_",season_label,"_",hemi,"_",year,".asc"), format = 'ascii', overwrite=T)

  }

  if(!GS){

    writeRaster(MoistureCap, paste0(outputDir,"/",className,"/MoistureCap_",season_label,"_",hemi,"_",year,".asc"), format = 'ascii', overwrite=T)

    pdf(paste0(outputDir,"/",className,"/MoistureCap_",season_label,"_",year,hemi,".pdf"))
    plot(MoistureCap, ext = BRA.e, main=paste("MoistureCap",season_label,year,hemi, sep=" "))  #need to use "index_1" to get to months labelled 1 in season_indices
    dev.off()
  }

  rm(pre,tmn,tmx,pre.b,tmn.b,tmx.b,PET.b,DEF.b,ET.b)

}

outputDir <- "Data"
className <- "Moisture"

#crop_season <- c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")
#soy_season <- c("Oct","Nov","Dec","Jan","Feb","Mar")
mz1_season <- c("Oct","Nov","Dec","Jan","Feb","Mar")
mz2_season <- c("Jan","Feb","Mar","Apr","May","Jun")
crops <- list(mz1_season, mz2_season)

#create the output directory for this classification if it does not exist
if(!dir.exists(paste0(outputDir,"/",className))) { dir.create(paste0(outputDir,"/",className)) }

#yr <-2000
for(yr in 2001:2018)
{
  writeClimRast <- F
  writeClimPdf <- F
  calcMoistureMaps(munis.r, PAW, yr, BRA.ext, "S", mz1_season, GS = F)
  print(paste0(yr," done"))
}


######
# Generates predicted (counterfactual) time series of EB estimates for
# greylisted countries had they NOT been greylisted
# Uses GBM and public data for predictions
# Includes estimated std errors for OPE estimates of value of greylisting
######

library(gbm)
library(ggplot2)
library(reshape2)

##########################
# read in files + preprocess
##########################

# read in pre-processed public data file
X <- read.csv("../OtherData/Xall.csv", header = TRUE)

# remove row numbers (1st column)
X <- X[,-1]

# rename features & convert date to correct type
names(X) <- c("country", "date", paste("cases_minus", 1:20, sep=""), "cases_zero",
              paste("cases_plus", 1:19, sep=""), paste("deaths_minus", 1:20, sep=""),
              "deaths_zero", paste("deaths_plus", 1:19, sep=""), paste("tests_minus", 1:20, sep=""),
              "tests_zero", paste("tests_plus", 1:19, sep=""))
X$date <- as.Date(X$date, format = "%Y-%m-%d")

# identify countries as white/black
# note that all greylisted countries were white
ctry_white_list <- read.csv("https://raw.githubusercontent.com/ovelixasterix/greek_project/master/countries_allowed.csv", header = FALSE)
X$white <- as.integer(as.character(X$country) %in% ctry_white_list[,1])

# identify when countries were greylisted
grey_list_se <- read.csv("https://raw.githubusercontent.com/ovelixasterix/greek_project/master/grey_list_start_end.csv")
grey_list_se$start_date <- as.Date(grey_list_se$start_date, format = "%Y-%m-%d")
grey_list_se$end_date <- as.Date(grey_list_se$end_date, format = "%Y-%m-%d")
grey_list_se[is.na(grey_list_se$end_date),]$end_date <- as.Date("2022-01-01")
X$grey <- FALSE
for(i in 1:nrow(X)){
  ind <- which(grey_list_se$country == as.character(X$country)[i])
  if(length(ind) > 0){
    X$grey[i] <- as.logical(X$date[i] >= grey_list_se[ind,]$start_date &
                              X$date[i] <= grey_list_se[ind,]$end_date)
  }
}

# merge with OPE outputs file of private EB predictions
tmp <- read.csv("../OPE_outputs/hist_eb_timeseries_TRUE_Window_3_MinTest_30_SmoothPrior_TRUE_2001_0.9.csv")
tmp <- tmp[c("country", "eb_type", "date", "eb_prev")]
tmp$date <- as.Date(tmp$date, format = "%Y-%m-%d")
for(i in 1:nrow(grey_list_se)){
  # remove non-* version of EB type for greylisted period
  ind <- which(tmp$date >= grey_list_se[i,]$start_date & tmp$date <= grey_list_se[i,]$end_date
               & as.character(tmp$country) == grey_list_se[i,]$country
               & as.character(tmp$eb_type) == grey_list_se[i,]$country)
  if(length(ind) > 0) tmp <- tmp[-ind,]

  # remove * version of EB type for non-greylisted period
  ind <- which((tmp$date < grey_list_se[i,]$start_date | tmp$date > grey_list_se[i,]$end_date)
               & as.character(tmp$country) == grey_list_se[i,]$country
               & as.character(tmp$eb_type) == paste(grey_list_se[i,]$country, "*", sep=""))
  if(length(ind) > 0) tmp <- tmp[-ind,]
}

# merge with public data file
X2 <- merge(X, tmp, by=c("country", "date"))

X2$country <- as.factor(X2$country)
X2$eb_type <- NULL

##########################
# predict greylist counterfactual EB prevalence
##########################

# test set, convert date to a numeric since some start date
X_grey <- X2[X2$grey,]
X_grey$grey <- NULL
X_grey$date <- as.integer(X_grey$date - min(X2$date))

# train + validation set on non-grey
tmp <- X2[!X2$grey,]
tmp$grey <- NULL
tmp$date <- as.integer(tmp$date - min(X2$date))

# randomly split into train and validation set
n <- round(nrow(tmp)*.7)
ind <- sample(1:nrow(tmp))[1:n]
trainX <- tmp[ind, -which(names(tmp) %in% c("eb_prev"))]
trainy <- tmp[ind, "eb_prev"]
valX <- tmp[-ind, -which(names(tmp) %in% c("eb_prev"))]
valy <- tmp[-ind, "eb_prev"]

# fit GBM model on train and predict on validation set
fit <- gbm(trainy ~ ., data = trainX, distribution = "gaussian", n.trees = 500,
           bag.fraction = .75, cv.folds = 5, interaction.depth = 9)
pred_val <- predict(fit, newdata = valX)
summary(fit)

# get standard deviation of residuals on validation set
residuals <- pred_val-valy
hist(residuals)
sd_val <- sd(residuals)

# retrain on entire dataset (train + val)
fit <- gbm(c(trainy, valy) ~ ., data = rbind(trainX, valX), distribution = "gaussian", n.trees = 500,
           bag.fraction = .75, cv.folds = 5, interaction.depth = 9)

# test set predictions
pred_grey <- predict(fit, newdata = X_grey[,-which(names(X_grey) %in% c("eb_prev"))])
X_grey <- cbind(X_grey, "pred_prev" = pred_grey, "sd_prev" = sd_val)

# predict on past data
grey <- unique(as.character(X_grey$country))
dat <- X2[(as.character(X2$country) %in% grey) & !X2$grey,]
dat$date <- as.integer(dat$date - min(X2$date))
dat$pred_prev <- predict(fit, newdata = dat[,-which(names(dat) %in% c("grey", "eb_prev"))])
dat$sd_prev <- sd_val

# combine with test set
dat <- dat[,c("country", "date", "eb_prev", "pred_prev", "sd_prev")]
dat <- rbind(dat, X_grey[,c("country", "date", "eb_prev", "pred_prev", "sd_prev")])
dat$date <- as.Date(dat$date + min(X2$date))

# make sure predicted prevalence is non-negative
dat$pred_prev <- pmax(dat$pred_prev, 0)

# make sure counterfactual prevalence is above observed prevalence
# i.e., requiring negative-PCR pretest cannot increase prevalence
dat$pred_prev <- pmax(dat$pred_prev, dat$eb_prev)

write.csv(dat, "../OPE_outputs/grey_eb_preds.csv")


## First install the amcat-r package from github
#install.packages('devtools')
#library(devtools)
#install_github("amcat/amcat-r")

library(amcatr)
source('lda.r') # from amcat-r-tools folder

conn = amcat.connect('http://preview.amcat.nl') # AmCAT vraagt om je inloggegevens

project_id = 403
articleset_id = 10277 # 1083 english articles about the Rwandan genocide in The Guardian, NYT and The Toronto Star
tokens = amcat.gettokens(conn, project_id, articleset_id, page_size=10, module="corenlp_lemmatize")

dtm = amcat.dtm.create(tokens$aid, tokens$lemma, tokens$freq)

termstats = amcat.term.statistics(dtm)
termstats = termstats[termstats$termfreq > 2 & termstats$nonalpha == F,]
voca = as.character(termstats[order(termstats$tfidf, decreasing=T),][1:8000,'term'])
dtm = dtm[,voca]

m = amcat.lda.fit(dtm)
top.topic.words(m$topics)

## visualize topics
meta = amcat.getarticlemeta(conn, articleset_id)
m = amcat.lda.addMeta(m, meta)

## visualize topics
par(mar=c(5,3,3,3))
amcat.plot.lda.wordcloud(m, topic_nr=1)
amcat.plot.lda.time(m, topic_nr=1, date_interval='week') # default time variable is m$meta$date
amcat.plot.lda.category(m, 1) # default category variable is m$meta$medium
amcat.plot.lda.topic(m, 1)

# print topic plots for all topics
amcat.plot.lda(m, date_interval='day', path='/tmp/clouds/') ## set path to existing directory

## in progress
## Plot model fit for different values of K (takes a long time as it calculats a model for every value in k_values)
#source('lda_ktests.r')
#fit_scores = amcat.lda.find.best.K(dtm, k_values=seq(2,100,10))


# train an rf classifier for every timepoint clustering
rf.generate.classifiers <- function(otus, clusterings, percentage=0.8, kernel='linear'){

  # execute analysis per timepoint
  rfs <- lapply(clusterings, function(clustering){

    # filter otus with timepoint
    otus.of.timepoint <- otus.all.records.for.timepoints(otus, clustering$timepoint)

    # normalize otus
    otus.normalized <- otus.normalize(otus.of.timepoint, 0)

    # train a classifier for every timepoint
    rf.classifier <- rf.train.classifier(otus.normalized, clustering$best.clustering_by_ch, percentage, kernel)

    result <- list('timepoint' = clustering$timepoint, 'rf' = rf.classifier)

    return(result)
  })

  return(rfs)
}

rf.train.classifier <- function(data, classification, percentage, kernel){

  # if a timepoing has (n) clusters this list contains (n) classfication values
  unique.classification.values <- unique(classification)

  # initiate training and validation data sets
  training.data.set <- array(dim=c(0,ncol(data)))
  training.classification.set <- array(dim=c(0,ncol(data)))
  validation.data.set <- array(dim=c(0,ncol(data)))
  validation.classification.set <- array(dim=c(0,ncol(data)))

  training.stats <- ''
  training.stats <- paste(training.stats, nrow(data), sep = '')
  training.stats <- paste(training.stats, ':', sep = '')

  # for every classification value create separate training and validation sets
  # Merge them all togenter and then train the random forests
  for(classification.value in unique.classification.values){

    classification.value.index <- as.vector(which(classification == classification.value))

    nrOfTrainingSamples <- round(percentage * length(classification.value.index), 0L)

    training.stats <- paste(training.stats, '[', sep = '')
    training.stats <- paste(training.stats, classification.value, sep = '')
    training.stats <- paste(training.stats, ':', sep = '')

    if (nrOfTrainingSamples == 1){
      training.indeces <- classification.value.index
      validation.indeces <- classification.value.index
    }
    else{
      training.indeces <- sample(classification.value.index, nrOfTrainingSamples, replace = F)
      validation.indeces <- setdiff(classification.value.index, training.indeces)
    }

    training.stats <- paste(training.stats, toString(length(training.indeces)), sep = '')
    training.stats <- paste(training.stats, '-', sep = '')
    training.stats <- paste(training.stats, toString(length(validation.indeces)), sep = '')

    training.data.set.for.specific.value <- data[training.indeces,]
    training.classification.set.for.specific.value <- classification[training.indeces]

    validation.data.set.for.specific.value <- data[validation.indeces,]
    validation.classification.set.for.specific.value <- classification[validation.indeces]

    training.data.set <- rbind(training.data.set, training.data.set.for.specific.value)
    training.classification.set <- c(training.classification.set, training.classification.set.for.specific.value)

    validation.data.set <- rbind(validation.data.set, validation.data.set.for.specific.value)
    validation.classification.set <- c(validation.classification.set, validation.classification.set.for.specific.value)

    training.stats <- paste(training.stats, ']', sep = '')
  }

  # train random forest
  classifier <- randomForest(x=training.data.set,
                             y=as.factor(training.classification.set),
                             ntree = 1, mtry = ncol(data), importance = T)

  # validate training
  prediction.on.validation.set <- rf.predict(classifier, validation.data.set)

  confusion.matrix <- table(prediction.on.validation.set, validation.classification.set)

  result <- list('classifier' = classifier,
                 'training.stats' = training.stats,
                 'confusion.matrix'= confusion.matrix)

  return(result)
}

rf.predict <- function(classifier, data){
  prediction <- predict(classifier, data, type='class')
  return(prediction)
}


library(ggplot2)
library(extrafont)
args=commandArgs(trailingOnly = TRUE)

outbase="STEMBits"
tstring=gsub(" .*$","",Sys.time(),perl=TRUE)

pwmtab= args[1]
ditab=args[2]

pwm=read.table(pwmtab,sep = "\t")
di=read.table(ditab,sep = "\t")
diname=di$V1
ndiname=gsub(".di.pfm","_short.pfm",diname)
#ndipre=cbind(di,ndiname)
di$V1=ndiname

overalloutname=paste(outbase,"_overall_",tstring,".pdf",sep="")
perbaseoutname=paste(outbase,"_perbase_",tstring,".pdf",sep="")
distem=subset(di,V3=="STEM")
pwmstem=subset(pwm,V3=="STEM")

#dimean=aggregate(distem$V2,by=list(distem$V1),FUN=mean)
#pwmmean=aggregate(pwmstem$V2,by=list(pwmstem$V1),FUN=mean)
#colnames(dimean)=c("motif","Di")
#colnames(pwmmean)=c("motif","Mono")
colnames(distem)=c("motif","Di","Tag")
colnames(pwmstem)=c("motif","Mono","Tag")
allstem=merge(distem,pwmstem,by="motif")
q=ggplot(allstem,aes(Mono,Di/2)) +geom_point(col="royalblue",alpha=0.5,size=2)+scale_fill_brewer(palette="Pastel1")+scale_y_continuous("Di")+scale_x_continuous("Mono")+ggtitle("Perbase IC of stem in Mono & Di matrix")+
  theme(panel.background=element_blank(),axis.line.x=element_line(size=1,color="grey",linetype="solid"),axis.line.y=element_line(size=1,color="grey",linetype="solid"),legend.position=c(0.5,0.95),legend.direction="horizontal",legend.title=element_blank(),legend.background=element_blank(),plot.title=element_text(size=14,hjust = 0.5),axis.text=element_text(size=12),axis.title=element_text(size=14),legend.text=element_text(size=12),text = element_text(family = "Arial Narrow"))

ggsave(filename = perbaseoutname,width = 10,height =10,units = "cm",plot = q,useDingbats=FALSE)

# the overall
dnn=distem$motif
mnn=pwmstem$motif
distem$motif=gsub("pfm.*","pfm",dnn)
pwmstem$motif=gsub("pfm.*","pfm",mnn)
disum=aggregate(distem$Di,by=list(distem$motif),FUN=sum)
pwmsum=aggregate(pwmstem$Mono,by=list(pwmstem$motif),FUN=sum)
colnames(disum)=c("motif","Di")
colnames(pwmsum)=c("motif","Mono")
allsum=merge(disum,pwmsum,by="motif")
p=ggplot(allsum,aes(Mono,Di/2)) +geom_point(col="blue",alpha=0.5,size=2)+scale_x_continuous(limits=c(0,8))+scale_y_continuous("Di",limits=c(0,8))+ggtitle("Overall IC of stem in Mono & Di matrix")+
  theme(panel.background=element_blank(),axis.line.x=element_line(size=1,color="grey",linetype="solid"),axis.line.y=element_line(size=1,color="grey",linetype="solid"),legend.position=c(0.5,0.95),legend.direction="horizontal",legend.title=element_blank(),legend.background=element_blank(),plot.title=element_text(size=14,hjust = 0.5),axis.text=element_text(size=12),axis.title=element_text(size=14),legend.text=element_text(size=12),text = element_text(family = "Arial Narrow"))
ggsave(filename = overalloutname,width = 10,height =10,units = "cm",plot = p,useDingbats=FALSE)

overallIncreaseBits=mean(allsum$Di -allsum$Mono)
write.table(overallIncreaseBits,file=paste("OverallIncreasedBits",tstring,".txt",sep = ""),col.names = F,row.names = F,quote = F)


#' Compute relative distances between intervals.
#'
#' @param x [tbl_interval()]
#' @param y [tbl_interval()]
#' @param detail report relative distances for each `x` interval.
#'
#' @family interval statistics
#'
#' @return
#' If `detail = FALSE`, a [tbl_interval()] that summarizes
#' calculated `.reldist` values with the following columns:
#'
#'   - `.reldist` relative distance metric
#'   - `.counts` number of metric observations
#'   - `.total` total observations
#'   - `.freq` frequency of observation
#'
#' If `detail = TRUE`, the `.reldist` column reports the relative
#' distance for each input `x` interval.
#'
#' @template stats
#'
#' @seealso \url{http://bedtools.readthedocs.io/en/latest/content/tools/reldist.html}
#'
#' @examples
#' genome <- read_genome(valr_example('hg19.chrom.sizes.gz'))
#'
#' x <- bed_random(genome, seed = 1010486)
#' y <- bed_random(genome, seed = 9203911)
#'
#' bed_reldist(x, y)
#'
#' bed_reldist(x, y, detail = TRUE)
#'
#' @export
bed_reldist <- function(x, y, detail = FALSE) {
  if (!is.tbl_interval(x)) x <- as.tbl_interval(x)
  if (!is.tbl_interval(y)) y <- as.tbl_interval(y)

  x <- group_by(x, chrom, add = TRUE)
  y <- group_by(y, chrom, add = TRUE)

  if (utils::packageVersion("dplyr") < "0.7.99.9000"){
    x <- update_groups(x)
    y <- update_groups(y)
  }

  grp_indexes <- shared_group_indexes(x, y)

  res <- dist_impl(x, y,
                   grp_indexes$x,
                   grp_indexes$y,
                   distcalc = "reldist")

  if (detail) return(res)

  res[[".reldist"]] <- floor(res[[".reldist"]] * 100) / 100
  nr <- nrow(res)
  res <- group_by(res, .reldist)
  res <- summarize(
    res,
    .counts = n(),
    .total = nr,
    .freq = .counts / .total
  )
  res
}


res <- read.table('../original_results/section_v_e_anytime_problem7_results.csv', header=TRUE, sep=',')

min_obj = min(min(res$qos, res$freecycles))
max_obj = max(max(res$qos, res$freecycles))

xlimits = c(min(res$timeout), max(res$timeout))
ylimits = c(min_obj, max_obj)

pdf('problem7.pdf')
fs = 1.5
fs_leg = 1.25

plot(res$timeout[res$method=="minizinc"], res$qos[res$method=="minizinc"],
	xlim=xlimits,ylim=ylimits, type='b', pch='+', xlab='Time (s)', ylab='Normalised Objective Value',
	cex.lab=fs, cex.axis=fs, cex.main=fs, cex.sub=fs)
#, main='Problem 7: Anytime Algorithms')
lines(res$timeout[res$method=="minizinc"], res$freecycles[res$method=="minizinc"], pch='+', type='b', lty=2)

lines(res$timeout[res$method=="local"], res$qos[res$method=="local"], type='b', pch='o')
lines(res$timeout[res$method=="local"], res$freecycles[res$method=="local"], type='b', pch='o', lty=2)

x_pos = max(res$timeout) * 0.6
y_pos = max_obj * 0.75

legend(legend=c('Minizinc QoS', 'MiniZinc Util', 'Local Search QoS', 'Local Search Util'),
	x=x_pos, y=y_pos, lty=c(1,2,1,2), pch=c('+','+','o','o'), cex=fs_leg)

dev.off()


#----------------------------------------------------------------------------#
#' @title ticks number control
#' @description ticks number control for ggplot
#' @param n	number of ticks
#' @examples "scale_x_continuous(break = n.ticks(20))"
#' @export
n_ticks = function (n) {function(limits) pretty(limits, n)}


#'---
#'title: "2.1 MRI, fMRI and MEG"
#'author: "Denis A. Engemann"
#'date: "8/6/2019"
#'output:
#'    html_document:
#'        code_folding:
#'            hide
#'    md_document:
#'        variant:
#'            markdown_github
#'---

# seed!
set.seed(42)

#+ config
library(ggplot2)
library(ggbeeswarm)
library(ggrepel)

# imports `color_cats` and `get_label_from_marker`
source('./utils.r')
source('./config.r')

PREDICTIONS <- './data/age_stacked_predictions_megglobal.csv'
PREDICTIONS2 <- './data/age_stacked_predictions__na_coded.csv'
PREDICTIONS3 <- './data/age_stacked_predictions_meglocal.csv'

DUMMY <- './data/age_stacked_dummy.csv'
SCORES <- './data/age_stacked_scores_megglobal.csv'

data_dummy <- read.csv(DUMMY)
data_dummy$MAE <- -data_dummy$MAE

data_pred_wide <- read.csv(PREDICTIONS)
data_scores_wide <- read.csv(SCORES)

# for chance-level predictiong and differences between methods

# fix column names and add dummy

names(data_scores_wide) <- fix_column_names(names(data_scores_wide))
data_scores_wide$chance <- data_dummy$MAE

#'Preprocess data.

#'r data
stacked_keys <- c(
  "MEG_handcrafted",
  "MEG_powers",
  "MEG_powers_cross_powers",
  "MEG_powers_cross_powers_handrafted",
  "MEG_cat_powers_cross_powers_correlation",
  "MEG_cat_powers_cross_powers_correlation_handcrafted",
  "MEG_cross_powers_correlation",
  "MEG_powers_cross_powers_correlation",
  "MEG_all",
  "ALL",
  "ALL_no_fMRI",
  "MRI",
  "ALL_MRI",
  "fMRI",
  "chance"
)

#' Let's first first get an overview on all models

base_line_sel <- c(
 "ALL", "ALL_no_fMRI",  "ALL_MRI", "MRI", "fMRI",  "MEG_all", "chance")

data_all_scores <- data_scores_wide[,base_line_sel]
names(data_all_scores) <- c('Multimodal', 'MRI & MEG', 'MRI & MRI', "MRI", 'fMRI', "MEG", "Chance")

#' Now let's investigate difference from chance baseline

summarize_table <- function(data){
    data <- rbind(
      apply(data, FUN = mean, 2),
      apply(data, FUN = sd, 2),
      apply(data, FUN = function(x) quantile(x, c(0.025, 0.975)), 2)
    )

    rownames(data) <- c("M", "SD", rownames(data)[c(3, 4)])
    data <- round(t(data), 3)
    data <- data.frame(model = rownames(data), data)
    rownames(data) <- NULL
    return(data)
}

data_all_summary <- summarize_table(data_all_scores)

knitr:::kable(data_all_summary)

write.csv(
  data.frame(
  stat = rownames(data_all_summary), data_all_summary),
  './viz_intermediate_files/all_scores_summary.csv'
)

data_dummy_diff <- data_all_scores - data_all_scores$Chance

data_dummy_diff_summary <- summarize_table(data_dummy_diff)

data_dummy_diff_summary$Pr <- t(t(apply(data_dummy_diff, FUN = function(x) sum(x < 0), 2)))

knitr:::kable(data_dummy_diff_summary)

write.csv(
  data.frame(
  stat = rownames(data_dummy_diff_summary), data_dummy_diff_summary),
  './viz_intermediate_files/all_scores_dummy_diff_summary.csv'
)

data_mri_diff <- data_all_scores - data_all_scores$MRI

data_mri_diff_summary <- summarize_table(data_mri_diff)

data_mri_diff_summary$Pr <- t(t(apply(data_mri_diff, FUN = function(x) sum(x < 0), 2)))

knitr:::kable(data_mri_diff_summary)

write.csv(
  data.frame(
  stat = rownames(data_mri_diff_summary), data_mri_diff_summary),
  './viz_intermediate_files/all_scores_mri_diff_summary.csv'
)

# XXX idea, rank statistics
model_ranking <- do.call(
  rbind,
  lapply(seq_along(data_all_scores[,1]),
         function(ii) {
          out <- data.frame(
            rank = rank(data_all_scores[ii,]),
            model = names(data_all_scores),
            fold = ii)
          rownames(out) <- NULL
          return(out)
        }))

model_ranking$model <- factor(
  model_ranking$model,
  levels = rev(c("Chance", "fMRI", "MEG", "MRI", "MRI & MEG",
                 "MRI & MRI", "Multimodal")),
  labels = rev(c(
    "Chance", "fMRI", "MEG", "MRI", "MRI, MEG", "MRI, fMRI",
    "MRI, fMRI, MEG")))

colors_multimodal <- setNames(
  with(color_cats, c(black, orange, `blueish green`, blue, violet, vermillon, gray)),
  c("MRI, fMRI, MEG", 'MRI, fMRI', 'MRI, MEG', 'MRI', 'fMRI', 'MEG', 'Chance'))

fig_rank_box <- ggplot(data = model_ranking,
       mapping = aes(x = rank, y = reorder(model, rank, mean), color = model, fill = model)) +
geom_boxplot(show.legend = F, alpha = 0.3) +
geom_jitter(show.legend = F, size=1.5, width = 0.12, alpha=0.5) +
scale_x_continuous(breaks = 1:7) +
scale_color_manual(values = colors_multimodal,
                   labels = names(colors_multimodal),
                   breaks = names(colors_multimodal)) +
scale_fill_manual(values = colors_multimodal,
                  labels = names(colors_multimodal),
                  breaks = names(colors_multimodal)) +
labs(x = 'Ranking across CV testing-splits', y = 'Stacking Models')
print(fig_rank_box)

fname <- "./figures/elements_fig2_stacking_mri_meg_supp_rank_box."
ggsave(paste0(fname, "pdf"),
       width = save_width, height = save_height, useDingbats = F)
embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
ggsave(paste0(fname, "png"),
       width = save_width, height = save_height, dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

##
# explore rank stats
rankmat <- data.frame(
  do.call(
    cbind,
    with(model_ranking,
      by(model_ranking, model, function(x) x$rank))))
rankmat$n <- 1
rank_ds <- destat(rankmat)
rownames(rank_ds$pair) <- names(rankmat)[-ncol(rankmat)]
colnames(rank_ds$pair) <- names(rankmat)[-ncol(rankmat)]
rownames(rank_ds$mar) <- names(rankmat)[-ncol(rankmat)]
colnames(rank_ds$mar) <- names(rankmat)[-ncol(rankmat)]

print(rank_ds$pair)
print(rank_ds$mar)

get_mat <- function(mat) {
  mat <- data.frame(mat)
  colnames(mat) <- levels(model_ranking$model)
  rownames(mat) <- levels(model_ranking$model)

  mat_long <- do.call(rbind, lapply(colnames(mat), function(x) {
    data.frame(count = mat[, x], x = x, y = rownames(mat))
  }))
  mat_long$x <- factor(mat_long$x, levels = colnames(mat))
  mat_long$y <- factor(mat_long$y, levels = colnames(mat))
  mat_long
}

fig_rank_mat_pair <- ggplot(data = get_mat(rank_ds$pair),
                            mapping = aes(x = x, y = y, fill = count, label = count)) +
  geom_tile() +
  scale_fill_viridis_c(begin = 0.01, end = 0.99) +
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
  geom_text(color = 'white', size = 8) +
  labs(x = element_blank(), y = element_blank())
print(fig_rank_mat_pair)

fname <- "./figures/elements_fig2_stacking_mri_meg_supp_rank_mat_pair."
ggsave(paste0(fname, "pdf"),
       width = save_width, height = save_height, useDingbats = F)
embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
ggsave(paste0(fname, "png"),
       width = save_width, height = save_height, dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

#' Now we can investigate the differences between models in depth.
reshape_sel <- names(data_scores_wide)[!names(data_scores_wide) %in% c(
  'repeat_', 'repeat_idx', 'age')]

data_scores <- reshape(data = data_scores_wide,
                       direction = 'long',
                       varying = reshape_sel,
                       v.names = 'MAE',
                       timevar = 'marker',
                       times = reshape_sel)

data_scores['modality'] <- 'MEG'
data_scores[grepl('MEG_', data_scores$marker),]['modality'] <- 'MEG'
data_scores[grepl('Connectivity_Matrix',
                  data_scores$marker),]['modality'] <- 'fMRI'
data_scores[grepl('ALL', data_scores$marker),]['modality'] <- 'Multimodal'
data_scores[grepl('chance', data_scores$marker),]['modality'] <- 'Chance'

data_scores$marker <- sub("stacked_", "", data_scores$marker)
data_scores$prediction <- factor(ifelse(
  data_scores$marker %in% stacked_keys, 'stacked', 'linear'))
data_scores$marker <- factor(data_scores$marker)

#'Select stacked data.

#+r stacked_data
data_stacked <- subset(data_scores, prediction == 'stacked')

stacked_selection <- c(
  "ALL",
  "ALL_MRI",
  "ALL_no_fMRI",
  "MRI",
  "chance"
)

data_stacked_sel <- within(
    data_stacked[data_stacked$marker %in% stacked_selection,],
    {
      family <- rep('Multimodal', length(marker))
      family[marker == 'ALL_MRI'] <- 'MRI & fMRI'
      family[marker == 'ALL_no_fMRI'] <- 'MRI & MEG'
      family[marker == 'MRI'] <- 'MRI'
      family[marker == 'chance'] <- 'Chance'
      family <- factor(family)
    }
)

#'Plot error distibution.
#+ fig2a
colors <- setNames(
  with(color_cats, c(black, orange, `blueish green`, blue, gray)),
  c('Multimodal', 'MRI & fMRI', 'MRI & MEG', 'MRI', "Chance"))

sort_idx <- order(aggregate(MAE ~ marker,
                            data = data_stacked_sel, FUN = mean)$MAE)
data_stacked_sel$cv_idx <- rep(rep(1:10, times = 10), length(colors))

set_na_chance <- function(data){
  data$is_chance <- F

  data <- rbind(
    data,
    within(data, {
      is_chance <- T
      MAE[family !=  "Chance"] <- NA})
  )

  data[
    (data$is_chance == F &
     data$family == "Chance"),]$MAE <- NA
  return(data)
}

sort_idx <- order(
      aggregate(MAE~marker, data = data_stacked_sel, FUN = mean)$MAE)

data_stacked_sel$marker <- factor(
  data_stacked_sel$marker,
  levels(factor(data_stacked_sel$marker))[sort_idx])

data_stacked_sel <- subset(data_stacked_sel, family != "Chance")

mri_mean <- aggregate(MAE ~ family, data_stacked_sel, mean)[1, 2]

#'Now let us look at the difference from baseline.

#+ fig2b
# The power of R ... do multi-line assignment expressions inside data frame
# environment and return updated data.frame

data_diff <- within(subset(data_stacked_sel, family != "Chance"),
    {
      MAE_diff <- c(MAE[family == 'Multimodal'] - MAE[family == 'MRI'],
                    MAE[family == 'MRI & MEG'] - MAE[family == 'MRI'],
                    mri_mean - MAE[family == 'MRI'],
                    MAE[family == 'MRI & fMRI'] - MAE[family == 'MRI'])
      family <- factor(gsub("Multimodal", "Fully multimodal", family))
    }
)

legend_name <- "Improvement over anatomical MRI"
colors_fig2b <- setNames(
  with(color_cats,
       c(black, orange, `blueish green`, blue)),
  c("MRI, fMRI, MEG", 'MRI, fMRI', 'MRI, MEG', 'MRI'))

sort_idx <- order(aggregate(MAE_diff ~ family, data_diff, mean)$MAE_diff)

levels(data_diff$family) <- c("MRI, fMRI, MEG", "MRI", "MRI, fMRI", "MRI, MEG")

fig2b <- ggplot(
  data = data_diff,
  mapping = aes(y = MAE_diff,
                x = reorder(family, MAE_diff, function(x) mean(x)),
                color = family, fill = family)) +
  coord_flip(ylim = c(-2.9, 1.7)) +
  stat_summary(geom = "boxplot", fun.data = my_quantiles,
               alpha = 0.5, size = 0.7, width = 0.8) +
  stat_summary(geom = "errorbar", fun.data = my_quantiles,
               alpha = 0.5, size = 0.7, width = 0.5) +
  stat_summary(geom = 'text',
               mapping = aes(label  = sprintf("%1.1f",
                                              ..y.. +
                                              mri_mean)),
               fun.y= mean, size = 3.2, show.legend = FALSE,
               position = position_nudge(x=-0.49)) +
  geom_beeswarm(alpha=0.3, show.legend = F, size = 3) +
  geom_hline(yintercept = 0, linetype = 'dashed') +
  guides(color = guide_legend(nrow = 3, title.position = "top")) +
  ylab("MAE difference (years)") +
  xlab("Multimodal stacking") +
  scale_color_manual(values = colors_fig2b,
                     labels = names(colors_fig2b),
                     breaks = names(colors_fig2b),
                     name = legend_name) +
  scale_fill_manual(values = colors_fig2b,
                    labels = names(colors_fig2b),
                    breaks = names(colors_fig2b),
                    name = legend_name) +
  guides(color = guide_legend(nrow = 1, title.position = 'top'),
         fill = guide_legend(nrow = 1)) +
  scale_y_continuous(breaks = seq(-3, 1.5, 0.5)) +
  theme(axis.text.y = element_blank(),
        legend.position = 'top',
        legend.justification = 'left',
        legend.text.align = 0)
print(fig2b)

fname <- "./figures/elements_fig2_stacking_mri_meg_diff."
ggsave(paste0(fname,  "pdf"),
       width = save_width, height = save_height, useDingbats = F)
embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
ggsave(paste0(fname,  "png"), width = save_width, height = save_height,
       dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

#'Let's investigate the interaction between the MEG and MRI.
#'For this we will have to extract the raw prediction errors.
#'
#'We will first prepare a subset of data that allows us to
#'compare MEG and fRMI.

#+ data_wide
stacked_selection2 <- c(stacked_selection, "fMRI", "MEG_all")
data_pred_stacked_sel <- preprocess_prediction_data(
  df_wide = data_pred_wide, stack_sel = stacked_selection2, drop_na = T)

#'Now we can package the data for plotting.

#+ data_diff
data_pred_stacked_comp <- rbind(
  data.frame(
    MAE_meg = subset(data_pred_stacked_sel, family == 'MEG')$MAE,
    MAE_fmri = subset(data_pred_stacked_sel, family == 'fMRI')$MAE,
    combined = F),
   data.frame(
    MAE_meg = subset(data_pred_stacked_sel, family == 'MRI & MEG')$MAE,
    MAE_fmri = subset(data_pred_stacked_sel, family == 'MRI & fMRI')$MAE,
    combined = T)
)

data_pred_stacked_comp <- cbind(
  data_pred_stacked_comp,
  rbind(subset(data_pred_stacked_sel, family == 'MEG', select = -c(MAE)),
        subset(data_pred_stacked_sel, family == 'MEG', select = -c(MAE))))

data_pred_stacked_comp$combined <- factor(
  ifelse(data_pred_stacked_comp$combined, "MRI[anat.]~added", "no~MRI[anat.]"),
  levels = c("no~MRI[anat.]", "MRI[anat.]~added"))

#'Now we can plot it.
data_corr_agg <- aggregate(
    cbind(MAE_fmri, MAE_meg, age) ~ X*combined,
    data = data_pred_stacked_comp, FUN = mean)

cor1 <- with(subset(data_corr_agg, combined != "MRI[anat.]~added"),
             cor.test(MAE_meg, MAE_fmri,  method = "spearman"))
cor2 <- with(subset(data_corr_agg, combined == "MRI[anat.]~added"),
             cor.test(MAE_meg, MAE_fmri,  method = "spearman"))

cor.details <- data.frame(
  p.value = c(sprintf("%e", cor1$p.value),
              ifelse(cor2$p.value == 0, "2.2e-16", sprintf("%e", cor2$p.value))),
  r2 = round(c(cor1$estimate, cor2$estimate) ^ 2, 3),
  rho = round(c(cor1$estimate, cor2$estimate), 3),
  mri = c(F, T)
)

write.csv(cor.details, './viz_intermediate_files/correlation_meg_mri.csv')

# annotation <- data.frame(
#    x = c(2,4.5),
#    y = c(20,25),
#    label = c("label 1", "label 2")
# )

#+ fig2c
fig2c <- ggplot(
  data = data_corr_agg,
  mapping = aes(x = MAE_fmri, y =  MAE_meg, size = age, color = age)) +
  geom_point(alpha = 0.8) +
  scale_size_continuous(range = c(0.01, 3),
                        trans = 'sqrt') +
  ylab(expression(MAE[MEG] ~ (years))) +
  xlab(expression(MAE[fMRI] ~ (years))) +
  facet_wrap(~combined, labeller = label_parsed) +
  scale_color_viridis_c() +
  theme(legend.position = 'top',
        legend.justification = 'left',
        legend.text.align = 0) +
  guides(
        color = guide_legend(title.position = "left"),
        size = guide_legend(title.position = "left")) +
  coord_fixed(ylim = c(0, 30.5), xlim = c(0, 30.5)) +
  labs(color = "age", shape = "age")
print(fig2c)

fname <- "./figures/elements_fig2_supplement_mri_meg_scatter."
ggsave(paste0(fname, "pdf"), plot = fig2c,
       width = save_width, height = save_height, useDingbats = F)
embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
ggsave(paste0(fname, "png"), plot = fig2c,
        width = save_width, height = save_height,
       dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

#'One can see that a) the MEG and MRI errors are not
#'strongly related b) comabining each of them with MRI
#'Makes the error somewhat more similar, especially in old
#'people, yet leaves them rather  uncorrelated.
#'

#'Let us now plot the error by age group and modality.

#+ error_by_age
# make qualitative ordered age group

colors_fig2e <- setNames(
  with(color_cats, c(black, orange, `blueish green`, blue, violet, vermillon)),
  c("MRI, fMRI, MEG", 'MRI, fMRI', 'MRI, MEG', 'MRI', 'fMRI', 'MEG'))

data_pred_stacked_sel$age_group <- cut(data_pred_stacked_sel$age, breaks = seq(15, 90, 5))
data_pred_stacked_sel$family <- factor(
  data_pred_stacked_sel$family,
  levels = c("MRI", "fMRI", "MEG", "MRI & fMRI", "MRI & MEG", "Multimodal"),
  labels = c("MRI", "fMRI", "MEG", "MRI, fMRI", "MRI, MEG", "MRI, fMRI, MEG"))

names(data_pred_stacked_sel) <- c("subject", names(data_pred_stacked_sel)[-1])

data_pred_stacked_sel_agg <- aggregate(
    cbind(MAE, age) ~ subject*family, data = data_pred_stacked_sel, FUN = mean)

data_pred_stacked_sel_agg$age_group <- cut_number(data_pred_stacked_sel_agg$age, 7)

(anomod <- summary(aov(log(MAE) ~ age_group * family,
                  data = data_pred_stacked_sel_agg)))

writeLines(capture.output(anomod),
           "./viz_intermediate_files/anova_stacking_error.txt")

fig2d <- ggplot(data = data_pred_stacked_sel,
                mapping = aes(x = age, y = MAE
                              # size = MAE,
                              # color = family,
                              # fill = family
                            )) +
  facet_wrap(.~family, scales = 'free_x') +

  # geom_jitter(shape=21, fill='white', show.legend = F, alpha=0.5) +

  geom_hex(mapping =  aes(x = age, y = MAE),
           show.legend = T, size = 0.1, bins = 15) +
  stat_smooth(size = 1.2, show.legend = F,
              method = loess,
              color='red',
              method.args = list(degree = 2),
              fill = NA, level = .9999) +
  scale_fill_continuous(type = "viridis") +
  theme(strip.text.y = element_text(angle = 0),
        panel.spacing.x = unit(0.05, 'in')) +
  xlab("Age (years)") +
  ylab("MAE (years)")
  # facet_wrap(~family, ncol = 3)
print(fig2d)

fname <- "./figures/elements_fig2_error_by_age_group."
ggsave(paste0(fname, "pdf"), plot = fig2d,
       width = save_width, height = save_height, useDingbats = F)
ggsave(paste0(fname, "png"), plot = fig2d,
        width = save_width, height = save_height,
       dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

#' We see, what we knew before that, stacking helps improve the error
#' However, we see that this is probably due to at least two mechanisms.
#' 1) extreme error is unifomely reduced. 2) Error in young and old groups
#' is mitigated. However, we also learn that the best model still shows
#' considerable brain age bias, with young and old subjects systematically
#' suffering from more error.

#' Time to investigate the 2D dependence. To select the right variables,

#' We can see from the printed outputs that MEG power always makes it under
#' the top markers. Thus, it makes sense to focus on power in a 2D dependence
#' analysis.

OUT_DEPENDENCE_2D <- './data/age_stacked_dependence_model-full-2d.csv'
data_dependence2d <- read.csv(OUT_DEPENDENCE_2D)
data_dependence2d$marker <- fix_marker_names(data_dependence2d$marker)
data_dependence2d$var_x <- fix_marker_names(data_dependence2d$var_x)
data_dependence2d$var_y <- fix_marker_names(data_dependence2d$var_y)
data_dependence2d$model <- gsub(" ", "_", data_dependence2d$model)

pdp2dmap <- list(
  "ALL" = list(
    cases = c(
      "Connectivity_Matrix,_MODL_256_tan--power_diag",
      "Cortical_Thickness--Connectivity_Matrix,_MODL_256_tan",
      "Cortical_Thickness--power_diag",
      "Cortical_Thickness--Subcortical_Volumes",
      "Subcortical_Volumes--Connectivity_Matrix,_MODL_256_tan",
      "Subcortical_Volumes--power_diag"),
    labels = c(
      "fMRI-P[cat]",
      "CrtT-fMRI",
      "CrtT-P[cat]",
      "CrtT-SbcV",
      "SbcV-fMRI",
      "SbcV-P[cat]")
  )
)

print(nrow(data_dependence2d))
print(unique(data_dependence2d$model))
models <- c("ALL")
for (i_model in seq_along(models)){
  this_model <- models[[i_model]]
  print(this_model)
  this_data <- subset(data_dependence2d,
                      model == this_model & model_type == 'rf_msqrt')

  #  make nicer marker labels for titles.
  this_data$marker_label <- this_data$marker
  for (i_case in seq_along(pdp2dmap[[this_model]][['cases']])) {
    this_data$marker_label <- gsub(
      pdp2dmap[[this_model]][['cases']][i_case],
      pdp2dmap[[this_model]][['labels']][i_case],
      this_data$marker_label)
  }

  marker_split <- strsplit(this_data$marker_label, '-')
  this_data$marker_label_x <- sapply(marker_split, `[[`, 1)
  this_data$marker_label_y <- sapply(marker_split, `[[`, 2)

  if(this_model == "ALL_MRI"){
    this_breaks <- seq(30, 80, 4)
  }else{
    this_breaks <- seq(46, 62, 2)
  }

  fig2e <- ggplot(data = this_data,
                  mapping = aes(x = x, y = y, z = pred)) +
      geom_raster(aes(fill = pred), show.legend = T) +
      stat_contour(breaks = this_breaks,
                  color = "white", bins = 7, show.legend = F) +
      scale_fill_viridis_c(breaks = this_breaks,
                          name = expression(hat(y)),
                          guide = guide_colorbar(barheight = 10)) +
      theme(panel.grid.major = element_blank(),
            panel.grid.minor = element_blank()) +
      facet_wrap(marker_label_x ~ marker_label_y,
                scales = "free",
                labeller = function(x) label_parsed(x, multi_line = F)) +
      xlab("Input age 1") +
      ylab("Input age 2")

  fname <- paste0("./figures/elements_fig2e_meg_pdp_2d",
                  "_", this_model, ".")
  ggsave(paste0(fname, "pdf"), plot = fig2e,
        width = save_width, height = save_height, useDingbats = T)
  embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
  ggsave(paste0(fname, "png"), plot = fig2e,
          width = save_width, height = save_height,
        dpi = 300)
}

#' ## Session info

#+ session_info
print(sessionInfo())


# GetShockData_compare_cop5.r
#                                       RBLandau 20171230
# where to run?
# setwd("C:/cygwin64/home/landau/working/PreservationSimulation/shocks/compare/cop5")
#
# For copies=5, what are the failure rates at shock impacts 50, 80, 100%?
#

source("./DataUtil.r")
source("./PlotUtil.r")

# G E T   D A T A
if (exists("results")) {rm(results)}
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.shockallcopies <- as.data.frame(fndfGetShockData(results))
dat.shockall <- dat.shockallcopies[dat.shockallcopies$copies>=3
                & dat.shockallcopies$copies<=5,]

# S U B S E T S

if (nrow(dat.shockall) > 0)
{
    source("./ShockLowPlots.r")

    dat.shock5.3 <- dat.shockall[dat.shockall$copies==5
                            & dat.shockall$shockspan==3,
                            ]
    gp <- fnPlotShock4(trows=dat.shock5.3, nCopies=5)
    plot(gp)
    fnPlotMakeFile(gp, "Shock_compare_cop5_freq2yr_dur1yr_span3.png")

}

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}

#END


# By Yea-Hung Chen

# clear work space
rm(list=ls())

# set random seed
set.seed(2018)

# define time point of interest for survival analysis
TIME<-3

# load libraries
library(survival)
if_else<-dplyr::if_else

# load functions
source('impute dates.r')
source('define survival variables.r')
source('community-level estimates.r')
source('Preprocess_Functions.R')
source('Stage2_Functions.R')
source('Adapt_Functions.R')
source('s2.r')

# pri: load data
load('prepared data.RData')

# pri: define risk period
ii$start<-ii$tb_risk_start
ii$end<-ii$tb_risk_end

# pri: impute missing dates
ii<-impute_dates(c('ht.end','di.end','do.end','om.end'))

# pri: define survival variables
ovar<-c('ht','di')
cvar<-c('do','om')
ii<-define_survival_variables(ii)

# pri: define population
ii<-subset(ii,!data_flag)
ii<-subset(ii,!tb_censor_0)
ii<-subset(ii,!(dead_0|move_0))
ii<-subset(ii,adult_0)
ii<-subset(ii,resident_0)
ii<-subset(ii,!tb_0)
ii<-subset(ii,hiv_0|is.na(hiv_0))
ii<-subset(ii,stable_0)

# pri: initiate community-level data frame
cc<-c('com','community_name','pair','intervention',
      'tb_incidence_0','hiv_prev_0')
cc<-unique(ii[,cc])
cc<-cc[order(cc$com),]
row.names(cc)<-NULL

# pri: outcome variables
cc<-oo('pri',method='survival')
cc<-oo('pri_cd4_1',method='survival',dd=subset(ii,hiv_0&(cd4_0<=500)))

# pri: pre-process data
cc<-preprocess(cc,YHC=TRUE)

# pri: stage-ii analysis
s2('pri',CLUST.ADJ=c('U','tb_incidence_0','hiv_prev_0'),SURVIVAL=TRUE)
s2('pri_cd4_1',CLUST.ADJ=c('U','tb_incidence_0','hiv_prev_0'),SURVIVAL=TRUE)

# annual: load data
load('prepared data.RData')

# annual: define risk periods
ii$start<-ii$tb_risk_start
ii$end<-ii$tb_risk_end
source('risk periods for annual rates.r')

# annual: impute missing dates
ii<-impute_dates(c('tb.end','da.end','om.end'))

# annual: define survival variables
ovar<-c('tb')
cvar<-c('da','om')
ii<-define_survival_variables(ii)

# annual: define population
ii<-subset(ii,!data_flag)
ii<-subset(ii,!tb_censor_0)
ii<-subset(ii,!(dead_0|move_0))
ii<-subset(ii,adult_0)
ii<-subset(ii,resident_0)
ii<-subset(ii,!tb_0)

# annual: initiate community-level data frame
cc<-c('com','community_name','pair','intervention',
      'tb_incidence_0','hiv_prev_0')
cc<-unique(ii[,cc])
cc<-cc[order(cc$com),]
row.names(cc)<-NULL

# annual: outcome variables
oo('neg',method='annual',dd=subset(ii,!hiv_0))
oo('pos',method='annual',dd=subset(ii,hiv_0))

# annual: pre-process data
cc<-preprocess(cc,YHC=TRUE)

# annual: stage-ii analysis
OUTCOME<-paste(c('neg','pos'),rep(1:3,each=2),sep='')
invisible(lapply(OUTCOME,s2,CLUST.ADJ=c('U','tb_incidence_0','hiv_prev_0'),
                 SURVIVAL=FALSE))

# annual, crude: load data
load('prepared data.RData')

# annual, crude: define risk periods
ii$start<-ii$tb_risk_start
ii$end<-ii$tb_risk_end
source('risk periods for annual rates.r')

# annual, crude: impute missing dates
ii<-impute_dates(c('tb.end','da.end','om.end'))

# annual, crude: define survival variables
ovar<-c('tb')
cvar<-c('da','om')
ii<-define_survival_variables(ii)

# annual, crude: define population
ii<-subset(ii,!data_flag)
ii<-subset(ii,!tb_censor_0)
ii<-subset(ii,!(dead_0|move_0))
ii<-subset(ii,adult_0)
ii<-subset(ii,resident_0)
ii<-subset(ii,!tb_0)

# annual, crude: rates
negtxt<-yy(TRUE,'intervention',subset(ii,!hiv_0),'y')
negcon<-yy(FALSE,'intervention',subset(ii,!hiv_0),'y')
postxt<-yy(TRUE,'intervention',subset(ii,hiv_0),'y')
poscon<-yy(FALSE,'intervention',subset(ii,hiv_0),'y')

# output estimates
tt<-rbind(negtxt,negcon,postxt,poscon)
tt$hiv<-c('neg','neg','pos','pos')
tt<-tt[,c('hiv','intervention','y1','y2','y3')]
write.csv(tt,'tuberculosis crude incidence rates.csv',row.names=FALSE)
tt<-rbind(pri,pri_cd4_1,neg1,neg2,neg3,pos1,pos2,pos3)
write.csv(tt,'tuberculosis intervention effects.csv',row.names=FALSE)


# Performs preprocessing of categorical (multiple) fields, namely:
# 1) Reassigning values as specified in data coding file
# 2) Generating binary variable for each category in field, restricting to correct set of participants as specified
# in CAT_MULT_INDICATOR_FIELDS field of variable info file (either NO_NAN, ALL or a field ID)
# 3) Checking derived variable has at least catmultcutoff cases in each group
# 4) Calling binaryLogisticRegression function for this derived binary variable

testCategoricalMultiple <- function(varName, varType, thisdata, varlogfile)
{
    data_to_add_mat <- matrix(nrow=nrow(thisdata), ncol=0)
    data_to_add_names <- c()

    cat("CAT-MULTIPLE || ", file=varlogfile, append=TRUE)

    pheno <- thisdata[,phenoStartIdx:ncol(thisdata), drop=FALSE]
    pheno <- reassignValue(pheno, varName, varlogfile)

    # Get unique values from all columns of this variable
    # uniqueValues <- unique(na.omit(c(pheno)))
    numRows <- nrow(pheno)
    numCols <- ncol(pheno)

    uniqueValues = unique(na.omit(pheno[,1]));
    numCols = ncol(pheno);
    numRows = nrow(pheno);
    if (numCols>1) {
        for (num in 2:numCols) {
            u = unique(na.omit(pheno[,num]))
            uniqueValues = union(uniqueValues,u);
        }
    }

    print(uniqueValues)

    # For each value create a binary variable and test this
    if (length(uniqueValues) > 1) {
        for (variableVal in uniqueValues) {
            # Numeric negative values we assume are missing.
            if (is.numeric(variableVal) & variableVal < 0) {
                cat("SKIP_val:", variableVal," < 0 || ", sep="",
                    file=varlogfile, append=TRUE)
                next
            }

             # Make variable for this value - make sure that this is just the sample (the rows).
            idxForVar <- which(pheno == variableVal, arr.ind=TRUE)[,1]

            cat("CAT-MUL-BINARY-VAR ", variableVal, " || ", sep="", file=varlogfile, append=TRUE)
            incrementCounter("catMul.binary")

            # Make zero vector and set 1s for those with this variable value
            varBinary <- rep.int(FALSE, numRows)
            varBinary[idxForVar] <- TRUE
            varBinaryFactor <- factor(varBinary)

            # Data for this new binary variable
            newthisdata <- cbind.data.frame(thisdata[,1:numPreceedingCols], varBinaryFactor)
            newthisdata_to_save <- cbind.data.frame(thisdata[,1:numPreceedingCols], varBinary)

            # One of 3 ways to decide which examples are negative
            idxsToRemove <- restrictSample(varName, pheno, variableVal, varlogfile)

            # Create an ids to save vector, and plug these in NAs at the right positions.
        	if (!is.null(idxsToRemove)) {
                newthisdata_to_save <- newthisdata
                newthisdata_to_save[idxsToRemove,] <- NA
                newthisdata <- newthisdata[-idxsToRemove,]
            }

            facLevels <- levels(newthisdata_to_save[,phenoStartIdx])
            idxTrue <- length(which(newthisdata_to_save[,phenoStartIdx] == TRUE))
            idxFalse <- length(which(newthisdata_to_save[,phenoStartIdx] == FALSE))

            if (idxTrue < opt$catmultcutoff || idxFalse < opt$catmultcutoff) {
                cat("CAT-MULT-SKIP-", opt$catmultcutoff, " (", idxTrue, " vs ", idxFalse, ") || ",
                    sep="", file=varlogfile, append=TRUE)
                incrementCounter(paste("catMul.", opt$catmultcutoff, sep=""))
            } else {
                incrementCounter(paste("catMul.over", opt$catmultcutoff, sep=""))
            	# Binary so logistic regression
                data_to_add <- binaryLogisticRegression(paste(varName, variableVal, sep="_"),
                    varType, newthisdata_to_save, varlogfile)
                data_to_add_mat <- cbind(data_to_add_mat, as.logical(data_to_add[[1]]))
                data_to_add_names <- c(data_to_add_names, data_to_add[[2]])
        	}
        }
    }
    return(list(data_to_add_mat, data_to_add_names))
}

# Restricts sample based on value in CAT_MULT_INDICATOR_FIELDS column of variable info file,
# either NO_NAN, ALL or a field ID.
# Returns idx's that should be removed from the sample.
restrictSample <- function(varName, pheno, variableVal, varlogfile)
{
    # Get definition for sample for this variable either NO_NAN, ALL or a variable ID
    varIndicator <- vl$phenoInfo$CAT_MULT_INDICATOR_FIELDS[which(vl$phenoInfo$FieldID == varName)]
    return(restrictSample2(varName, pheno, varIndicator, variableVal, varlogfile))
}

restrictSample2 <- function(varName,pheno, varIndicator, variableVal, varlogfile)
{
    if (varIndicator=="NO_NAN") {
        # Remove NAs (remove all people with no value for this variable)

        # Row indexes with NA in all columns of this cat mult field
        ind <- apply(pheno, 1, function(x) all(is.na(x)))
        naIdxs <- which(ind == TRUE)
        cat("NO_NAN Remove NA participants", length(naIdxs), "|| ",
            file=varlogfile, append=TRUE)
    } else if (varIndicator == "ALL") {
        # Use all people (no missing assumed) so return empty vector
        # e.g. hospital data and death registry
        naIdxs <- c()
        cat("ALL || ", file=varlogfile, append=TRUE)
    } else if (varIndicator != "") {
        # Remove people who have no value for indicator variable
        print(varIndicator)
        indName <- grep(paste0("x", varIndicator,"_0_"), names(data), value=TRUE)
        print(indName)
        cat("Indicator name ", indName, " || ", sep="", file=varlogfile, append=TRUE)
        indicatorVar <- data[,indName, drop=FALSE]

        # Remove participants with all NAs in this related field
        where_change <- which(sapply(indicatorVar, is.nan) | indicatorVar == "NaN" | indicatorVar == "", arr.ind=TRUE)

        if(nrow(where_change) > 0) {
            indicatorVar[which(sapply(indicatorVar, is.nan) | indicatorVar == "NaN" | indicatorVar == "", arr.ind=TRUE)] <- NA
        }

        naIdxs <- which(apply(indicatorVar, 1, allNAs))

        cat("Remove indicator var NAs:", length(naIdxs), "|| ", file=varlogfile, append=TRUE)

        if (is.numeric(as.matrix(indicatorVar))) {
            # Remove participants with value <0 in this related field - assumed missing indicators
            lessZero <- which(indicatorVar < 0, arr.ind=TRUE)[,1]
            naIdxs <- union(naIdxs, lessZero)
            cat("Remove indicator var <0:", length(lessZero), "|| ", file=varlogfile, append=TRUE)
        }
    } else {
        stop("Categorical multiples variables need a value for CAT_MULT_INDICATOR_FIELDS", call.=FALSE)
    }

    # Remove people with pheno < 0 if they aren't a positive example for this
    # variable indicator because we can't know if they are a negative example or not.
    if (is.numeric(as.matrix(pheno))) {

        idxForVar <- which(pheno == variableVal, arr.ind = TRUE)[,1]
        idxMissing <- which(pheno < 0, arr.ind = TRUE)[,1]

        # All people with < 0 value and not variableVal
        naMissing <- setdiff(idxMissing, idxForVar)
        # Add these people with unknowns to set to remove from sample
        naIdxs <- union(naIdxs, naMissing)

        cat("Removed", length(naMissing) , "examples !=",
            variableVal, "but with missing value (<0) || ",
            file=varlogfile, append=TRUE)
    } else {
        cat("Not numeric || ", file=varlogfile, append=TRUE)
    }
    return(naIdxs)
}


library(shiny)
library(ggplot2)
library(ggvis)

# Data processing libraries
library(data.table)
library(reshape2)
library(dplyr)

library(mapproj)
library(maps)

# Load data
dt <- fread('data/gdp.csv')
world_map <- map_data("world")

shinyServer(
  function(input,output){

    output$gdpMap <- renderPlot({
      year = input$year
      world_map$gdp_percapita <- nchar(dt[ , year]) + sample(nrow(world_map))

      # Prepare map based on GDP data
      gg <- ggplot(world_map,aes(map_id=region))
      gg <- gg + geom_map(data=world_map, map=world_map, aes(map_id=region, x=long, y=lat, fill=gdp_percapita))
      gg <- gg + scale_fill_gradient(low = "red", high = "green", guide = "colourbar")
      gg <- gg + coord_equal()

      print(
        gg

      )
    })
  }
)


library(pacman)
p_load(tidyverse, leaflet, dplyr, sf)

# Reading file with municipal border (1:2 mil)
municipalities_mil <- st_read("KOMMUNE.shp") %>% dplyr::select(geometry, KOMNAVN) %>%  st_transform(crs = st_crs(4326)) %>% st_zm()

# Using st_union to create one polygon of each municipality
united_municipalities_mil <- municipalities_mil %>%
    group_by(KOMNAVN) %>%
    summarise(geometry = sf::st_union(geometry)) %>%
    ungroup()

# Writing shapefile
st_write(united_municipalities_mil, "municipal_mil_united.shp")
write.csv(united_municipalities_mil$KOMNAVN, "kommun.csv")


library(minfi)
# specify directory
minfi_baseDir = paste0("/Users/nrigby/Desktop/idats_standard/batch_1052641/")
# read samplesheet
minfi_targets = read.metharray.sheet(minfi_baseDir)
# read IDAT's into RGChannelSet
rgSet <- read.metharray.exp(targets = minfi_targets1,verbose = TRUE)
# preprocessRaw
mSet.raw = preprocessRaw(rgSet)
# make files
meth.raw = getMeth(mSet.raw)
write.csv(file='~/Desktop/idats_standard/minfi_raw_meth.csv',x=meth.raw1,row.names=TRUE,col.names=TRUE)
unmeth.raw = getUnmeth(mSet.raw)
write.csv(file='~/Desktop/idats_standard/minfi_raw_unmeth.csv',x=unmeth.raw1,row.names=TRUE,col.names=TRUE)
betas.raw = getBeta(mSet.raw)
write.csv(file='~/Desktop/idats_standard/minfi_raw_betas.csv',x=betas.raw1,row.names=TRUE,col.names=TRUE)
# preprocessNoob
mSet.noob = preprocessNoob(rgSet)
# make files
meth.noob = getMeth(mSet.noob)
write.csv(file='~/Desktop/idats_standard/minfi_noob_meth.csv',x=meth.noob,row.names=TRUE,col.names=TRUE)
unmeth.noob = getUnmeth(mSet.noob)
write.csv(file='~/Desktop/idats_standard/minfi_noob_unmeth.csv',x=unmeth.noob,row.names=TRUE,col.names=TRUE)
betas.noob = getBeta(mSet.noob)
write.csv(file='~/Desktop/idats_standard/minfi_noob_betas.csv',x=betas.noob,row.names=TRUE,col.names=TRUE)


b: a -> b (5)
c: b -> c (6)
e: c -> e (3)
d: d -> c (2)


library (dplyr)
library(tidyr)
library(ggplot2)
table <- read.csv("tabula-Expenditure Budget Volume 2 (Part I)_0.csv", header = TRUE,na="")
table_1 <- read.csv("tabula-Expenditure Budget Volume 2 (Part II)_0 (1).csv", header = FALSE, na = "")

names(table)[1] <- "Heads"
names(table_1)[1] <- "Heads"
names(table)[5] <- "Budget2020"
names(table_1)[5] <- "Budget2020"
#table <- na.omit(table)

table$Heads <- as.character(table$Heads)
table_1$Heads <- as.character(table_1$Heads)
#table_office <- table %>% filter(Heads == "Office Expenses")
#table[,grep("Office Expenses", names(df), value=TRUE)]
tableoffice <- table[grep("Office Expenses", table$Heads),]
tableoffice$Budget2020 <- as.numeric(as.character(tableoffice$Budget2020))
#tableoffice$Heads <- sapply(strsplit(tableoffice$Heads," "),1)
tableoffice$Heads <- substr(tableoffice$Heads,1,4)
#write.csv(tableoffice,"C:/Users/Preethi's Laptop/Documents/R/datascience_coursera_main/HP expenditure/HP-expenditure/tableoffice.csv", row.names = FALSE)
tableoffice<- tableoffice %>% group_by(Heads) %>% summarise_at("Budget2020",sum, na.rm = TRUE)

table_1_office <- table_1[grep("Office Expenses", table_1$Heads),]
table_1_office$Budget2020 <- as.numeric(as.character(table_1_office$Budget2020))
table_1_office$Heads <- sapply(strsplit(table_1_office$Heads," "), `[`, 1)
table_1_office <- table_1_office %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

Office_table <- rbind(tableoffice, table_1_office)
Office_table <- Office_table %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
Office_table_sum<- sum(Office_table$Budget2020)

office_plot <- Office_table %>% arrange(desc(Budget2020)) %>%
  slice(1:5) %>%
  ggplot(., aes(x=Heads,y=Budget2020)) + geom_bar(fill = "#21405d", stat = "identity")+
  ggtitle ("Budget Estimates for Office Expenses for the year 2020-21")+
  ylab ("Budget Estimates in rs lakhs")

print(office_plot)
ggsave("office_plot.png")

table_vehicle <- table[grep("Vehicle", table$Heads),]
table_vehicle$Budget2020 <- as.numeric(as.character(table_vehicle$Budget2020))
table_vehicle$Heads <- sapply(strsplit(table_vehicle$Heads," "), `[`, 1)
table_vehicle<- table_vehicle %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

table_1_vehicle <- table_1[grep("Vehicle", table_1$Heads),]
table_1_vehicle$Budget2020 <- as.numeric(as.character(table_1_vehicle$Budget2020))
table_1_vehicle$Heads <- sapply(strsplit(table_1_vehicle$Heads," "), `[`, 1)
table_1_vehicle<- table_1_vehicle %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

vehicle_table <- rbind(table_vehicle, table_1_vehicle)
vehicle_table <- vehicle_table %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
vehicle_table_sum<- sum(vehicle_table$Budget2020)

vehicle_plot <- vehicle_table %>% arrange(desc(Budget2020)) %>%
  slice(1:5) %>%
  ggplot(., aes(x=Heads,y=Budget2020)) + geom_bar(fill = "#21405d", stat = "identity") +
  theme(axis.text.x = element_text(angle = 90))+
  ggtitle ("Budget Estimates for Vehicles for the year 2020-21")+
  ylab ("Budget Estimates in rs lakhs")

print(vehicle_plot)
ggsave("vehicle_plot.png")

table_electricity <- table[grep("Electricity", table$Heads),]
table_electricity$Budget2020 <- as.numeric(as.character(table_electricity$Budget2020))
table_electricity <- table_electricity[- grep("Electricity Charges Total", table_electricity$Heads),]
table_electricity <- table_electricity[!is.na(table_electricity$Budget2020), ]
table_electricity$Heads <- sapply(strsplit(table_electricity$Heads," "), `[`, 1)
table_electricity<- table_electricity %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

table_1_electricity <- table_1[grep("Electricity", table_1$Heads),]
table_1_electricity$Budget2020 <- as.numeric(as.character(table_1_electricity$Budget2020))
table_1_electricity$Heads <- sapply(strsplit(table_1_electricity$Heads," "), `[`, 1)
table_1_electricity<- table_1_electricity %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

electricity_table <- rbind(table_electricity, table_1_electricity)
electricity_table <- electricity_table %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
electricity_table_sum<- sum(electricity_table$Budget2020)

elec_plot <- electricity_table %>% arrange(desc(Budget2020)) %>%
  slice(1:5) %>%
  ggplot(., aes(x=Heads,y=Budget2020)) + geom_bar(fill = "#21405d", stat = "identity") +
  theme(axis.text.x = element_text(angle = 90))+
  ggtitle ("Budget Estimates for Electricity for the year 2020-21")+
  ylab ("Budget Estimates in rs lakhs")

print(elec_plot)
ggsave("elec_plot.png")

#table_enter <- table[grep("Entertainment", table$Heads),]
#table_enter$Budget2020 <- as.numeric(as.character(table_enter$Budget2020))
#table_enter<- table_enter[- grep("Total", table_enter$Heads),]
#table_enter <- table_enter[!is.na(table_enter$Budget2020), ]
#table_enter$Heads <- sapply(strsplit(table_enter$Heads," "), `[`, 1)
#table_enter<- table_enter %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
#table_1_enter <- table_1[grep("Entertainment", table_1$Heads),]
#table_1_enter$Budget2020 <- as.numeric(table_1_enter$Budget2020)
#table_1_enter$Heads <- sapply(strsplit(table_1_enter$Heads," "), `[`, 1)
#table_1_enter <- table_1_enter %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
#entertainment_table <- rbind(table_enter, table_1_enter)
#entertainment_table <- entertainment_table %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
#entertainment_table_sum<- sum(entertainment_table$Budget2020)
#ent_plot <- entertainment_table %>% arrange(desc(Budget2020)) %>%
 # slice(1:5) %>%
#  ggplot(., aes(x=Heads,y=Budget2020)) + geom_bar(fill = "#21405d", stat = "identity") +
 # theme(axis.text.x = element_text(angle = 90))
#print(ent_plot)
#ggsave("ent_plot.png")

#tablesuppl <- table[grep("Supplies and Materials", table$Heads),]
#tablesuppl$Budget2020 <- as.numeric(tablesuppl$Budget2020)
#tablesuppl$Heads <- sapply(strsplit(tablesuppl$Heads," "), `[`, 1)
#tablesuppl <- tablesuppl %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

#table_1_suppl <- table_1[grep("Supplies and Materials", table_1$Heads),]
#table_1_suppl$Budget2020 <- as.numeric(table_1_suppl$Budget2020)
#table_1_suppl$Heads <- sapply(strsplit(table_1_suppl$Heads," "), `[`, 1)
#table_1_suppl <- table_1_suppl %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

#supply_table <- rbind(tablesuppl, table_1_suppl)
#supply_table <- supply_table %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
#supply_table_sum<- sum(supply_table$Budget2020)

#keywords <- c("Advertisement", "Advertising")
#table_ad <- filter(table, grepl(paste(keywords, collapse="|"), Heads))
table_ad <- table[grep("Advertis.*", table$Heads),]
table_ad$Budget2020 <- as.numeric(as.character(table_ad$Budget2020))
#table_ad$Heads <- substr(table_ad$Heads,1,4)
#table_ad$Heads <- sapply(strsplit(table_ad$Heads," "), `[`, 1)

table_ad <- table_ad[- grep("Total", table_ad$Heads),]
table_ad <- table_ad %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

table_1_ad <- table_1[grep("Advertis.*", table_1$Heads),]
table_1_ad$Budget2020 <- as.numeric(as.character(table_1_ad$Budget2020))
#table_1_ad$Heads <- sapply(strsplit(table_1_ad$Heads," "), `[`, 1)
#table_1_ad <- table_1_ad[- grep("Total", table_ad$Heads),]
table_1_ad <- table_1_ad %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

ad_table <- rbind(table_ad, table_1_ad)
ad_table <- ad_table %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
ad_table_sum<- sum(ad_table$Budget2020)

ad_plot <- ad_table %>% arrange(desc(Budget2020)) %>%
  slice(1:5) %>%
  ggplot(., aes(x=Heads,y=Budget2020)) + geom_bar(fill = "#21405d", stat = "identity") +
  theme(axis.text.x = element_text(angle = 90))+
  ggtitle ("Budget Estimates for advertising for the year 2020-21")+
  ylab ("Budget Estimates in rs lakhs")

print(ad_plot)
ggsave("ad_plot.png")

table_wage <- table[grep("Wages", table$Heads),]
table_wage$Budget2020 <- as.numeric(as.character(table_wage$Budget2020))
table_wage <- table_wage[- grep("Wages Total", table_wage$Heads),]
table_wage <- table_wage[!is.na(table_wage$Budget2020), ]
table_wage$Heads <- sapply(strsplit(table_wage$Heads," "), `[`, 1)
table_wage<- table_wage %>% group_by(Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

table_1_wage <- table_1[grep("Wages", table_1$Heads),]
table_1_wage$Budget2020 <- as.numeric(as.character(table_1_wage$Budget2020))
#table_1_wage <- table_1_wage[- grep("Wages Total", table_1_wage$Heads),]
table_1_wage <- table_1_wage[!is.na(table_1_wage$Budget2020), ]
table_1_wage$Heads <- sapply(strsplit(table_1_wage$Heads," "), `[`, 1)
table_1_wage <- table_1_wage %>% group_by(Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

wage_table <- rbind(table_wage,table_1_wage)
wage_table <- wage_table %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
wage_table_sum<- sum(wage_table$Budget2020)

wage_plot <- wage_table %>% arrange(desc(Budget2020)) %>%
  slice(1:5) %>%
  ggplot(., aes(x=Heads,y=Budget2020)) + geom_bar(fill = "#21405d", stat = "identity") +
  theme(axis.text.x = element_text(angle = 90))+
  ggtitle ("Budget Estimates for wages for the year 2020-21")+
  ylab ("Budget Estimates in rs lakhs")

print(wage_plot)
ggsave("wage_plot.png")

table_salaries <- table[grep("Salaries", table$Heads),]
table_salaries$Budget2020 <- as.numeric(as.character(table_salaries$Budget2020))
table_salaries <- table_salaries[- grep("Salaries Total", table_salaries$Heads),]
table_salaries <- table_salaries[!is.na(table_salaries$Budget2020), ]
table_salaries$Heads <- sapply(strsplit(table_salaries$Heads," "), `[`, 1)
table_salaries<- table_salaries %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

table_1_salaries <- table_1[grep("Salaries", table_1$Heads),]
table_1_salaries$Budget2020 <- as.numeric(as.character(table_1_salaries$Budget2020))
table_1_salaries<- table_1_salaries[- grep("Salaries Total", table_1_salaries$Heads),]
table_1_salaries<- table_1_salaries[!is.na(table_1_salaries$Budget2020), ]
table_1_salaries$Heads <- sapply(strsplit(table_1_salaries$Heads," "), `[`, 1)
table_1_salaries <- table_1_salaries %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)

salary_table <- rbind(table_salaries, table_1_salaries)
salary_table <- salary_table %>% group_by (Heads) %>% summarise_at("Budget2020", sum, na.rm = T)
salary_table_sum<- sum(salary_table$Budget2020)

salary_plot <- salary_table %>% arrange(desc(Budget2020)) %>%
  slice(1:5) %>%
  ggplot(., aes(x=Heads,y=Budget2020)) + geom_bar(fill = "#21405d", stat = "identity") +
  theme(axis.text.x = element_text(angle = 90))+
  ggtitle ("Budget Estimates for salaries for the year 2020-21")+
  ylab ("Budget Estimates in rs lakhs")

print(salary_plot)
ggsave("salary_plot.png")


pdf_file<-"pdf/scatterplots_symbols.pdf"
cairo_pdf(bg="grey98", pdf_file,width=7.5,height=12)

par(omi=c(0.5,0.5,0,0),mai=c(0.5,1.25,0,0.25),family="Lato Light",las=1)
library(maptools)

# Import data and prepare chart

library(gdata)
myData<-read.xls("myData/Intra-StateWarData_v4.1.xlsx", encoding="latin1")
mySelection<-subset(myData, myData$StartYear1>=1995 & myData$SideADeaths > 0 & myData$SideADeaths < 2000 & myData$SideBDeaths > 0 & myData$SideBDeaths < 4000)
attach(mySelection)

myColour<-"darkred"
myN<-nrow(mySelection)
h<-rep(0, myN)
v<-rep(0, myN)
myOffset<-cbind(h, v)

# mySelection[, c("WarName", "StartYear1", "SideADeaths", "SideBDeaths")]
myOffset[1, "h"]<--400
myOffset[5, "h"]<-232
myOffset[4, "h"]<--275
myOffset[2, "h"]<-270; myOffset[2, "v"]<-100
myOffset[13, "h"]<--275
myOffset[12, "h"]<--300

myX<-as.numeric(SideADeaths)
myY<-as.numeric(SideBDeaths)

# Define chart and other elements

plot(myX, myY, typ="n", xlab="", ylab="", axes=F, xlim=c(0, 2000), ylim=c(0, 4000))
axis(1,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
text(myX+130+myOffset[, "h"], myY-180+myOffset[, "v"], paste(WarName, StartYear1, sep=" "), cex=0.8, xpd=T, col="grey")

mtext(side=1, "Side A Deaths (Authorities)", adj=0.5, line=3)
mtext(side=2, "Side B Deaths (Rebels)", las=0, adj=0.5, line=4)

# Titling

mtext("Deaths by Intra-state Wars",3,adj=1,line=-3,cex=2.1,family="Lato Black")
mtext("1997-2007",3,adj=1,line=-5,cex=1.4,font=3)
mtext("Source: correlatesofwar.org",1,line=1,adj=0,cex=0.95,outer=T,font=3)

# Other elements of chart

par(family="Datendesign")
text(myX, myY, "b", col=myColour, cex=5, xpd=T)
dev.off()


## Setup R error handling to go to stderr
options( show.error.messages=F,
       error = function () { cat( geterrmessage(), file=stderr() ); q( "no", 1, F ) } )
warnings()
library(optparse)
library(ggplot2)
library(reshape2)

option_list <- list(
    make_option(c("-i", "--input"), type="character", help="Path to dataframe"),
    make_option(c("-t", "--title"), type="character", help="Main Title"),
    make_option("--xlab", type = "character", help="X-axis legend"),
    make_option("--ylab", type = "character", help="Y-axis legend"),
    make_option("--sample", type = "character", help="a space separated of sample labels"),
    make_option("--method", type = "character", help="bedtools or pysam"),
    make_option(c("-o", "--output"), type = "character", help="path to the pdf plot")
    )

parser <- OptionParser(usage = "%prog [options] file", option_list = option_list)
args = parse_args(parser)
samples = substr(args$sample, 2, nchar(args$sample)-2)
samples = strsplit(samples, ", ")

# data frames implementation

Table <- read.delim(args$input, header=F)
headers = c("chromosome", "start", "end", "id")
for (i in seq(1, length(Table)-4)) {
    headers <- c(headers, samples[[1]][i])
colnames(Table) <- headers
}

## function
if (args$method == 'bedtools') {
    cumul <- function(x,y) sum(Table[,y]/(Table$end-Table$start) > x)/length(Table$chromosome)
    } else {
    cumul <- function(x,y) sum(Table[,y] > x)/length(Table$chromosome)
    }
scaleFUN <- function(x) sprintf("%.3f", x)

## end of function
## let's do a dataframe before plotting
if (args$method == 'bedtools') {
    maxdepth <- trunc(max(Table[,5:length(Table)]/(Table$end-Table$start))) + 20
    } else {
    maxdepth <- trunc(max(Table[,5:length(Table)])) + 20
    }

graphpoints <- data.frame(1:maxdepth)
i <- 5
for (colonne in colnames(Table)[5:length(colnames(Table))]) {
    graphpoints <- cbind(graphpoints,  mapply(cumul, 1:maxdepth, rep(i, maxdepth)))
    i <- i + 1
    }
colnames(graphpoints) <- c("Depth", colnames(Table)[5:length(Table)])
maxfrac = max(graphpoints[,2:length(graphpoints)])

graphpoints <- melt(graphpoints, id.vars="Depth", variable.name="Samples", value.name="sample_value")

## GRAPHS

pdf(file=args$output)
ggplot(data=graphpoints, aes(x=Depth, y=sample_value, colour=Samples)) +
      geom_line(size=1) +
      scale_x_continuous(trans='log2', breaks = 2^(seq(0,log(maxdepth, 2)))) +
      scale_y_continuous(breaks = seq(0, maxfrac, by=maxfrac/10), labels=scaleFUN) +
      labs(x=args$xlab, y=args$ylab, title=args$title) +
      theme(legend.position="top", legend.title=element_blank(), legend.text=element_text(colour="blue", size=7))

##      facet_wrap(~Samples, ncol=2)

devname=dev.off()


x <- 1+1


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

par(omi=c(0.65,0.75,0.95,0.75),mai=c(0.9,0,0.25,0.02),fg=rgb(64,64,64,maxColorValue=255),bg="azure2",family="Lato Light",las=1)

# Read data and prepare chart

gdp<-read.xls("myData/GDP_germany_quarter.xlsx",sheet=1)
gdp<-subset(gdp,gdp$year > 2007)
x<-ts(rev(gdp$jeworiginal),start=2008,frequency=4)

# Create chart and other elements

plot(x,type="n",axes=F,xlim=c(2008,2012),ylim=c(560,670),xlab="",ylab="")
abline(v=c(2008:2012),col="white",lty=1,lwd=1)
lines(x,lwd=8,type="b",col=rgb(0,0,139,80,maxColorValue=255))
points(x,pch=19,cex=3,col=rgb(139,0,0,maxColorValue=255))
faktor<-rep(0.985,length(x))
for (i in 1:length(x))
{
if (i>1 & i<length(x)) { if (x[i]>x[i-1] & x[i]>x[i+1]) { faktor[i]<-1.015 } }
text((2008+i*0.25)-0.25,faktor[i]*x[i],x[i],col=rgb(64,64,64,maxColorValue=255),cex=1.1)
}
axis(1,at=c(2008:2012),tck=0)
axis(2,col=NA,col.ticks=rgb(24,24,24,maxColorValue=255),lwd.ticks=0.5,cex.axis=1.0,tck=-0.025)

# Titling

mtext("Gross Domestic Product in Germany 2000 - 2011",3,line=2.3,adj=0,cex=2,family="Lato Black",outer=T)
mtext("Original values in current prices, Bill. EUR, quarterly values",3,line=0,adj=0,cex=1.75,font=3,outer=T)
mtext("Source: destatis.de",1,line=1,adj=1,cex=1.25,font=3,outer=T)
dev.off()


library(dplyr)
library(tibble)
library(tidyr)
library(caret)
library(gtools)
library(FinCal)
library(doParallel)

#setwd("~/Documents/nstringjul18")
load(file="allns_data.rdata")
load("modelgbm.rdata")
load("models.rdata")
load("vardat.rdata")
load(file="markerchoiceinfo.rdata")

cl <- makePSOCKcluster(7)
registerDoParallel(cl)

md <- as.data.frame(subset(t(ctall.norm), sampleinfo$sex == "F" &
                             sampleinfo$prep== "Luke"&
                             sampleinfo$exp %in% c("Size-age", "cohorts", "OvY") &
                             sampleinfo$codeset == "phaw_1" &
                             sampleinfo$type %in% c("O", "Y", "M")
))

md <- subset(md, rownames(md)%in% qualsum$sample[qualsum$good])

md <- md[, lmdf2$in61 ==T & lmdf2$pvalovy < 0.05]

md <- md[, colnames(md) %in% c(minf$name[minf$in61==T], "predage")]

md$sample <- rownames(md)

md <- left_join(md, select(sampleinfo, sample, predage), by="sample") %>%
  filter(!(is.na(predage))) %>%
  column_to_rownames(var="sample")

trainchoice <- sample(1:nrow(md))[1:floor(4*(nrow(md)/5))]

trainchoice <- rownames(md) %in% rownames(currbest$trainingData)
trdat <- md[trainchoice,]
tedat <- md[-trainchoice,]

gbmagemodelp5 <- train(
  predage~.,
  tuneLength = 5,
  data = trdat,
  method = "gbm",
  tuneGrid=expand.grid(n.trees = (0:50)*200,
                       interaction.depth = c(1,2,3,4,5,6,7,8,9,10),
                       shrinkage = c(0.0001,.001, 0.01, 0.1, 0.2, 0.3) ,
                       n.minobsinnode = c(2,3,4,5,6,7,8,9,10)),
  trControl =  trainControl(method = 'cv',
                            number = 10,
                            summaryFunction=defaultSummary,
                            verboseIter = T)
)

md <- as.data.frame(subset(t(ctall.norm), sampleinfo$sex == "F" &
                             sampleinfo$prep== "Luke"&
                             sampleinfo$exp %in% c("Size-age", "cohorts", "OvY") &
                             sampleinfo$codeset == "phaw_1" &
                             sampleinfo$type %in% c("O", "Y", "M")
))

md <- subset(md, rownames(md)%in% qualsum$sample[qualsum$good])

md <- md[, lmdf2$in61 ==T & lmdf2$pvalovy < 0.04]

md <- md[, colnames(md) %in% c(minf$name[minf$in61==T], "predage")]

md$sample <- rownames(md)

md <- left_join(md, select(sampleinfo, sample, predage), by="sample") %>%
  filter(!(is.na(predage))) %>%
  column_to_rownames(var="sample")

trainchoice <- sample(1:nrow(md))[1:floor(4*(nrow(md)/5))]

trainchoice <- rownames(md) %in% rownames(currbest$trainingData)
trdat <- md[trainchoice,]
tedat <- md[-trainchoice,]

gbmagemodelp4 <- train(
  predage~.,
  tuneLength = 5,
  data = trdat,
  method = "gbm",
  tuneGrid=expand.grid(n.trees = (0:50)*200,
                       interaction.depth = c(1,2,3,4,5,6,7,8,9,10),
                       shrinkage = c(0.0001,.001, 0.01, 0.1, 0.2, 0.3) ,
                       n.minobsinnode = c(2,3,4,5,6,7,8,9,10)),
  trControl =  trainControl(method = 'cv',
                            number = 10,
                            summaryFunction=defaultSummary,
                            verboseIter = T)
)

md <- as.data.frame(subset(t(ctall.norm), sampleinfo$sex == "F" &
                             sampleinfo$prep== "Luke"&
                             sampleinfo$exp %in% c("Size-age", "cohorts", "OvY") &
                             sampleinfo$codeset == "phaw_1" &
                             sampleinfo$type %in% c("O", "Y", "M")
))

md <- subset(md, rownames(md)%in% qualsum$sample[qualsum$good])

md <- md[, lmdf2$in61 ==T & lmdf2$pvalovy < 0.03]

md <- md[, colnames(md) %in% c(minf$name[minf$in61==T], "predage")]

md$sample <- rownames(md)

md <- left_join(md, select(sampleinfo, sample, predage), by="sample") %>%
  filter(!(is.na(predage))) %>%
  column_to_rownames(var="sample")

trainchoice <- sample(1:nrow(md))[1:floor(4*(nrow(md)/5))]

trainchoice <- rownames(md) %in% rownames(currbest$trainingData)
trdat <- md[trainchoice,]
tedat <- md[-trainchoice,]

gbmagemodelp3 <- train(
  predage~.,
  tuneLength = 5,
  data = trdat,
  method = "gbm",
  tuneGrid=expand.grid(n.trees = (0:50)*200,
                       interaction.depth = c(1,2,3,4,5,6,7,8,9,10),
                       shrinkage = c(0.0001,.001, 0.01, 0.1, 0.2, 0.3) ,
                       n.minobsinnode = c(2,3,4,5,6,7,8,9,10)),
  trControl =  trainControl(method = 'cv',
                            number = 10,
                            summaryFunction=defaultSummary,
                            verboseIter = T)
)

md <- as.data.frame(subset(t(ctall.norm), sampleinfo$sex == "F" &
                             sampleinfo$prep== "Luke"&
                             sampleinfo$exp %in% c("Size-age", "cohorts", "OvY") &
                             sampleinfo$codeset == "phaw_1" &
                             sampleinfo$type %in% c("O", "Y", "M")
))

md <- subset(md, rownames(md)%in% qualsum$sample[qualsum$good])

md <- md[, lmdf2$in61 ==T & lmdf2$pvalovy < 0.02]

md <- md[, colnames(md) %in% c(minf$name[minf$in61==T], "predage")]

md$sample <- rownames(md)

md <- left_join(md, select(sampleinfo, sample, predage), by="sample") %>%
  filter(!(is.na(predage))) %>%
  column_to_rownames(var="sample")

trainchoice <- sample(1:nrow(md))[1:floor(4*(nrow(md)/5))]

trainchoice <- rownames(md) %in% rownames(currbest$trainingData)
trdat <- md[trainchoice,]
tedat <- md[-trainchoice,]

gbmagemodelp2 <- train(
  predage~.,
  tuneLength = 5,
  data = trdat,
  method = "gbm",
  tuneGrid=expand.grid(n.trees = (0:50)*200,
                       interaction.depth = c(1,2,3,4,5,6,7,8,9,10),
                       shrinkage = c(0.0001,.001, 0.01, 0.1, 0.2, 0.3) ,
                       n.minobsinnode = c(2,3,4,5,6,7,8,9,10)),
  trControl =  trainControl(method = 'cv',
                            number = 10,
                            summaryFunction=defaultSummary,
                            verboseIter = T)
)

md <- as.data.frame(subset(t(ctall.norm), sampleinfo$sex == "F" &
                             sampleinfo$prep== "Luke"&
                             sampleinfo$exp %in% c("Size-age", "cohorts", "OvY") &
                             sampleinfo$codeset == "phaw_1" &
                             sampleinfo$type %in% c("O", "Y", "M")
))

md <- subset(md, rownames(md)%in% qualsum$sample[qualsum$good])

md <- md[, lmdf2$in61 ==T & lmdf2$pvalovy < 0.01]

md <- md[, colnames(md) %in% c(minf$name[minf$in61==T], "predage")]

md$sample <- rownames(md)

md <- left_join(md, select(sampleinfo, sample, predage), by="sample") %>%
  filter(!(is.na(predage))) %>%
  column_to_rownames(var="sample")

trainchoice <- sample(1:nrow(md))[1:floor(4*(nrow(md)/5))]

trainchoice <- rownames(md) %in% rownames(currbest$trainingData)
trdat <- md[trainchoice,]
tedat <- md[-trainchoice,]

gbmagemodelp1 <- train(
  predage~.,
  tuneLength = 5,
  data = trdat,
  method = "gbm",
  tuneGrid=expand.grid(n.trees = (0:50)*200,
                       interaction.depth = c(1,2,3,4,5,6,7,8,9,10),
                       shrinkage = c(0.0001,.001, 0.01, 0.1, 0.2, 0.3) ,
                       n.minobsinnode = c(2,3,4,5,6,7,8,9,10)),
  trControl =  trainControl(method = 'cv',
                            number = 10,
                            summaryFunction=defaultSummary,
                            verboseIter = T)
)

gbmagemodelp1b <- train(
  predage~.,
  tuneLength = 5,
  data = trdat,
  method = "gbm",
  tuneGrid=expand.grid(n.trees = (0:50)*500,
                       interaction.depth = c(1,2,3,4,5,6,7,8,9,10),
                       shrinkage = c(0.0001,.001, 0.01, 0.1, 0.2, 0.3) ,
                       n.minobsinnode = c(2,3,4,5,6,7,8,9,10)),
  trControl =  trainControl(method = 'cv',
                            number = 10,
                            summaryFunction=defaultSummary,
                            verboseIter = T)
)

gbmagemodelp1c <- train(
  predage~.,
  tuneLength = 5,
  data = trdat,
  method = "gbm",
  tuneGrid=expand.grid(n.trees = (0:50)*500,
                       interaction.depth = c(1,2,3,4,5,6,7,8,9,10),
                       shrinkage = c(0.0001,.001, 0.01, 0.1, 0.2, 0.3) ,
                       n.minobsinnode = c(2,3,4,5,6,7,8,9,10)),
  trControl =  trainControl(method = 'cv',
                            number = 20,
                            summaryFunction=defaultSummary,
                            verboseIter = T)
)

gbmagemodelp1d <- train(
  predage~.,
  tuneLength = 5,
  data = trdat,
  method = "gbm",
  tuneGrid=expand.grid(n.trees = (0:50)*500,
                       interaction.depth = c(1,2,3,4,5,6,7,8,9,10),
                       shrinkage = c(0.0001,.001, 0.01, 0.1, 0.2, 0.3) ,
                       n.minobsinnode = c(2,3,4,5,6,7,8,9,10)),
  trControl =  trainControl(method = 'cv',
                            number = 40,
                            summaryFunction=defaultSummary,
                            verboseIter = T)
)

stopCluster(cl)

save(gbmagemodelp5, gbmagemodelp4, gbmagemodelp3, gbmagemodelp2, gbmagemodelp1, gbmagemodelp1b, gbmagemodelp1c, gbmagemodelp1d, file="gbmbig2.rdata")