# GetGlitchData_quarter.r
#                                       RBLandau 20180211
# where to run?
# setwd("C:/cygwin64/home/landau/working/PreservationSimulation/glitch/month")
#
# For copies=3,4,5: what are the failure rates with glitches?
#

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.glitchallcopies <- as.data.frame(fndfGetGlitchData(results))
dat.glitchall <- dat.glitchallcopies[
                    dat.glitchallcopies$copies>=3
                &   dat.glitchallcopies$copies<=6,
                ]

# S U B S E T S

if (nrow(dat.glitchall) > 0)
{
    source("./GlitchPlots.r")

    # freq 3mo  dur 4wk
    dat.glitchspan1 <- data.frame(dat.glitchall[dat.glitchallcopies$glitchfreq>0
                        & dat.glitchall$glitchfreq==2500
                        & dat.glitchall$glitchmaxlife==1000
                        & dat.glitchall$glitchimpact==50
                        ,]
                        )
    gp <- fnPlotGlitch1(dat.glitchspan1, nFreq=2500, nDuration=1000, nSpan=1, nImpact=50)
    plot(gp)
    fnPlotMakeFile(gp, "Glitch_compare_copvar_freq3mo_dur1mo_span1_impact50.png")

    # freq 3mo  dur 4wk
    dat.glitchspan1 <- dat.glitchall[dat.glitchall$glitchdecay==0
                        & dat.glitchall$glitchfreq==2500
                        & dat.glitchall$glitchmaxlife==1000
                        & dat.glitchall$glitchimpact==33
                        ,]
    gp <- fnPlotGlitch1(dat.glitchspan1, nFreq=2500, nDuration=1000, nSpan=1, nImpact=33)
    plot(gp)
    fnPlotMakeFile(gp, "Glitch_compare_copvar_freq3mo_dur1mo_span1_impact33.png")

    # freq 3mo  dur 4wk
    dat.glitchspan1 <- dat.glitchall[dat.glitchall$glitchdecay==0
                        & dat.glitchall$glitchfreq==2500
                        & dat.glitchall$glitchmaxlife==1000
                        & dat.glitchall$glitchimpact==67
                        ,]
    gp <- fnPlotGlitch1(dat.glitchspan1, nFreq=2500, nDuration=1000, nSpan=1, nImpact=67)
    plot(gp)
    fnPlotMakeFile(gp, "Glitch_compare_copvar_freq3mo_dur1mo_span1_impact67.png")

}

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

#END


\docType{data}
\name{miller}
\alias{miller}
\title{38 popüler otomobil modeli için 1999'dan 2008'e kadar yakıt ekonomisi verileri}
\format{234 gözlem ve 11 değişken içeren bir tibble
\describe{
\item{üretici}{Üretici firma adı}
\item{model}{Model adı}
\item{motor}{Motor hacmi (litre)}
\item{yıl}{Üretim yılı}
\item{silindir}{Silindir sayısı}
\item{şanzıman}{Şanzıman türü}
\item{çekiş}{Çekiş türü (ön = önden çekiş, arka = arkadan çekiş, 4 = 4x4)}
\item{şehir}{Şehir içi mil başına galon tüketimi}
\item{otoyol}{Otoyolda mil başına galon tüketimi}
\item{yakıt}{Yakıt türü (y = yüksek kaliteli, n = normal, e = etanol, d = dizel, g = gaz)}
\item{sınıf}{Araç sınıfı}
}}
\usage{miller}
\description{Bu veri kümesi, EPA'nın https://fueleconomy.gov/ adresinde sunduğu yakıt ekonomisi verilerinin bir kısmını içerir. Yalnızca 1999 ile 2008 arasında her yıl yeni çıkan modelleri içerir - bu, arabanın popülerliğinin bir göstergesi olarak kullanılmıştır.}
\seealso{\code{\link[ggplot2]{mpg}}}
\keyword{datasets}


#belowBlimplotfile(dev=my.dev,out='abox-pel-derm')
par(mfcol=c(3,3))
par(mar=c(4,4,3,2)) #bottom, left, top, right

 load(file =file.path(scenario.dir, "indicators.RData"))

pl<-strmacro(SP,Sp,
   expr={
    ylab1<-paste("(1000 t)")
    main1<-"Demersal biomass"
    main2<-"Pelagic biomass"
    main3<-"Pelagic bio:Demersal biom"
    xlab1<-paste('F', "Sp")
    boxplot(bio.demer/1000~SP,data=indi,xlab=xlab1,ylab=ylab1,main=main1)
    boxplot(bio.pelag/1000~SP,data=indi,xlab=xlab1,ylab=ylab1,main=main2)
    boxplot(bio.pelag/bio.demer~SP,data=indi,xlab=xlab1,ylab=' ',main=main3)
  } )
pl(SP=COD,Sp=Cod)
pl(SP=HER,Sp=Herring)
pl(SP=SPR,Sp=Sprat)
if (my.dev %in% c('png','wmf','pdf'))  dev.off()

plotfile(dev=my.dev,out='abox-life_expec')
par(mfcol=c(3,3))
par(mar=c(4,4,3,2)) #bottom, left, top, right

pl.life<-strmacro(SP,Sp,
   expr={
    ylab3<-"Years"
    main1<-"Community M2"
    main2<-"Community F"
    main3<-"Life expectancy"
    xlab1<-paste('F', "Sp")
    boxplot(comm.M2~SP,data=indi,xlab=xlab1,ylab=' ',main=main1)
    boxplot(comm.Fall~SP,data=indi,xlab=xlab1,ylab=' ',main=main2)
    boxplot(comm.life.expec~SP,data=indi,xlab=xlab1,ylab=ylab3,main=main3)
  } )
pl.life(SP=COD,Sp=Cod)
pl.life(SP=HER,Sp=Herring)
pl.life(SP=SPR,Sp=Sprat)
if (my.dev %in% c('png','wmf','pdf'))  dev.off()

plotfile(dev=my.dev,out='abox-LFI')
par(mfcol=c(3,3))
par(mar=c(4,4,3,2)) #bottom, left, top, right

pl.LFI<-strmacro(SP,Sp,
   expr={
    ylab1<-"%"
    main1<-"LFI (40 cm)"
    xlab1<-paste('F', "Sp")
    boxplot(LFI*100~SP,data=indi,xlab=xlab1,ylab=ylab1,main=main1)
    #boxplot(comm.Fall~SP,data=indi,xlab=xlab1,ylab=' ',main=main2)
    #boxplot(comm.life.expec~SP,data=indi,xlab=xlab1,ylab=ylab3,main=main3)
  } )
pl.LFI(SP=COD,Sp=Cod)
pl.LFI(SP=HER,Sp=Herring)
pl.LFI(SP=SPR,Sp=Sprat)
if (my.dev %in% c('png','wmf','pdf'))  dev.off()

plotfile(dev=my.dev,out='abox-all-sys-indi')
par(mfcol=c(7,3))
par(mar=c(4,4,3,2)) #bottom, left, top, right

pl.indi<-strmacro(SP,Sp,
   expr={

    ylab1<-paste("(1000 t)")
    main1<-"Demersal biomass"
    main2<-"Pelagic biomass"
    main3<-"Pelagic bio:Demersal biom"
    xlab1<-paste('F', "Sp")
    boxplot(bio.demer/1000~SP,data=indi,xlab=xlab1,ylab=ylab1,main=main1)
    boxplot(bio.pelag/1000~SP,data=indi,xlab=xlab1,ylab=ylab1,main=main2)
    boxplot(bio.pelag/bio.demer~SP,data=indi,xlab=xlab1,ylab=' ',main=main3)

    ylab3<-"Years"
    main1<-"Community M2"
    main2<-"Community F"
    main3<-"Life expectancy"
    xlab1<-paste('F', "Sp")
    boxplot(comm.M2~SP,data=indi,xlab=xlab1,ylab=' ',main=main1)
    boxplot(comm.Fall~SP,data=indi,xlab=xlab1,ylab=' ',main=main2)
    boxplot(comm.life.expec~SP,data=indi,xlab=xlab1,ylab=ylab3,main=main3)

    ylab1<-"%"
    main1<-"LFI (40 cm)"
    xlab1<-paste('F', "Sp")
    boxplot(LFI*100~SP,data=indi,xlab=xlab1,ylab=ylab1,main=main1)
    } )

pl.indi(SP=COD,Sp=Cod)
pl.indi(SP=HER,Sp=Herring)
pl.indi(SP=SPR,Sp=Sprat)
if (my.dev %in% c('png','wmf','pdf'))  dev.off()

plotfile(dev=my.dev,out='abox-sys-indi_paper')
par(mfcol=c(5,3))
par(mar=c(4,4,3,2)) #bottom, left, top, right

pl.indi<-strmacro(SP,Sp,
   expr={

    ylab1<-paste("(1000 t)")
    main1<-"Demersal biomass"
    main2<-"Pelagic biomass"
    main3<-"Pelagic bio:Demersal bio"
    xlab1<-paste('F', "Sp")
   # boxplot(bio.demer/1000~SP,data=indi,xlab=xlab1,ylab=ylab1,main=main1)
   # boxplot(bio.pelag/1000~SP,data=indi,xlab=xlab1,ylab=ylab1,main=main2)
    boxplot(bio.pelag/bio.demer~SP,data=indi,xlab=xlab1,ylab=' ',main=main3)

    ylab3<-"Years"
    main1<-"Community M2"
    main2<-"Community F"
    main3<-"Life expectancy"
    xlab1<-paste('F', "Sp")
    boxplot(comm.M2*100~SP,data=indi,xlab=xlab1,ylab='%',main=main1)
    boxplot(comm.Fall*100~SP,data=indi,xlab=xlab1,ylab='%',main=main2)
    boxplot(comm.life.expec~SP,data=indi,xlab=xlab1,ylab=ylab3,main=main3)

    ylab1<-"%"
    main1<-"LFI (40 cm)"
    xlab1<-paste('F', "Sp")
    boxplot(LFI*100~SP,data=indi,xlab=xlab1,ylab=ylab1,main=main1)
    } )

pl.indi(SP=COD,Sp=Cod)
pl.indi(SP=HER,Sp=Herring)
pl.indi(SP=SPR,Sp=Sprat)
if (my.dev %in% c('png','wmf','pdf'))  dev.off()


##############################################################################################
#
# Mark Cembrowski, Janelia Research Campus,
#
# This script loads up the relevant tables and scripts for single-cell RNA-seq.
#
##############################################################################################

# Load scripts.
	source('./code/loadSingleCellData.r') # Load single cell data.
	source('./code/singleCellBarplot.r')	# single cell barplot
	source('./code/singleCellPca.r') # pca
	source('./code/singleCellDispersion.r')	# single cell dispersion
	source('./code/singleCellMultigene.r') # single cell multigene plot


#' Stanfit MCMC Sampling Diagnostics
#'
#' A wrapper function around several model diagnostics provided by \code{rstan}. It prints
#' the amount of divergent transitions, treedepth limit hits, energy, effective transitions
#' and R-hat.
#'
#' @export
#' @param fit Any stanfit object.
#' @return Prints model diagnostics to console.
model_diagnostics <- function(fit){

    cat('\nDivergencies:\n')
    check_divergences(fit)
    cat('\nTreedepth:\n')
    rstan::check_treedepth(fit)
    cat('\nE-BFMI:\n')
    check_energy(fit)
}


#' Seasonal Factors for Initial Unemployment Claims, weekly (ic)
#'
#' A time series object with seasonal factors generated for weekly initial unemployment
#' claims released by the Department of Labor
#'
#' @format A tis time series object from February 1, 2003 to January 30, 2021
#' @source \url{https://www.dol.gov/ui/data.pdf}
"ic_sf"


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

# par(omi=c(0.65,0.25,1.25,0.75),mai=c(0.3,2,0.35,0),family="Lato Light",las=1)
par(omi=c(0.55,0.25,1.15,0.75),family="Lato Light",las=1)
library(treemap)
library(gdata)

# Import data

federalbudget<-read.xls("mydata/federalbudget.xlsx",sheet=1, encoding="latin1")

#  Create chart

plot.new()
treemap(federalbudget,title="",index="Title",type="index",vSize="Expenditures",palette="YlOrRd",aspRatio=1.9,inflate.labels=T)

# Titling

mtext("Federal Budget 2011",3,line=3.8,adj=0,cex=2.2,family="Lato Black",outer=T)
mtext("Shares of Expenditure",3,line=2.3,adj=0,cex=1.5,outer=T,font=3)
mtext("Source: bund.offenerhaushalt.de",1,line=1,adj=1.0,cex=0.95,outer=T,font=3)
dev.off()


library(shiny)

ui <- shinyUI(fluidPage(
  titlePanel("Load Forecasting Dashboard"),
  tabsetPanel(
    tabPanel("Upload File",
             titlePanel("Uploading Files"),
             sidebarLayout(
               sidebarPanel(

                 tags$form(
                   fileInput('file1', 'Choose CSV File',
                             accept=c('text/csv',
                                      'text/comma-separated-values,text/plain','.csv')),

                   radioButtons('sep', 'Separator',c(Comma=','
                                                     ,Semicolon=';',Tab='\t'),','),
                   actionButton("upload", "Upload")
                 )
                 )

           ,

               mainPanel(
                 dataTableOutput('contents')
               )
             )#sidebar layout
    ),
#####################################################################
#####################################################################
    tabPanel("Plot",
             pageWithSidebar(
               headerPanel('Data'),
               sidebarPanel(

                 tags$form(
                 # "Empty inputs" - they will be updated after the data is uploaded
                 selectInput('xcol', 'X axis', "",selected = 1),
                 selectInput('ycol', 'Y axis', "", selected = 1),
                 downloadButton('downloadPlot', 'Download Plot'),
                 actionButton("drawPlot","Plot")
               )),mainPanel(
                  dygraphOutput("dygraph")
               )
             )
),# end of tabpanel 2
#####################################################################
####################################################################
    tabPanel("Model",
             pageWithSidebar(
               headerPanel('Model'),
               # 1. upload button for regressors.
               # 2. apply a specific model.
               # 3. divide the data.
                sidebarPanel(
                  tags$form(
                   selectInput("model", "please specifiy the model",
                               c("ANN" = "ANN",
                               "ARIMA" = "ARIMA",
                               "HoltWinters" = "HoltWinters",
                               "HybridModel" = "HybridModel",
                               "STLF" = "STLF",
                               "TBATS" = "TBATS"
                    )),
                   selectInput("freq", "please specifiy the data frequency",
                                c("24" = 24,
                                  "168" = 168,
                                  "365" = 365,
                                  "7866" = 7866
                   ),selected = 24),
                   selectizeInput(
                     'xreg', 'please select regressor',
                     choices = state.name, multiple = TRUE
                   ),
                   actionButton("applymodel","Apply")
               )),
               #main panel of tabpanel 3
               mainPanel(

                tags$article(
                #textOutput("modelData")
                verbatimTextOutput("modelData")
                 ),
                 tags$hr(),
                 tableOutput("modelData2")

                 )
             )
    ),
#end of main panel 3 ####################################
##########################################################

    tabPanel("Forecast Plot",
             titlePanel("Forecasting Polt"),
             sidebarLayout(
               sidebarPanel(
                 tags$form(
                  selectInput("FP", "please specifiy the Forecasting period",
                             c("24" = 24,
                               "168" = 168,
                               "365" = 365,
                               "7866" = 7866
                             ),selected = 24),
                  downloadButton('forecastData', 'Download Data'),
                  actionButton("forecastAction","Plot")
              )),

               mainPanel(
                 plotOutput("forecastPlot"),
                 tags$hr(),
                 dataTableOutput('forecastTables')

               )
             )#sidebar layout
    ),
#end of main panel 3 ####################################
##########################################################
    tabPanel("Residuals",
             titlePanel("Residuals"),
             sidebarLayout(
               sidebarPanel(
                 tags$p('if you want to download the data'),
                 downloadButton('downloadRes', 'Download Data')
                 ),
               mainPanel(
                 plotOutput('residualsPlot'),
                tags$hr(),
                 dataTableOutput('residualsTables')
               )
             )#sidebar layout
    ),
#end of main panel 5 ####################################
##################About###############################
    tabPanel("About",
             titlePanel("About"),
             mainPanel(

               tags$hr()

             )
    )
  )#end tabset panel

)#end fluidpanel
)


# The experiments are called form this script
# It loads the data, call the Gibbs sampler,
# and saves the traces in files for further analysis
# and evaluation of thread length predictions in the test set
# author: Alberto Lumbreras
#######################################################
experiment <- function(nthreads.train, dataset, model, nsamples, K=5){
    source('gibbs_dual.r')

    # Load data
    ######################################
    data.dir <- paste0('./data/', dataset, '/')
    df <- read.table(paste0(data.dir, 'data_users_50.csv'), sep='\t', header=TRUE)
    z_init <- df$z+1
    if(dataset=='iris'){
      A <- t(df[,2:4])
    }else{
      A <- t(df[,2:3])
    }
    B <- t(df$b)

    y <- read.table(paste0(data.dir, 'train_lengths_50.csv'), sep='\t', header=TRUE)
    P <- read.table(paste0(data.dir, 'train_participations_50.csv'), sep='\t', header=TRUE)
    nthreads <- dim(P)[2]

    # Select a random subset of threads for training the model
    idx.train <- sample(nthreads, nthreads.train)
    y <- y[idx.train,]
    P <- P[,idx.train]

    # Initialization of cluster assignments
    ########################################
    # Non recommended.
    z_init <- rep(1, dim(B)[2])

    # Recommended (bit not a good initialization technique either!).
    z_init <- sample(10, dim(B)[2], replace = TRUE)

    # A la k-means (more clever)
    z_init <- kmeans(t(A), 10)$cluster

    # guarantees that there are no gaps!
    # http://stackoverflow.com/questions/35141155/create-n-random-integers-with-no-gaps
    tb <- table(z_init);
    z_init <- rep(seq(tb),tb)

    # run !
    #############
    if(model=="DP"){
      res <- gibbs(A, B, P, y, z_init=z_init, iters=nsamples, DP=TRUE, views='both')
    }
    if(model=="fixed"){
      z_init <- kmeans(t(A), K)$cluster
      res <- gibbs(A, B, P, y, z_init=z_init, iters=nsamples, DP=FALSE, views='both')
    }
    if(model=="single"){
      # Not implemented yed/
      # In the paper, z=1 for all and not sample z (1 cluster)
      # We should try with CRP in the regression model
      # but likelihood co,puted only with coefficients
      # sample_z and pass behavior view params
      z_init <- kmeans(t(A), K)$cluster
      res <- gibbs(A, B, P, y, z_init=z_init, iters=nsamples, DP=TRUE, views='behaviors')
    }

    # Save traces to files
    #######################
    # do not overwrite old experiments
    experiment.path <- file.path("out", dataset, paste0(model, "_threads_", nthreads.train, "_", nsamples))
    i <- 1
    while(TRUE){
      if(dir.exists(paste0(experiment.path, '-', i))){
          i <- i+1
      }
      else{
        experiment.path <- paste0(experiment.path, '-', i)
        break
      }
    }
    traces.path <- file.path(experiment.path, "traces")
    dir.create(file.path(traces.path), recursive=TRUE)
    for(i in 1:length(res)){
      tr.name <- paste0(names(res)[i], '.trc')
      write.matrix(as.data.frame(res[[i]]), file=file.path(traces.path,tr.name))
    }
}

library(doParallel)
library(foreach)
library(parallel)

# Choose one of the datasers
dataset = 'confused_features'
dataset = 'clear'

dataset <- 'disagreement'
dataset <- 'agreement'
dataset = 'iris'

nsamples <- 20000
<<<<<<< HEAD
#i.seq <- rep(seq(10,100, by=10), 3)
i.seq <- rep(c(40), 5)
ncores <- detectCores() - 2
cl<-makeCluster(ncores, outfile="", port=11439)
registerDoParallel(cl)
pck = c('abind', 'MASS', 'mvtnorm', 'mixtools', 'coda', 'ars')

foreach(i=i.seq, .packages = pck)%dopar%experiment(i, dataset, 'single', nsamples, K=5)
#foreach(i=i.seq, .packages = pck)%dopar%experiment(i, dataset, 'DP', nsamples, K=5)
#foreach(i=i.seq, .packages = pck)%dopar%experiment(i, dataset, 'fixed', nsamples, K=5)
=======
i.seq <- rep(seq(20,100, by=10), 1)
ncores <- detectCores() - 2
cl<-makeCluster(ncores, outfile="", port=11439)
registerDoParallel(cl)
pck = c('abind', 'MASS', 'mvtnorm', 'mixtools', 'coda')

foreach(i=i.seq, .packages = pck)%dopar%experiment(i, dataset, 'single', nsamples, K=5)
foreach(i=i.seq, .packages = pck)%dopar%experiment(i, dataset, 'DP', nsamples, K=5)
foreach(i=i.seq, .packages = pck)%dopar%experiment(i, dataset, 'fixed', nsamples, K=5)
>>>>>>> cb9c7e3e353728a21e70ae04da064f57e5d0622a

stopCluster(cl)


###MUST SAVE TABLE AND IMAGE OUTPUTS!

#wd="D:/Dropbox/current work/IUCN_threats_analysis_outputs/"
wd="C:/Users/Kaipo Dye/Dropbox/PICCC/IUCN_threats_analysis_outputs/"
setwd(wd)
library(stringi)
species_types=c("critically endangered", "endangered", "least concern")
species_types_short=c("CR", "EN", "LC")

for (i in 1:length(species_types)){
  species_type=species_types[i]
  if (i==1){
    all_spp_data=read.csv(paste0("data/",species_type,".csv"))#
    all_spp_data=cbind(all_spp_data, status=species_types_short[i])
  }else{
    jnk=read.csv(paste0("data/",species_type,".csv")) #
    jnk=cbind(jnk, status=species_types_short[i])
    all_spp_data=rbind(all_spp_data, jnk)
  }
}

#all_threats
for (i in 1:length(species_types)){
  species_type=species_types[i]
  if (i==1){
    all_threat_data=read.csv(paste0("threat_matrix_",species_type,".csv"), header = T, row.names = NULL, check.names = FALSE)#
    #all_threat_data=cbind(all_threat_data, status=species_types_short[i])
  }else{
    jnk=read.csv(paste0("threat_matrix_",species_type,".csv"), header = T, row.names = NULL, check.names = FALSE)#
    #jnk=cbind(jnk, status=species_types_short[i])
    all_threat_data=rbind(all_threat_data, jnk)
  }
}

threats=as.character(c(1:12))
jnk=c(names(all_threat_data)[1],threats)
all_threat_data_summary=all_threat_data[,jnk]
n_threats=rowSums(all_threat_data[,threats])
all_threat_data_summary=cbind(all_threat_data_summary,n_threats)
#

#total threats per year
plot(as.numeric(all_spp_data$Year.assessed), all_threat_data_summary$n_threats)

#CC threats per year (hist)
#number of threats assessed have been going up, but not necessarily a climate bias
hist(all_spp_data[all_threat_data_summary[,"n_threats"]>0,"Year.assessed"])
hist(all_spp_data[all_threat_data_summary[,"11"]>0,"Year.assessed"])
plot(all_threat_data_summary[,"n_threats"], all_threat_data_summary[,"11"])
all_threat_freq=as.data.frame(table(all_spp_data[all_threat_data_summary[,"n_threats"]>0,"Year.assessed"]))
CC_threat_freq=as.data.frame(table(all_spp_data[all_threat_data_summary[,"11"]>0,"Year.assessed"]))
names(all_threat_freq)=c("Year", "All.Species.count")
names(CC_threat_freq)=c("Year", "CC.Species.count")
all_threat_freq$Year=as.numeric(as.character(all_threat_freq$Year))
CC_threat_freq$Year=as.numeric(as.character(CC_threat_freq$Year))
minYr=min(c(all_threat_freq$Year,CC_threat_freq$Year))
maxYr=max(c(all_threat_freq$Year,CC_threat_freq$Year))
all_yr_freq=data.frame(Year=c(minYr:maxYr))
#c(minYr:maxYr) %in% all_threat_freq$Year
all_yr_freq2=merge(all_yr_freq, all_threat_freq, by="Year", all.x =T)
all_yr_freq2=merge(all_yr_freq2, CC_threat_freq, by="Year", all.x =T)
all_yr_freq2[is.na(all_yr_freq2)]=0

library(plyr)
library(reshape2)
# melt the data frame for plotting
data.m <- melt(all_yr_freq2, id.vars='Year')

library(ggplot2)
# plot everything
ggplot(data.m, aes(Year, value)) +
  geom_bar(aes(fill = variable), position = "dodge", stat="identity")

plot(all_yr_freq2$All.Species.count, all_yr_freq2$CC.Species.count)

#CC threats per year plot
plot(as.numeric(all_spp_data$Year.assessed), all_threat_data_summary[,"11"])

#two way anova
aovData=cbind(all_spp_data, all_threat_data_summary)
aovData=cbind(aovData, CC_threat=aovData[,"11"]>0)
aovData_wThreat=aovData[aovData$n_threats>0,]
int <- aov(aovData_wThreat$n_threats ~ aovData_wThreat$CC_threat*aovData_wThreat$status*aovData_wThreat$Year.assessed)
#int <- aov(aovData_wThreat$n_threats ~ aovData_wThreat$CC_threat*aovData_wThreat$status)
summary(int)
plot(int)

glmFit=glm(aovData_wThreat$n_threats ~ aovData_wThreat$CC_threat*aovData_wThreat$status)
summary(glmFit)
plot(glmFit)

older/older version of repository/3_threats and year.r


#' Choose initial parameters for direct effects on X and Y
#'
#' @param nsnp_x nsnp_x
#' @param var_gx.x var_gx.x
#' @param var_x.y var_x.y
#' @param var_gx.y var_gx.y=0
#' @param nsnp_y nsnp_y=0
#' @param var_gy.y var_gy.y=0
#' @param mu_gx.y mu_gx.y=0
#' @param var_gy.x var_gy.x=0
#' @param mu_gy.x mu_gy.x=0
#' @param prop_gy.x prop_gy.x=1
#' @param prop_gx.y prop_gx.y=1
#'
#' @export
#' @return List of model parameters
init_parameters <- function(nsnp_x, var_gx.x, var_x.y, var_gx.y=0, nsnp_y=0, var_gy.y=0, mu_gx.y=0, var_gy.x=0, mu_gy.x=0, prop_gy.x=1, prop_gx.y=1)
{
	parameters <- list(
		# Causal effect
		var_x.y = var_x.y,

		# Direct effects on x
		nsnp_x = nsnp_x,
		var_gx.x = var_gx.x,
		var_gx.y = var_gx.y,
		mu_gx.y = mu_gx.y,
		prop_gx.y = prop_gx.y,

		nsnp_y = nsnp_y,
		var_gy.y = var_gy.y,
		var_gy.x = var_gy.x,
		mu_gy.x = mu_gy.x,
		prop_gy.x = prop_gy.x,
		u = list()
	)
	return(parameters)
}

#' Add confounder variables and their instruments
#'
#' @param parameters Output from \code{init_parameters}
#' @param nsnp_u nsnp_u
#' @param var_u.x var_u.x
#' @param var_u.y var_u.y
#' @param var_gu.u var_gu.u
#'
#' @export
#' @return List of model parameters
add_u <- function(parameters, nsnp_u, var_u.x, var_u.y, var_gu.u)
{
	nom <- "u"
	if(var_u.x == 0 & var_u.y != 0) nom <- "b"
	if(var_u.x != 0 & var_u.y == 0) nom <- "a"
	i <- length(parameters$u) + 1
	parameters$u[[i]] <- list(
		nsnp_u = nsnp_u,
		var_u.x = var_u.x,
		var_u.y = var_u.y,
		var_gu.u = var_gu.u,
		name_u = nom
	)
	return(parameters)
}

#' Sample the actual effects based on initial parameters
#'
#' @param parameters Output from \code{init_parameters} or \code{add_u}
#'
#' @export
#' @return List of effect parameters
sample_system_effects <- function(parameters)
{
	nu <- length(parameters$u)
	if(nu > 0)
	{
		for(i in 1:nu)
		{
			parameters$u[[i]]$eff_gu.u <- choose_effects(parameters$u[[i]]$nsnp_u, parameters$u[[i]]$var_gu.u)
			parameters$u[[i]]$eff_u.x <- choose_effects(1, parameters$u[[i]]$var_u.x)
			parameters$u[[i]]$eff_u.y <- choose_effects(1, parameters$u[[i]]$var_u.y)
		}
	}

	# Make genetic effects for x instruments
	parameters$eff_gx.x <- choose_effects(parameters$nsnp_x, parameters$var_gx.x)

	# Make genetic effects for y instruments
	parameters$eff_gy.y <- choose_effects(parameters$nsnp_y, parameters$var_gy.y)

	# Create pleiotropic effects for some proportion of the effects
	# X-Y
	nchoose <- round(parameters$nsnp_x * parameters$prop_gx.y)
	ind <- sample(1:parameters$nsnp_x, nchoose, replace=FALSE)
	parameters$eff_gx.y <- rep(0, parameters$nsnp_x)
	if(nchoose > 0)
	{
		parameters$eff_gx.y[ind] <- choose_effects(nchoose, parameters$var_gx.y, mua=parameters$mu_gx.y)
	}

	# Create pleiotropic effects for some proportion of the effects
	# Y-X
	nchoose <- round(parameters$nsnp_y * parameters$prop_gy.x)
	ind <- sample(1:parameters$nsnp_y, nchoose, replace=FALSE)
	parameters$eff_gy.x <- rep(0, parameters$nsnp_y)
	if(nchoose > 0)
	{
		parameters$eff_gy.x[ind] <- choose_effects(nchoose, parameters$var_gy.x, mua=parameters$mu_gy.x)
	}

	parameters$eff_u.x <- sapply(parameters$u, function(x) choose_effects(1, x$var_u.x))
	parameters$eff_u.y <- sapply(parameters$u, function(x) choose_effects(1, x$var_u.y))
	parameters$eff_x.y <- sqrt(parameters$var_x.y)

	return(parameters)
}

#' Simulate individual level data from initial parameters
#'
#' @param parameters Output from \code{init_parameters} or \code{add_u}
#' @param nid Sample size to generate
#'
#' @export
#' @return List of matrices and vectors that represent individual level data
simulate_population <- function(parameters, nid)
{
	Gx <- matrix(rbinom(parameters$nsnp_x * nid, 2, 0.5), nid, parameters$nsnp_x)

	Gy <- matrix(rbinom(parameters$nsnp_y * nid, 2, 0.5), nid, parameters$nsnp_y)

	U <- lapply(parameters$u, function(param)
	{
		G <- matrix(rbinom(param$nsnp_u * nid, 2, 0.5), nid, param$nsnp_u)
		u <- make_phen(param$eff_gu.u, G)
		return(list(p=u, G=G, nom=param$name_u))
	})

	bx <- parameters$eff_gx.x
	by <- parameters$eff_gx.y

	Gt <- Gx
	if(parameters$nsnp_y > 0)
	{
		bx <- c(bx, parameters$eff_gy.x)
		by <- c(by, parameters$eff_gy.y)
		Gt <- cbind(Gt, Gy)
	}

	if(length(parameters$u) > 0)
	{
		bx <- c(bx, sapply(parameters$u, function(x) x$eff_u.x))
		by <- c(by, sapply(parameters$u, function(x) x$eff_u.y))
		Gt <- cbind(Gt, do.call(cbind, lapply(U, function(x) x$p)))
	}
	by <- c(by, parameters$eff_x.y)

	x <- make_phen(bx, Gt)
	y <- make_phen(by, cbind(Gt, x))

	return(list(
		y=y,
		x=x,
		Gx=Gx,
		Gy=Gy,
		U=U
	))

}

#' Estimate the effects of all SNPs on all phenotypes
#'
#' @param sim Output from \code{simulate_population}
#'
#' @export
#' @return Lists of SNP-trait effect estimates
estimate_system_effects <- function(sim)
{
	# Get effects of all X SNPs

	l <- list()

	gx.x <- gwas(sim$x, sim$Gx)
	gx.x$inst <- "x"
	gx.x$snp <- paste0(1:nrow(gx.x), "x")

	gx.y <- gwas(sim$y, sim$Gx)
	gx.y$inst <- "x"
	gx.y$snp <- paste0(1:nrow(gx.y), "x")

	gx <- gx.x
	gy <- gx.y

	# Get effects of all SNPs on Y

	if(ncol(sim$Gy) > 0)
	{
		gy.x <- gwas(sim$x, sim$Gy)
		gy.x$inst <- "y"
		gy.x$snp <- paste0(1:nrow(gy.x), "y")
		gx <- rbind(gx, gy.x)

		gy.y <- gwas(sim$y, sim$Gy)
		gy.y$inst <- "y"
		gy.y$snp <- paste0(1:nrow(gy.y), "y")
		gy <- rbind(gy, gy.y)
	}

	nconf <- length(sim$U)
	if(nconf > 0)
	{
		gu.x <- list()
		gu.y <- list()
		gx.u <- list()
		gy.u <- list()
		gu.u <- list()
		for(i in 1:nconf)
		{
			gu.u[[i]] <- gwas(sim$U[[i]]$p, sim$U[[i]]$G)
			gu.u[[i]]$inst <- paste0("u", i)
			gu.u[[i]]$snp <- paste0(1:nrow(gu.u[[i]]), gu.u[[i]]$inst)

			gu.x[[i]] <- gwas(sim$x, sim$U[[i]]$G)
			gu.x[[i]]$inst <- paste0("u", i)
			gu.x[[i]]$snp <- paste0(1:nrow(gu.x[[i]]), gu.x[[i]]$inst)

			gx.u[[i]] <- gwas(sim$U[[i]]$p, sim$Gx)
			gx.u[[i]]$inst <- "x"
			gx.u[[i]]$snp <- paste0(1:nrow(gx.u[[i]]), gx.u[[i]]$inst)

			gu.y[[i]] <- gwas(sim$y, sim$U[[i]]$G)
			gu.y[[i]]$inst <- paste0("u", i)
			gu.y[[i]]$snp <- paste0(1:nrow(gu.y[[i]]), gu.y[[i]]$inst)

			if(ncol(sim$Gy) > 0)
			{
				gy.u[[i]] <- gwas(sim$U[[i]]$p, sim$Gy)
				gy.u[[i]]$inst <- "y"
				gy.u[[i]]$snp <- paste0(1:nrow(gy.u[[i]]), gy.u[[i]]$inst)
			}
		}
		gx <- rbind(gx, dplyr::bind_rows(gu.x))
		gy <- rbind(gy, dplyr::bind_rows(gu.y))
		gu <- list()
		for(i in 1:nconf)
		{
			if(ncol(sim$Gy) > 0)
			{
				gu[[i]] <- rbind(gx.u[[i]], gy.u[[i]], gu.u[[i]])
			} else {
				gu[[i]] <- rbind(gx.u[[i]], gu.u[[i]])
			}
		}
		names(gu) <- paste0("u", 1:nconf)
		l <- gu
	}
	l$x <- gx
	l$y <- gy
	return(l)
}

#' Wrapper for simulation pipeline
#'
#' Based on the parameters specified this function will call \code{init_parameters}, \code{add_u}, \code{sample_system_effects}, \code{simulate_population} and \code{estimate_system_effects}. A separate population is generated for each phenotype (x, y and each of u) to allow 2SMR and PRS analyses
#'
#' @param nidx number of individuals for x
#' @param nidy number of individuals for y
#' @param nidu Default=0 If 0 then don't simulate separate populations for the u variables
#' @param nu Default=0 Number of confounders influencing x and y
#' @param na Default=0 Number of traits upstream of x
#' @param nb Default=0 Number of traits upstream of y
#' @param var_x.y var in y explained by x
#' @param nsnp_x nsnp influencing x
#' @param var_gx.x variance in x explained by instruments for x
#' @param var_gx.y Default=0
#' @param mu_gx.y Default=0
#' @param prop_gx.y Default=1
#' @param nsnp_y Default=0
#' @param var_gy.y Default=0
#' @param var_gy.x Default=0
#' @param mu_gy.x Default=0
#' @param prop_gy.x Default=1
#'
#' @export
#' @return List of effects across system
create_system <- function(nidx, nidy, nidu=0, nu=0, na=0, nb=0, var_x.y, nsnp_x, var_gx.x, var_gx.y=0, mu_gx.y=0, prop_gx.y=1, nsnp_y=0, var_gy.y=0, var_gy.x=0, mu_gy.x=0, prop_gy.x=1)
{
	parameters <- init_parameters(nsnp_x=nsnp_x, nsnp_y=nsnp_y, var_gx.x=var_gx.x, var_gy.y=var_gy.y, var_x.y=var_x.y, var_gx.y=var_gx.y, mu_gx.y=mu_gx.y, prop_gx.y=prop_gx.y, var_gy.x=var_gy.x, mu_gy.x=mu_gy.x, prop_gy.x=prop_gy.x)
	if(nu > 0)
	{
		for(i in 1:nu)
		{
			parameters <- add_u(
				parameters,
				nsnp_u=sample(5:30, 1),
				var_u.x=stats::runif(1, min=0.01, max=0.1),
				var_u.y=stats::runif(1, min=0.01, max=0.1),
				var_gu.u=stats::runif(1, min=0.02, 0.2)
			)
		}
	}
	if(na > 0)
	{
		for(i in 1:na)
		{
			parameters <- add_u(
				parameters,
				nsnp_u=sample(5:30, 1),
				var_u.x=stats::runif(1, min=0.01, max=0.1),
				var_u.y=0,
				var_gu.u=stats::runif(1, min=0.02, 0.2)
			)
		}
	}
	if(nb > 0)
	{
		for(i in 1:nb)
		{
			parameters <- add_u(
				parameters,
				nsnp_u=sample(5:30, 1),
				var_u.x=0,
				var_u.y=stats::runif(1, min=0.01, max=0.1),
				var_gu.u=stats::runif(1, min=0.02, 0.2)
			)
		}
	}

	parameters <- sample_system_effects(parameters)

	message("X")
	pop <- simulate_population(parameters, nidx)
	x <- estimate_system_effects(pop)

	message("Y")
	pop <- simulate_population(parameters, nidy)
	y <- estimate_system_effects(pop)

	out <- list(x=x, y=y, parameters=parameters)

	if(nidu > 0)
	{
		u <- list()
		if(nu > 0)
		{
			for(i in 1:nu)
			{
				message("U: ", i, " of ", nu)
				pop <- simulate_population(parameters, nidu)
				u[[i]] <- estimate_system_effects(pop)
			}
		}

		a <- list()
		if(na > 0)
		{
			for(i in 1:na)
			{
				message("A: ", i, " of ", na)
				pop <- simulate_population(parameters, nidu)
				a[[i]] <- estimate_system_effects(pop)
			}
		}

		b <- list()
		if(nb > 0)
		{
			for(i in 1:nb)
			{
				message("B: ", i, " of ", nb)
				pop <- simulate_population(parameters, nidu)
				b[[i]] <- estimate_system_effects(pop)
			}
		}
		u <- c(u, a, b)
		names(u) <- paste0("u", 1:length(u))
		out$u <- u
	}
	return(out)
}

#' Apply MR tests to system
#'
#'
#' @param ss Output from create_syste,
#' @param id string denoting simulation ID
#'
#' @export
#' @return List
test_system <- function(ss, id="test")
{
	out <- list()

	dx <- merge_exp_out(ss$x$x, ss$y$y)
	dx$exposure <- paste0("X:", id)
	dx$outcome <- paste0("Y:", id)
	dx$id.exposure <- paste0("X:", id)
	dx$id.outcome <- paste0("Y:", id)

	dy <- merge_exp_out(ss$y$y, ss$x$x)
	dy$exposure <- paste0("Y:", id)
	dy$outcome <- paste0("X:", id)
	dy$id.exposure <- paste0("Y:", id)
	dy$id.outcome <- paste0("X:", id)

	# Oracle
	ox <- subset(dx, grepl("x", SNP))
	out$ox <- try(TwoSampleMR::mr_wrapper(ox)[[1]])
	oy <- subset(dy, grepl("y", SNP))
	out$oy <- try(TwoSampleMR::mr_wrapper(oy)[[1]])

	# Empirical
	ex <- subset(dx, pval.exposure < 5e-8)
	out$ex <- try(TwoSampleMR::mr_wrapper(ex)[[1]])
	ey <- subset(dy, pval.exposure < 5e-8)
	out$ey <- try(TwoSampleMR::mr_wrapper(ey)[[1]])

	param <- expand.grid(
		hypothesis = c("x", "y"),
		selection = c("e", "o"),
		type = c("valid", "reverse", "confounder")
	)
	o <- list()
	for(i in 1:nrow(param))
	{
		o[[i]] <- dplyr::tibble(
			hypothesis = param$hypothesis[i],
			selection = param$selection[i],
			type = param$type[i],
			measure = c("nofilter", "outlier", "steiger", "both"),
			counts = get_counts(
				param$type[i],
				param$hypothesis[i],
				get(paste0(param$selection[i], param$hypothesis[i])),
				out[[paste0(param$selection[i], param$hypothesis[i])]]
			)
		)
	}

	out$instrument_validity <- dplyr::bind_rows(o) %>% dplyr::group_by(hypothesis, selection, type) %>% dplyr::mutate(n=dplyr::first(counts), pcounts=counts/n)
	out$instrument_validity$id <- id

	# Best model
	out$ex$estimates <- best_model(out$ex$estimates, ss$parameters$eff_x.y)
	out$ox$estimates <- best_model(out$ox$estimates, 0)

	return(out)
}

get_counts <- function(type, hyp, dat, res)
{
	if(type == "valid")
	{
		node = hyp
	} else if(type == "reverse") {
		node = ifelse(hyp=="x", "y", "x")
	} else {
		node = "u"
	}
	c(
		nrow(res$snps_retained %>% subset(grepl(node, SNP))),
		nrow(subset(res$snps_retained, outlier) %>% subset(grepl(node, SNP))),
		nrow(subset(res$snps_retained, steiger) %>% subset(grepl(node, SNP))),
		nrow(subset(res$snps_retained, both) %>% subset(grepl(node, SNP)))
	)
}

best_model <- function(res, bxy)
{
	res$beta_correct <- res$ci_low <= bxy & res$ci_upp >= bxy
	res$beta_best <- FALSE
	res$beta_best[which.min(abs(res$b - bxy))] <- TRUE
	res$pval_sig <- res$pval < 0.05
	res$pval_lowest <- FALSE
	res$pval_lowest[which.min(res$pval)] <- TRUE
	res$pval_highest <- FALSE
	res$pval_highest[which.max(res$pval)] <- TRUE
	return(res)
}


x<-read.table("infile.txt", header=TRUE)
a<-x$plus
b<-floor(9*(a-min(a))/(max(a)-min(a)))
write.table(b, "BDI.txt", quote=FALSE, row.names=FALSE,col.names=FALSE)


#' dmrff
#'
#' Identifying differentially methylated regions efficiently with power and control.
#'
#' Note: the function checks that
#' @param estimate Vector of association effect estimates
#' (corresponds to rows of \code{methylation}).
#' @param se Vector of standard errors of the effect estimates.
#' @param p.value Vector of p-values.
#' @param methylation Methylation matrix (rows=features, columns=samples).
#' @param chr Feature chromosome (corresponds to rows of \code{methylation}).
#' @param pos Feature chromosome position.
#' @param p.cutoff Unadjusted p-value cutoff for membership in a candidate DMR
#' (Default: 0.05).
#' @param maxgap Maximum distance between consecutive features (Default: 500bp).
#' @param verbose If \code{TRUE} (default), then output status messages.
#' @return A data frame listing all candidate regions and their summary statistics.
#'
#' @examples
#'
#' dmrs <- dmrff(estimate, ## effect estimate for each CpG site
#'               se,       ## standard error of the estimate for each CpG site
#'               p.value,  ## p-value
#'               methylation, ## methylation matrix
#'               chr,      ## chromosome of each CpG site
#'               pos)      ## position of each CpG site
#'
#' dmrs[which(dmrs$p.adjust < 0.05 & dmrs$n > 1),]
#'
#' @export
dmrff <- function(estimate, se, p.value, methylation, chr, pos,
                  maxgap=500, p.cutoff=0.05, verbose=T,debug=F) {
    stopifnot(is.vector(estimate))
    stopifnot(is.vector(se))
    stopifnot(is.vector(p.value))
    stopifnot(is.matrix(methylation))
    stopifnot(is.vector(chr))
    stopifnot(is.vector(pos))
    stopifnot(length(estimate) == length(se))
    stopifnot(length(estimate) == nrow(methylation))
    stopifnot(length(estimate) == length(p.value))
    stopifnot(length(estimate) == length(chr))
    stopifnot(length(estimate) == length(pos))

    if (debug) browser()

    # sort input by chromosomal position
    idx <- order(chr,pos)
    sorted <- identical(idx, 1:length(idx))
    if (!sorted) {
        estimate <- estimate[idx]
        se <- se[idx]
        p.value <- p.value[idx]
        chr <- chr[idx]
        pos <- pos[idx]
        methylation <- methylation[idx,,drop=F]
    }

    ## scale summary stats as if methylation was standarized
    methylation.sd <- row.sds(methylation,na.rm=T)
    estimate <- estimate/methylation.sd
    se <- se/methylation.sd

    # identify candidate regions
    candidates <- dmrff.candidates(estimate=estimate,
                                   p.value=p.value,
                                   chr=chr,
                                   pos=pos,
                                   maxgap=maxgap,
                                   p.cutoff=p.cutoff,
                                   verbose=verbose)

    if (is.null(candidates)) {
        return (NULL)
    }

    # identify sub-regions that maximize statistical significance
    stats <- shrink.candidates(candidates$start.idx, candidates$end.idx,
                               function(start.idx,end.idx) {
                                   idx <- start.idx:end.idx
                                   ivwfe.getz(estimate[idx], se[idx], methylation[idx,,drop=F])
                               })

    # calculate B and S statistics for each region (recall z=B/S)
    full <- do.call(rbind, parallel::mclapply(1:nrow(stats), function(i) {
        idx <- stats$start.idx[i]:stats$end.idx[i]
        ivwfe.stats(estimate[idx], se[idx], methylation[idx,,drop=F])
    }))

    stats$estimate <- stats$B <- full[,"B"]
    stats$se <- stats$S <- full[,"S"]

    collate.stats(stats, chr, pos, simple=!sorted)
}

collate.stats <- function(stats, chr, pos, simple=F) {
    stats <- with(stats, data.frame(chr=chr[start.idx],
                                    start=pos[start.idx],
                                    end=pos[end.idx],
                                    n=end.idx-start.idx+1,
                                    start.idx=start.idx,
                                    end.idx=end.idx,
                                    start.orig=start.orig,
                                    end.orig=end.orig,
                                    z.orig=z.orig,
                                    p.orig=2*pnorm(-abs(z.orig), lower.tail=T),
                                    B=B,
                                    S=S,
                                    estimate=estimate,
                                    se=se,
                                    z=z,
                                    p.value=2*pnorm(-abs(z), lower.tail=T)))
    number.tests <- length(chr) + calculate.number.shrink.tests(stats)
    stats$p.adjust <- pmin(1, stats$p.value * number.tests)
    if (simple)
        stats$start.idx <- stats$end.idx <- stats$start.orig <- stats$end.orig <- stats$z.orig <- stats$p.orig <- NULL
    stats
}


# Use Keras for a neural network instead of neuralnet

# Set environment variables
source("packrat/init.R")
# Interface with a local conda environment: this needs to be configured for each system
Sys.setenv("PATH" = paste0("/usr/local/cuda-10.2/bin:", Sys.getenv("HOME"), "/miniconda3/bin:", Sys.getenv("PATH")))
Sys.setenv(CUDA_HOME="/usr/local/cuda-10.2")
#Sys.setenv("LD_LIBRARY_PATH" = paste0(Sys.getenv("HOME"), "/miniconda3/envs/r-tensorflow/lib:", Sys.getenv("LD_LIBRARY_PATH")))
library(keras)
library(hydroGOF)

source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("pixel-based/utils/crossvalidation.r")
source("pixel-based/utils/subpixel-confusion-matrix.r") # Replace with package eventually
source("utils/accuracy-statistics.r")

Data.df.orig = LoadTrainingAndCovariates()
Data.df.orig = st_set_geometry(Data.df.orig, NULL)
# Manually rescale
Data.df = Data.df.orig
#Data.df = RescaleBasedOn(Data.df.orig, Data.df.orig, GetAllPixelCovars())
#Data.df = NAToMean(Data.df, GetAllPixelCovars())
Data.df[is.na(Data.df)] = -9999
#Data.df[is.na(Data.df)] = 0
Data.df = TidyData(Data.df, drop.cols=NULL)

# Validation data
Data.val = LoadValidationAndCovariates()
Data.val = st_set_geometry(Data.val, NULL)
#Data.val = RescaleBasedOn(Data.val, Data.df.orig, GetAllPixelCovars())
#Data.val = NAToMean(Data.val, GetAllPixelCovars())
Data.val[is.na(Data.val)] = -9999
#Data.val[is.na(Data.val)] = 0
Data.val = TidyData(Data.val, drop.cols=NULL) # Drops around 1050

TargetMatrix = as.matrix(Data.df[,GetCommonClassNames()])/100
CovarMatrix = as.matrix(Data.df[,GetAllPixelCovars()])

model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  #layer_dense(units = 128, activation = 'relu') %>%
  #layer_batch_normalization() %>%
  layer_dropout(rate = 0.5) %>%
  layer_dense(units = 64, activation = 'relu') %>%
  layer_batch_normalization() %>%
  layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'sigmoid') %>%
  compile(
    loss = 'mean_absolute_error',
    optimizer = optimizer_adam(lr = 0.0001, decay = 1e-5),
    #optimizer = optimizer_sgd(lr = 0.01, decay = 1e-4, momentum = 0.9, nesterov = TRUE),
    metrics = c('accuracy')
  )

# # define train/val set
#
#
# # train
# for (i in (1:300)){
#   history = fit(model, CovarMatrix[], TargetMatrix[], epochs = 1, batch_size = 128)
#   plot(history)
#
#   # save model state
# }

schedule = function(epoch, lr)
{
  # if(epoch==100) {
  #   print('reducing lr...')
  #   lr = lr / 10
  # }
  return(lr)
}

history = fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 256, validation_split=0.3)
              # callbacks=list(callback_learning_rate_scheduler(schedule),callback_reduce_lr_on_plateau(monitor = "val_loss", factor = 0.1,patience = 10)))
plot(history)

# evaluate
#score <- model %>% evaluate(x_test, y_test, batch_size = 128)
#score

ValidMatrix = as.matrix(Data.val[,GetAllPixelCovars()])
TruthMatrix = as.matrix(Data.val[,GetCommonClassNames()])
preds = predict(model, ValidMatrix)
colnames(preds) = colnames(TargetMatrix)
round(head(preds), 2)
rowSums(preds)

round(head(TruthMatrix), 2)
round(head(preds), 2)

Predictions = preds
Predictions[Predictions < 0] = 0
Predictions[Predictions > 1] = 1
Predictions = ScalePredictions(as.data.frame(Predictions*100), FALSE)
AccuracyStatisticsPlots(Predictions, Data.val[,GetCommonClassNames()]) # 29.7% RMSE, 12.5 MAE
SCM(Predictions/100, Data.val[,GetCommonClassNames()]/100, plot=TRUE, totals=TRUE) # OA 56±0 kappa 0.39±0.01
NSE(unlist(Predictions)/100, unlist(Data.val[,GetCommonClassNames()]/100)) # 0.02
PlotHex(Predictions, Data.val[,GetCommonClassNames()], "Neural networks, 2 hidden layers (128&64), sigmoid activation, adam optimiser")
PlotBox(Predictions, Data.val[,GetCommonClassNames()], main="Neural networks, 2 hidden layers (128&64), sigmoid activation, adam optimiser", binpredicted=TRUE)

## Try softmax activation

model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  #layer_dense(units = 128, activation = 'relu') %>%
  #layer_batch_normalization() %>%
  layer_dropout(rate = 0.5) %>%
  layer_dense(units = 64, activation = 'relu') %>%
  layer_batch_normalization() %>%
  layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'softmax') %>%
  compile(
    loss = 'mean_absolute_error',
    optimizer = optimizer_adam(lr = 0.0001, decay = 1e-5),
    #optimizer = optimizer_sgd(lr = 0.01, decay = 1e-4, momentum = 0.9, nesterov = TRUE),
    metrics = c('accuracy')
  )
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 256, validation_split=0.3)

preds = predict(model, ValidMatrix)
colnames(preds) = colnames(TargetMatrix)
Predictions = as.data.frame(preds*100)
AccuracyStatisticsPlots(Predictions, Data.val[,GetCommonClassNames()]) # 25.1% RMSE, 10.6 MAE, much better
SCM(Predictions/100, Data.val[,GetCommonClassNames()]/100, plot=TRUE, totals=TRUE) # OA 63±1 kappa 0.51±0.02
NSE(unlist(Predictions)/100, unlist(Data.val[,GetCommonClassNames()]/100)) # 0.30
PlotHex(Predictions, Data.val[,GetCommonClassNames()], "Neural networks, 2 hidden layers (128&64), softmax activation, adam optimiser")
PlotBox(Predictions, Data.val[,GetCommonClassNames()], main="Neural networks, 2 hidden layers (128&64), softmax activation, adam optimiser", binpredicted=TRUE)

## Try with NA set to 0
Data.df = Data.df.orig
#Data.df = RescaleBasedOn(Data.df.orig, Data.df.orig, GetAllPixelCovars())
#Data.df = NAToMean(Data.df, GetAllPixelCovars())
#Data.df[is.na(Data.df)] = -9999
Data.df[is.na(Data.df)] = 0
Data.df = TidyData(Data.df, drop.cols=NULL)

# Validation data
Data.val = LoadValidationAndCovariates()
Data.val = st_set_geometry(Data.val, NULL)
#Data.val = RescaleBasedOn(Data.val, Data.df.orig, GetAllPixelCovars())
#Data.val = NAToMean(Data.val, GetAllPixelCovars())
#Data.val[is.na(Data.val)] = -9999
Data.val[is.na(Data.val)] = 0
Data.val = TidyData(Data.val, drop.cols=NULL)

model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  #layer_dense(units = 128, activation = 'relu') %>%
  #layer_batch_normalization() %>%
  layer_dropout(rate = 0.5) %>%
  layer_dense(units = 64, activation = 'relu') %>%
  layer_batch_normalization() %>%
  layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'softmax') %>%
  compile(
    loss = 'mean_absolute_error',
    optimizer = optimizer_adam(lr = 0.0001, decay = 1e-5),
    #optimizer = optimizer_sgd(lr = 0.01, decay = 1e-4, momentum = 0.9, nesterov = TRUE),
    metrics = c('accuracy')
  )
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 256, validation_split=0.3)

preds = predict(model, ValidMatrix)
colnames(preds) = colnames(TargetMatrix)
Predictions = as.data.frame(preds*100)
AccuracyStatisticsPlots(Predictions, Data.val[,GetCommonClassNames()]) # 24.8% RMSE, 10.3 MAE, a bit better
SCM(Predictions/100, Data.val[,GetCommonClassNames()]/100, plot=TRUE, totals=TRUE) # OA 64±1 kappa 0.52±0.02
NSE(unlist(Predictions)/100, unlist(Data.val[,GetCommonClassNames()]/100)) # 0.31
PlotHex(Predictions, Data.val[,GetCommonClassNames()], "Neural networks, 2 hidden layers (128&64), softmax activation, adam optimiser, NA to 0")
PlotBox(Predictions, Data.val[,GetCommonClassNames()], main="Neural networks, 2 hidden layers (128&64), softmax activation, adam optimiser, NA to 0", binpredicted=TRUE)

# Remove dropouts
model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  #layer_dense(units = 128, activation = 'relu') %>%
  #layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 64, activation = 'relu') %>%
  layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'softmax') %>%
  compile(
    loss = 'mean_absolute_error',
    optimizer = optimizer_adam(lr = 0.0001, decay = 1e-5),
    #optimizer = optimizer_sgd(lr = 0.01, decay = 1e-4, momentum = 0.9, nesterov = TRUE),
    metrics = c('accuracy')
  )
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 256, validation_split=0.3)

preds = predict(model, ValidMatrix)
colnames(preds) = colnames(TargetMatrix)
Predictions = as.data.frame(preds*100)
AccuracyStatisticsPlots(Predictions, Data.val[,GetCommonClassNames()]) # 24.0% RMSE, 10.0 MAE, a bit better again
SCM(Predictions/100, Data.val[,GetCommonClassNames()]/100, plot=TRUE, totals=TRUE) # OA 65±1 kappa 0.54±0.02
NSE(unlist(Predictions)/100, unlist(Data.val[,GetCommonClassNames()]/100)) # 0.36
PlotHex(Predictions, Data.val[,GetCommonClassNames()], "Neural networks, 2 hidden layers (128&64), softmax, adam, NA to 0, no dropout")
PlotBox(Predictions, Data.val[,GetCommonClassNames()], main="Neural networks, 2 hidden layers (128&64), softmax, adam, NA to 0, no dropout", binpredicted=TRUE)

# try sgd
model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  #layer_dense(units = 128, activation = 'relu') %>%
  #layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 64, activation = 'relu') %>%
  layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'softmax') %>%
  compile(
    loss = 'mean_absolute_error',
    #optimizer = optimizer_adam(lr = 0.0001, decay = 1e-5),
    optimizer = optimizer_sgd(lr = 0.01, decay = 1e-4, momentum = 0.9, nesterov = TRUE),
    metrics = c('accuracy')
  )
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 256, validation_split=0.3)
# really bad overfitting

# Try more layers
model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  layer_dense(units = 64, activation = 'relu') %>%
  #layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 32, activation = 'relu') %>%
  layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'softmax') %>%
  compile(
    loss = 'mean_absolute_error',
    optimizer = optimizer_adam(lr = 0.0001, decay = 1e-5),
    #optimizer = optimizer_sgd(lr = 0.01, decay = 1e-4, momentum = 0.9, nesterov = TRUE),
    metrics = c('accuracy')
  )
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 256, validation_split=0.3)

preds = predict(model, ValidMatrix)
colnames(preds) = colnames(TargetMatrix)
Predictions = as.data.frame(preds*100)
AccuracyStatisticsPlots(Predictions, Data.val[,GetCommonClassNames()]) # 23.8% RMSE, 10.0 MAE, a slight bit better again
# On GPU with NA -9999 it's 23.4 RMSE, 9.6 MAE; back on CPU with NA -9999 it's 24.1 RMSE 9.9 MAE
SCM(Predictions/100, Data.val[,GetCommonClassNames()]/100, plot=TRUE, totals=TRUE) # OA 65±2 kappa 0.54±0.02
# GPU OA 66±1 kappa 0.56±0.02
NSE(unlist(Predictions)/100, unlist(Data.val[,GetCommonClassNames()]/100)) # 0.37 / GPU 0.39
PlotHex(Predictions, Data.val[,GetCommonClassNames()], "Neural networks, 3 hidden layers (128&64&32), softmax, adam, NA to 0, no dropout")
PlotBox(Predictions, Data.val[,GetCommonClassNames()], main="Neural networks, 3 hidden layers (128&64&32), softmax, adam, NA to 0, no dropout", binpredicted=TRUE)
write.csv(Predictions, "../data/pixel-based/predictions/nn-3layers-softmax-adam-9999na-nodropout.csv")
write.csv(Predictions, "../data/pixel-based/predictions/nn-3layers-softmax-adam-0na-nodropout.csv")

# Smaller batches to train for longer
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 32, validation_split=0.3, use_multiprocessing=TRUE, workers=12, shuffle = TRUE)

# Try nadam optimiser
model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  layer_dense(units = 64, activation = 'relu') %>%
  #layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 32, activation = 'relu') %>%
  layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'softmax') %>%
  compile(
    loss = 'mean_absolute_error',
    optimizer = optimizer_nadam(),
    metrics = c('accuracy')
  )
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 32, validation_split=0.3, shuffle = TRUE)

preds = predict(model, ValidMatrix)
colnames(preds) = colnames(TargetMatrix)
Predictions = as.data.frame(preds*100)
AccuracyStatisticsPlots(Predictions, Data.val[,GetCommonClassNames()]) # 22.9% RMSE, 9.28 MAE, a slight bit better again
SCM(Predictions/100, Data.val[,GetCommonClassNames()]/100, plot=TRUE, totals=TRUE) # OA 68±2 kappa 0.57±0.02
NSE(unlist(Predictions)/100, unlist(Data.val[,GetCommonClassNames()]/100)) # 0.41

# Try with dropout
model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  layer_dense(units = 64, activation = 'relu') %>%
  #layer_batch_normalization() %>%
  layer_dropout(rate = 0.5) %>%
  layer_dense(units = 32, activation = 'relu') %>%
  layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'softmax') %>%
  compile(
    loss = 'mean_absolute_error',
    optimizer = optimizer_nadam(),
    metrics = c('accuracy')
  )
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 32, validation_split=0.3, shuffle = TRUE)
# Not any better

# normalisation only
model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  layer_dense(units = 64, activation = 'relu') %>%
  layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 32, activation = 'relu') %>%
  layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'softmax') %>%
  compile(
    loss = 'mean_absolute_error',
    optimizer = optimizer_nadam(),
    metrics = c('accuracy')
  )
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 32, validation_split=0.3, shuffle = TRUE)

preds = predict(model, ValidMatrix)
colnames(preds) = colnames(TargetMatrix)
Predictions = as.data.frame(preds*100)
AccuracyStatisticsPlots(Predictions, Data.val[,GetCommonClassNames()]) # 22.1%/22.7 RMSE, 9.00/9.19 MAE, a slight bit better again
SCM(Predictions/100, Data.val[,GetCommonClassNames()]/100, plot=TRUE, totals=TRUE) # OA 69±2/68±1 kappa 0.59±0.02/0.57±0.02
NSE(unlist(Predictions)/100, unlist(Data.val[,GetCommonClassNames()]/100)) # 0.46/0.43
write.csv(Predictions, "../data/pixel-based/predictions/nn-3layers-softmax-nadam-9999na-nodropout.csv")

# Same but with all input data
model = keras_model_sequential() %>%
  layer_dense(units = 128, activation = 'relu', input_shape = c(67)) %>%
  #layer_dropout(rate = 0.5) %>%
  layer_batch_normalization() %>%
  layer_dense(units = 64, activation = 'relu') %>%
  layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 32, activation = 'relu') %>%
  layer_batch_normalization() %>%
  #layer_dropout(rate = 0.5) %>%
  layer_dense(units = 7, activation = 'softmax') %>%
  compile(
    loss = 'mean_absolute_error',
    optimizer = optimizer_nadam(),
    metrics = c('accuracy')
  )
fit(model, CovarMatrix, TargetMatrix, epochs = 100, batch_size = 32, shuffle = TRUE)
# It is much worse?! It seems that the validation is actually pretty useful to guide the optimiser


# This script creates diagnostics for models that have already been run through
# model.r.

# Resources:

# General diagnostics:
# https://betanalpha.github.io/assets/case_studies/rstan_workflow.html
# Summary: diagnostic code

# E-BMFI:
# https://betanalpha.github.io/assets/case_studies/pystan_workflow.html

# Strategies for divergences:
# https://dev.to/martinmodrak/taming-divergences-in-stan-models-5762
# Summary: change priors

# Identify divergent transitions
# https://mc-stan.org/users/documentation/case-studies/divergences_and_bias.html
# Summary: increase adapt delta or reparametrize (fit hierachical group
# parameter); example of reparametrizing;
# false negatives may be involved if divergent iterations are
# spreaded out (reduce adapt_delta);

#  Reparametrize to improve models for divergences
# https://mc-stan.org/docs/2_18/stan-users-guide/reparameterization-section.html
# Summary: "This reparameterization is helpful when there is not much data,
# because it separates the hierarchical parameters and lower-level
# parameters in the prior."
# Reparametrize for Cauchy, Student t-distribution,
# "Hierarchical Models and the Non-Centered Parameterization",

# TODO: Posterior predictive checks
# https://mc-stan.org/docs/2_25/stan-users-guide/simulating-from-the-posterior-predictive-distribution.html

source('2020-08-31-jsa-type-v2-ch2/02-model/init.r')

#### Get models

models <- list.dirs(dir_analysis_edie_model, recursive = F, full.names = F)
models <- models[!grepl("_|template|sanity-check", models)]

# OR predefine here
# models <- "HAL-E0-C4-I20000-A0.999-T12-F25-V0" # e.g. bad model
models <- "BGY-E1-C4-I20000-A0.9-T12-F25-V0"
models <- "BGY-E2-C4-I8000-A0.8-T12-F25-V0"

##### Diagnostics

# HIGH LEVEL DIAGNOSTICS -------------------------------------------------------

# can either run for ALL models in `models` or just choose 1 model to run
for (i in 1:length(models)) {
    chosen_model <- models[i]

    dir_model_folder <- paste0(dir_analysis_edie_model, chosen_model, "/")
    model_params <- parse_model_identifier(chosen_model)

    print(paste0("Checking for ", i , " -- ", chosen_model))

    ##### Load data

    # Original data
    data_raw <- read.csv(paste0(dir_model_folder, "data.csv"), na.strings=c(""))

    # Original data
    offset <- read.csv(paste0(dir_model_folder, "offset.csv"), na.strings=c(""))

    # R data
    data <- read_rdump(paste0(dir_model_folder, "count_info.data.R")) # as "data"

    # Model
    load(paste0(dir_model_folder, "fit.data"))                        # as "fit"

    ##### Diagnostics

    check_all_diagnostics(fit)
    print("-------------------------------------------------------------------")
    print("-------------------------------------------------------------------")
    print("-------------------------------------------------------------------")
}

# SPECIFIC DIAGNOSTICS FOR DIVERGENT ITERATIONS --------------------------------

# Param names
params_n <- names(fit)[!grepl("log_lik|lp", names(fit))]

# Using shinystan
# launch_shinystan(fit)

# Prepare data
params <- as.data.frame(rstan::extract(fit, permuted=FALSE))
params <- data.table(params)
params$div <- get_sampler_params(fit, inc_warmup=FALSE)[[1]][,'divergent__']
params$iter <- 1:dim(params)[1]

# Plot 1 parameter
plot(
    params$iter, params$`chain:1.sigma_phi`, col = c_dark, pch=16, cex=0.8,
    xlab="Iteration", ylab="log(phi)"
)

# Plot running means
params$running_means <- sapply(
    params$iter,
    function(n) mean(log(params$`chain:1.sigma_phi`)[1:n])
)

plot(
    params$iter, params$running_means, col=c_dark, pch=16, cex=0.8,
    xlab="Iteration", ylab="MCMC mean of log(phi)"
)

# Plot divergent iterations
plot(
    params[div == 1]$iter, params[div == 1]$`chain:1.sigma_phi`,
    col=c_dark, pch=16, cex=0.8, xlab="Iterations", ylab="sigma_phi",
)

points(
    params[div == 0,]$iter, params[div == 0,]$`chain:1.sigma_phi`,
    col="red", pch=16, cex=0.8
)

# Plot divergent iterations using pairs
l <- length(params_n); n <- 1; increase <- 5
pairs(fit, pars=params_n[n:(n+increase-1)]); n <- ifelse(n+increase>=l, l, n+increase)

##### Forecasting

# Allows forecasting for custom timeframes,
# even though data is trained only till 2019

# Convert data to df
obs <- convert_data_to_df(data)

# Get final count
last_observed_count <- data.table(obs)[
    , list(cml_value = max(cml_value)), by = "group"
]

# Prediction years
start_year <- 2020
n_years <- 5
max_year <- max(data_raw$year)
diff <- start_year - max_year
ftime <- ifelse(diff == 1, n_years, n_years + diff - 1)

# CREATE NEW FORECASTS
# Posterior forecasting
forecast <- mclapply(1:1000, mc.cores = 1, function(ii) {
	posterior_forecast(
        data = data, ftime = ftime, model = fit, offset = "constant"
    )
}) # represent COUNTS not cumulative!

# OR LOAD FORECAST PREDICTIONS
load(paste0(dir_model_folder, "forecast.data")) # as "forecast"
# Forecast data is was done up to a certain duration only, and
# represent COUNTS not cumulative!

# Convert forecast to df
# This differs from "forecast" in "forecast.data" as is CUMULATIVE not count.
forsim <- convert_forecast_to_df(data, data_raw, forecast)
forsim <- data.table(forsim)

# Subset for the years required
years <- (start_year):(start_year + n_years - 1) # not including current
forecast_subset <- forsim[index %in% years, ][order(group, sim, index)]

head(forecast_subset,100)

# Subset only the latest year
forecast_last_year <- forecast_subset[,
    list(
        value = max(value), # highest value
        index = max(index)  # for the last year
    ),
    by = c("group", "sim")]

# Summarize results
summary_forecast <- forecast_subset[,
    list(
        fore_mu = round(mean(value), 0),
        fore_lower = round(quantile(value, 0.1), 0) ,
        fore_upper = round(quantile(value, 0.9), 0)
    ),
    by = "group"
]

filename <- paste0(
    "output/output_custom-prediction-",
    min(years), "-", max(years),
    "-trained-till-", max(data_raw$year),
    ".csv"
)

output <- paste0(dir_model_folder, filename)

write.csv(summary_forecast, file = output, row.names = FALSE)


##--------------------------
## LOAD PACKAGES & FUNCTIONS
##--------------------------
library(dplyr)
library(ggplot2)
library(ggrepel)
library(RColorBrewer)
library(sars)

##--------------
## LOAD DATASETS
##--------------
islands.of.endemic.mammals <- read.csv("data/islands_of_endemic_mammals.txt", sep="")
head(islands.of.endemic.mammals)
islands.of.endemic.mammals <- unique(islands.of.endemic.mammals %>% select(ULM_ID, REGION, Area))

iucn.mammals.endemic.trait <- read.csv("data/iucn_mammals_endemic_trait.txt", sep="")
head(iucn.mammals.endemic.trait)
iucn.mammals.endemic.trait <- unique(iucn.mammals.endemic.trait %>% select(binomial, statut, category))

iucn.mammals.insular <- read.delim("data/iucn_mammals_insular.txt")
head(iucn.mammals.insular)
iucn.mammals.insular <- unique(iucn.mammals.insular %>% select(binomial, ulm_id))
colnames(iucn.mammals.insular)[2] <- "ULM_ID"

data.endemic.mammals <- left_join(iucn.mammals.endemic.trait, iucn.mammals.insular, by = "binomial")
data.endemic.mammals <- left_join(data.endemic.mammals, islands.of.endemic.mammals, by = "ULM_ID")
head(data.endemic.mammals)
unique(data.endemic.mammals$statut)
unique(data.endemic.mammals$category)
data.endemic.mammals <- data.endemic.mammals %>% filter(category != "EX")
data.endemic.mammals <- data.endemic.mammals[!is.na(data.endemic.mammals$REGION),]
length(unique(data.endemic.mammals$binomial))
length(unique(data.endemic.mammals$REGION))
length(unique(data.endemic.mammals$ULM_ID))

database.mammals.archip <- data.frame(matrix(nrow = 19, ncol = 5))
colnames(database.mammals.archip) <- c("Archip", "Area", "Nb.islands", "Nb.sp.tot", "Nb.sp.thr")
database.mammals.archip$Archip <- unique(data.endemic.mammals$REGION)

for (i in 1:nrow(database.mammals.archip)){

  sub.archip <- data.endemic.mammals[data.endemic.mammals$REGION == database.mammals.archip[i,1],]
  database.mammals.archip[i,4] <- length(unique(sub.archip$binomial))
  database.mammals.archip[i,3] <- length(unique(sub.archip$ULM_ID))

  sub.archip.area <- unique(sub.archip %>% select(ULM_ID, Area))
  database.mammals.archip[i,2] <- sum(sub.archip.area$Area)

  sub.archip.thr <- sub.archip[sub.archip$category != "DD" & sub.archip$category != "LC" & sub.archip$category != "NT",]
  database.mammals.archip[i,5] <- length(unique(sub.archip.thr$binomial))

  }

rm(i, sub.archip, sub.archip.area, sub.archip.thr)

database.mammals.thr.archip <- database.mammals.archip %>% select(Area, Nb.sp.thr)
colnames(database.mammals.thr.archip) <- c("Area","TD.brut")
rownames(database.mammals.thr.archip) <- database.mammals.archip$Archip

##----------------------------
## DIVERSITY AREA RELATIONSHIP
##----------------------------
sars_models() #list the 20 functions used
display_sars_models() #information list about the 20 functions

####Standardized Average Model####
## Averaged Model TD ##
TD.averaged <- database.mammals.thr.archip
TD.averaged$TD.obs <- TD.averaged$TD.brut/max(TD.averaged$TD.brut)

fit.TD <- sar_average(data = TD.averaged %>% select(Area, TD.obs))
#20 remaining models used to construct the multi  SAR:
#Power, PowerR, Extended Power model 1, Extended Power model 2, Persistence function 1, Persistence function 2, Logarithmic, Kobayashi, MMF, Monod, Negative exponential, Chapman Richards, Cumulative Weibull 3 par., Asymptotic regression, Rational function, Gompertz, Cumulative Weibull 4 par., Beta-P cumulative, Heleg(Logistic), Linear model

plot(fit.TD)
summary(fit.TD)
plot(fit.TD, type = 'multi', allCurves = FALSE)
plot(fit.TD, type='bar')
fit.TD$details
str(fit.TD)
fitted.TD.values <- fit.TD$mmi

####Residuals Computation####
database.mammals.thr.archip <- database.mammals.thr.archip[order(database.mammals.thr.archip$Area, decreasing=F), ]
database.mammals.thr.archip$TD.obs <- database.mammals.thr.archip$TD.brut/max(database.mammals.thr.archip$TD.brut)
database.mammals.thr.archip$Fitted.values <- fitted.TD.values
database.mammals.thr.archip$Residuals <- database.mammals.thr.archip$TD.obs - database.mammals.thr.archip$Fitted.values
database.mammals.thr.archip$Archip <- rownames(database.mammals.thr.archip)
colnames(database.mammals.thr.archip)
database.mammals.thr.archip <- database.mammals.thr.archip[,c(6, 1:5)]
rownames(database.mammals.thr.archip) <- NULL
database.mammals.thr.archip <- database.mammals.thr.archip[order(database.mammals.thr.archip$Residuals, decreasing=T), ]
database.mammals.thr.archip$Rank <- 1:nrow(database.mammals.thr.archip)
write.table(database.mammals.thr.archip, "outputs/DAR_TD_Archip.txt", row.names = FALSE)

####DATA FOR GRAPH####
class(fit.TD)
str(fit.TD)

data.graph.TD <- data.frame(matrix(nrow=nrow(database.mammals.thr.archip), ncol=3))
colnames(data.graph.TD) <- c("Area", "Diversity", "Curve")
data.graph.TD$Area <- database.mammals.thr.archip$Area
data.graph.TD$Diversity <- database.mammals.thr.archip$TD.obs
data.graph.TD <- data.graph.TD[order(data.graph.TD$Area, decreasing=F), ]
data.graph.TD$Curve <- fit.TD$mmi
data.graph.TD

class(data.graph.TD)
class(data.graph.TD$Area)
class(data.graph.TD$Diversity)
class(data.graph.TD$Curve)

data.graph.TD <- left_join(data.graph.TD, database.mammals.thr.archip, by="Area")
data.graph.TD <- data.graph.TD[,c(4, 8, 1:3)]
write.table(data.graph.TD, "outputs/DAR_TD_Archip_graph.txt", row.names = FALSE)


library(ggplot2)
library(plyr)

read_pc <- function(file) {
  pc <- list()
  pc$points <- rbind(c(0, 0), read.delim(file, comment.char = "#"))
  pc$fun <- approxfun(pc$points$WindSpeed, pc$points$Power, # nolint
                    method = "linear",
                    yleft = NA, yright = 0)
  attr <- strsplit(trimws(system(paste(
    "perl -e 'open FH,\"", file,
  "\";while(<FH>){@parts= /^# (.+): (.+) /;print \"@parts \";}'",
    sep = ""),
    intern = TRUE)),
    "\\s+")
  attr <- matrix(unlist(attr), ncol = 2, byrow = T)
  pc$attr <- as.list(attr[, 2])
  names(pc$attr) <- attr[, 1]
  pc$attr$Filename <- file # nolint
  pc$attr$RatedPower <- as.numeric(pc$attr$RatedPower) # nolint
  return(pc)
}
read_xml_pc <- function(file) {
  xml <- xmlTreeParse(file, useInternalNodes = TRUE) # nolint
  xml_data <- xmlToList(xml) # nolint
  pc <- list()
  pcs <- xml_data$wind_turbine_properties$power_curves
  for (i in 1 : length(pcs)) {
    if (pcs[[i]]$air_density == 1.225) {
        pc$points <- ldply(pcs[[i]]$power_curve_table, #nolint
                            data.frame)[, c(2, 3)]
    colnames(pc$points) <- c("WindSpeed", "Power") #nolint
    pc$points <- transform(
      pc$points,
      WindSpeed = as.numeric(as.character(WindSpeed)), # nolint
      Power = as.numeric(as.character(Power))
    )
    pc$points <- rbind(c(0, 0), pc$points)
    break
    }
  }
  pc$fun <- approxfun(
    pc$points$WindSpeed, #nolint
    pc$points$Power, # nolint
    method = "linear",
    yleft = NA,
    yright = 0,
    ties = "ordered"
  )
  pc$attr$Diameter <- xml_data$wind_turbine_properties$rotor_diameter # nolint
  pc$attr$CutIn <- NA # nolint
  pc$attr$CutOut <- NA # nolint
  pc$attr$ReCutIn <- NA # nolint
  pc$attr$RatedSpeed <- NA # nolint
  pc$attr$RatedPower <- xml_data$wind_turbine_properties$rated_power # nolint
  pc$attr$IECClass <- NA # nolint
  pc$attr$Control <- NA # nolint
  pc$attr$Density <- 1.225 # nolint
  pc$attr$Name <- file # nolint
  pc$attr$Filename <- file # nolint
  pc$attr$RatedPower <- as.numeric(pc$attr$RatedPower) # nolint
  return(pc)
}
plot_pc <- function(pc) {
    plot <- ggplot(pc$points, aes(x = WindSpeed, y = Power)) +  # nolint
  geom_point() +
  stat_function(fun = pc$fun) +
  xlim(0, 35)
return(plot)
}
plot_pc_list <- function(list_pcs) {
  list_funs <- lapply(list_pcs, function(x) {
      function(y) {
            x$fun(y) / x$attr$RatedPower} # nolint
  })
  names <- lapply(list_pcs, function(x) x$attr$Name )  # nolint
  plot <- ggplot(NULL, aes(x = x, colour = Turbine)) #nolint
  for (i in 1 : length(list_pcs)) {
    plot <- plot + stat_function(data = data.frame(x = 0 : 30,
            Turbine = factor(names[[i]])), fun = list_funs[[i]])
  }
  plot <- plot + xlab("Wind speed (m/s)") + ylab("Capacity Factor (%)") +
      ggtitle("Selected power curves")
  return(plot)
}
get_list_turbines <- function() {
  files <- list.files()
  turb_list <- list()
  for (i in seq(files)) {
    file <- files[i]
    turb_list[[i]] <- read_xml_pc(file)
  }
  names(turb_list) <- files
  return(turb_list)
}
wind2power <- function(wind, pc) {
  power <- pc$fun(wind)
}
wind2CF <- function(wind, pc) {
  power <- pc$fun(wind)
  CF <- power / pc$attr$RatedPower #nolint
}
WPD <- function(wind, ro) {
  return(0.5 * ro * wind ^ 3)
}
bump <- function(x) {
  f <- function(y) {
    exp(-1 / y ^ 2)
  }
  return(f(x) / (f(x) + f(1 - x)))
}


cat(sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  t <- sapply(strsplit(s, "")[[1]], as.integer)
  u <- rep(0, length(t))
  for (i in t) {
    v <- i + 1
    if (v <= length(t)) {
      u[v] <- u[v] + 1
    } else {
      break
    }
  }
  if (all(t == u)) {
    "1"
  } else {
    "0"
  }
}), sep="\n")


setwd("~/MATLAB/Paper/27-Nov-2017")
A_data = read.csv("A_hist_data.csv", header = FALSE)
A_data$V1 <- factor(A_data$V1)
B_data = read.csv("B_hist_data.csv", header = FALSE)
B_data$V1 <- factor(B_data$V1)
C_data = read.csv("C_hist_data.csv", header = FALSE)
C_data$V1 <- factor(C_data$V1)
D_data = read.csv("D_hist_data.csv", header = FALSE)
D_data$V1 <- factor(D_data$V1)


phys$dM_in <- 0
phys$dM_out <- 0

# ABSORPTION

# dM/dt as result of feeding

if (route=="oral") {
  phys$dM_iv <- 0

  if (i<(timescale*E_start) | i>(timescale*E_end)) {
    phys$dM_food <- 0 # outside of exposure period
  } else if (regime=="continuous") {
    phys$dM_food <- (E_dose/par_in$MW)*par_in$Qingest # mmol/sec
  } else if (i%%(timescale*E_int)==0) {
    phys$dM_food <- (E_dose/par_in$MW) # one immediate bolus dose (mmol)  (if dose = mg/kgbw, multiply with BW)
    phys$dM_food[phys$comp!="lumen"] <- 0
  } else {
    phys$dM_food <- 0 # no bolus dose
  }
}

# dM/dt as result of iv

if (route=="iv") {
  phys$dM_food <- 0
  if (i<(timescale*E_start)|i>(timescale*E_end)) {
    phys$dM_iv <- 0
  } else if (i%%(timescale*E_int)==0) {
    phys$dM_iv <- (E_dose/par_in$MW)*BW    # iv dose in mmol (mg/kg / mg/mmol * kg)
    phys$dM_iv[phys$comp!="ven"] <- 0
  } else {
    phys$dM_iv <- 0
  }
}
####################################################################################################
phys$dM_in <- phys$dM_in + phys$dM_food

phys$dM_out[phys$comp=="feed"] <- phys$dM_food[phys$comp=="lumen"]

phys$dM_in <- phys$dM_in + phys$dM_iv

phys$dM_out[phys$comp=="iv"] <- sum(phys$dM_iv)

# dM/dt as result of absorption over intestinal wall

phys$dM_abs <- phys$M[phys$comp=="lumen"]*phys$kabs
phys$dM_in <- phys$dM_in + phys$dM_abs
phys$dM_out[phys$comp=="lumen"] <- phys$dM_out[phys$comp=="lumen"] + sum(phys$dM_abs)

# DISTRIBUTION

# dM/dt as result of delivery via arterial blood

phys$dM_art <- phys$Q*(phys$C[phys$comp=="art"])
phys$dM_in <- phys$dM_in + phys$dM_art
phys$dM_out[phys$comp=="art"] <- phys$dM_out[phys$comp=="art"]+sum(phys$dM_art)

# dM/dt as result of delivery to venous blood

phys$dM_ven <- phys$Q*(phys$C/phys$PC)

# portal vein

phys$dM_in[phys$comp=="liver"] <- phys$dM_in[phys$comp=="liver"] + phys$dM_ven[phys$comp=="intestine"]
phys$dM_ven[phys$comp=="liver"] <- phys$dM_ven[phys$comp=="liver"] + phys$Q[phys$comp=="intestine"]*(phys$C[phys$comp=="liver"]/phys$PC[phys$comp=="liver"])

phys$dM_out <- phys$dM_out + phys$dM_ven
phys$dM_in[phys$comp=="ven"] <- phys$dM_in[phys$comp=="ven"] + sum(phys$dM_ven[phys$comp!="intestine"])

# METABOLISM

# dM/dt as result of metabolism

phys$dM_met <- ifelse(!is.na(phys$Vmax)&!is.na(phys$Km),(phys$Vmax*(phys$C/phys$PC))/(phys$Km+phys$C/phys$PC),0)
phys$dM_met[phys$comp=="liver"] <-ifelse(!is.na(phys$Cl[phys$comp=="liver"]),phys$Cl[phys$comp=="liver"]*phys$C[phys$comp=="liver"],0)

phys$dM_out <- phys$dM_out + phys$dM_met

phys$dM_in <- phys$dM_in + phys$dM_met[phys$comp=="liver"]*phys$fbile*phys$fbact
phys$dM_in[phys$comp=="metab"] <- phys$dM_in[phys$comp=="metab"] + sum(phys$dM_met) - phys$dM_met[phys$comp=="liver"]*(1-    phys$fbile[phys$comp=="lumen"]*phys$fbact[phys$comp=="lumen"])

# ELIMINATION

# dM/dt as result of transport over lung and exhalation

phys$dM_exh <- ifelse(phys$comp=="ven", CO*phys$C[phys$comp=="ven"],0) # all mass in venous blood is transported
phys$dM_out <- phys$dM_out + phys$dM_exh
phys$dM_in[phys$comp=="art"] <- phys$dM_in[phys$comp=="art"] + phys$dM_exh[phys$comp=="ven"] * (CO/(CO+Qexhale*phys$PC[phys$comp=="air"]))
phys$dM_in[phys$comp=="air"] <- phys$dM_in[phys$comp=="air"] + phys$dM_exh[phys$comp=="ven"] * ((Qexhale*phys$PC[phys$comp=="air"])/(CO+Qexhale*phys$PC[phys$comp=="air"]))

# dM/dt as result of excretion to urine, milk, eggs, feces

phys$dM_exc <- ifelse(phys$comp=="mamgland",phys$C[phys$comp=="mamgland"]*phys$Qmilk[phys$comp=="mamgland"],
                      ifelse(phys$comp=="kidney",phys$C[phys$comp=="kidney"]*phys$Cl[phys$comp=="kidney"],
                             ifelse(phys$comp=="reprod",phys$C[phys$comp=="reprod"]*phys$Qegg[phys$comp=="reprod"],
                                    phys$M*phys$kgastric)))

phys$dM_out <- phys$dM_out + phys$dM_exc

phys$dM_in[phys$comp=="urine"] <- phys$dM_in[phys$comp=="urine"] + phys$dM_exc[phys$comp=="kidney"]
phys$dM_in[phys$comp=="milk"] <- phys$dM_in[phys$comp=="milk"] + phys$dM_exc[phys$comp=="mamgland"]
phys$dM_in[phys$comp=="egg"] <- phys$dM_in[phys$comp=="egg"] + phys$dM_exc[phys$comp=="reprod"]
phys$dM_in[phys$comp=="feces"] <- phys$dM_in[phys$comp=="feces"] + phys$dM_exc[phys$comp=="lumen"]

# Mass and concentration per compartment

phys$M <- phys$M + phys$dM_in - phys$dM_out  # mmol
phys$C <- ifelse(phys$V==0,0,phys$M/phys$V)  # mmol/L

# Write to results for t_A

if (chem_fix & any(i/timescale==t_A)) {

  wholebody_temp<- (sum(phys$M[phys$comp!="feces"&
                                 phys$comp!="urine"&
                                 phys$comp!="lumen"&
                                 phys$comp!="air"&
                                 phys$comp!="metab"&
                                 phys$comp!="feed"&
                                 phys$comp!="milk"&
                                 phys$comp!="egg"])*par_in$MW) / BW

}


library(tidyverse)

# read in data
council <- read.csv("citycouncil.csv")

# calculate councilors per 100,000 population
council$pc.council <- council$council/(council$pop17/100000)

# create annotation
annot <- read.table(text=
  "city|number|just|text
  1.75|4.65|0|Both Nashville & Louisville are consolidated,
city-county governments.
  16.5|2.4|0|Detroit & Fresno are the median city with
1.3 councilors per 100,000 residents.
  32.5|1.4|0|Some of the largest U.S. cities have the
fewest councilors per 100,000 residents.",
  sep="|", header=TRUE, stringsAsFactors=FALSE)
annot$text <- gsub("
", "\n", annot$text)

# plot
p <- ggplot(data=council,
  aes(x=reorder(City, -pc.council), y=pc.council, width=0.9))+
  geom_bar(stat="identity", fill="#E69F00")+
  #geom_bar(stat="identity", fill="#999999")+
  scale_y_continuous(breaks=seq(0, 6, by=1))+
  # read in annotations
  geom_label(data=annot, aes(x=city, y=number, label=text, hjust=just),
    family="Open Sans Condensed Light", lineheight=0.95,
    size=3.5, label.size=0, color="#2b2b2b")+
  # Theming
  labs(
    title="Most city council districts in the U.S. are large",
    subtitle="City councilors per 100,000 residents, 40 largest U.S. cities, 2017",
    caption="Author: Chris Goodman (@cbgoodman), Data: U.S. Census Bureau & Author's calculations.",
    y=NULL,
    x=NULL) +
  theme_minimal(base_family="Open Sans Condensed Light") +
  # light, dotted major y-grid lines only
  theme(panel.grid=element_line())+
  theme(panel.grid.major.y=element_line(color="#2b2b2b", linetype="dotted", size=0.15))+
  theme(panel.grid.major.x=element_blank())+
  theme(panel.grid.minor.x=element_blank())+
  theme(panel.grid.minor.y=element_blank())+
  # light x-axis line only
  theme(axis.line=element_line())+
  theme(axis.line.y=element_blank())+
  theme(axis.line.x=element_blank())+
  # tick styling
  theme(axis.ticks=element_line())+
  theme(axis.ticks.x=element_blank())+
  theme(axis.ticks.y=element_blank())+
  theme(axis.ticks.length=unit(5, "pt"))+
  # x-axis labels
  theme(axis.text.x=element_text(size=10, angle=90, hjust=0.95,vjust=0.2))+
  # breathing room for the plot
  theme(plot.margin=unit(rep(0.5, 4), "cm"))+
  # move the y-axis tick labels over a bit
  #theme(axis.text.y=element_text(margin=margin(r=-5)))+
  # make the plot title bold and modify the bottom margin a bit
  theme(plot.title=element_text(family="Open Sans Condensed Bold", margin=margin(b=15)))+
  # make the subtitle italic
  theme(plot.subtitle=element_text(family="Open Sans Condensed Light Italic"))+
  theme(plot.caption=element_text(size=8, hjust=0, margin=margin(t=15)))

ggsave(plot=p, "councilors.png", width=10, height=6, units="in", dpi="retina")


#'---
#'title: "Life and Time - PxVx - Value Stability"
#'output:
#'  html_document:
#'    toc: true
#'---

#+ echo=F
library(MplusAutomation)
library(knitr)
library(dplyr)
library(tidyr)
library(stringr)
library(ggplot2)
opts_chunk$set(echo=F, message=F, warning=F)

source('~/code_new/lnt_pxvx/Code/ggplottheme.r')

mfi <- function(X2,df,N){
  exp(-0.5 * (X2 - df)/N)
}

# Set working directory to that which contains Code, Data, etc
# setwd('E:/Projects/lnt_pxvx/')

loadStbFN<-'~/code_new/lnt_pxvx/Rez/stability.RData'

# # Create Models
# createModels('Code/value_stability_invariance_template.inp')
# createModels('Code/value_stability_invariance_template-Col.inp')
#
# setwd('E:/Projects/lnt_pxvx/Rez/stability')
# runModels(target = '~/code_new/lnt_pxvx/Rez/stability/',
#           Mplus_command = '/opt/mplus/8/mplus',
#           recursive = T)
#
# # Read models
# # setwd('../Rez/stability')
# saveStbFN<-'Rez/stability.RData'
# stbModelOut<-readModels(target = '~/code_new/lnt_pxvx/Rez/stability/',
#                         recursive = T,
#                         filefilter='stability.*')
# stbModelOut_df <- data_frame(model=stbModelOut)
# save(stbModelOut_df,file=saveStbFN)
# setwd('../../Code')

load(loadStbFN)

summaries <- stbModelOut_df %>% rowwise %>%
  do({
    aSummary <- .[[1]]$summaries
    as_data_frame(aSummary)
  }) %>%
  extract(Title,
          c('sample', 'variable', 'modelType'),
          'Stability of values - (\\w+) ([\\w_]+) ([\\w_]+);') %>%
  mutate(MFI = mfi(X2 = ChiSqM_Value, df = ChiSqM_DF, N = 863))

paramsummaries <- stbModelOut_df %>% rowwise %>%
	  do({
	    someParams <- .[[1]]$parameters$stdyx.standardized
	    someParams.df <- as_data_frame(someParams) %>%
		    mutate(est_se=as.numeric(ifelse(est_se == '*********', NA, est_se)))
	    someParams.df$Title <- as.character(.[[1]]$summaries$Title)
	    someParams.df
	  })%>%
	extract(Title,
		c('sample', 'variable', 'modelType'),
		'Stability of values - (\\w+) ([\\w_]+) ([\\w_]+);') %>%
	mutate(paramstatement=paste(paramHeader, param, sep='.'),
	       paramgroup=str_replace(paramstatement,
				      '^([ABCDS]|Means|Intercepts|Variances|Residual\\.Variances).*?\\.(ON|WITH)*\\.*([ABCDIS]).*',
				      '\\1 \\2 \\3'))

summaryTableLong <- summaries %>%
	select(sample, variable, modelType, Parameters,
	       ChiSqM_Value, ChiSqM_DF, ChiSqM_PValue, MFI,
	       AIC, BIC) %>%
	gather(stat, value, ChiSqM_Value, ChiSqM_DF, MFI, AIC, BIC)

summaryDiffs <- summaryTableLong %>%
	group_by(sample, variable, stat) %>%
	do(data_frame(value=.$value[.$modelType=='group']-
	   .$value[.$modelType=='longitudinal'])) %>%
	mutate(modelType='difference')

#'
#' # Model Fit
#'
#' ## Absolute fit of longitudinal invariance models
#'
#'
#+results='asis'
nada <- summaries %>%
	filter(modelType=='longitudinal') %>%
	group_by(sample) %>%
	do({
		asamp <- unique(.$sample)
		atable <- as_data_frame(.) %>%
			mutate_each(funs(gsub('^0(\\.\\d+)',
					      '\\1',
					      sprintf('%.2f', .))),
				    MFI, CFI,
				    RMSEA_Estimate,
				    RMSEA_90CI_LB,
				    RMSEA_90CI_UB) %>%
			mutate(RMSEA=paste0(RMSEA_Estimate,
					    ' [',
					    RMSEA_90CI_LB,
					    ',',
					    RMSEA_90CI_UB,
					    ']')) %>%
			select(variable,
			       RMSEA,
			       MFI,
			       CFI) %>%
			rename(`RMSEA [90% CI]`=RMSEA) %>%
			kable(digits=2, caption=paste0('Sample: ', asamp),
			      align=c('l', rep('r', 4)))
		print(atable)
		cat('\n\n\n')
		data_frame(table=list(atable), sample=asamp)
	})

#'
#' ## Absolute fit of group invariance models
#'
#+results='asis'
nada <- summaries %>%
	filter(modelType=='group',
	       sample=='Nat') %>%
	group_by(sample) %>%
	do({
		asamp <- unique(.$sample)
		atable <- as_data_frame(.) %>%
			mutate_each(funs(gsub('^0(\\.\\d+)',
					      '\\1',
					      sprintf('%.2f', .))),
					  MFI,CFI,
				    RMSEA_Estimate,
				    RMSEA_90CI_LB,
				    RMSEA_90CI_UB) %>%
			mutate(RMSEA=paste0(RMSEA_Estimate,
					    ' [',
					    RMSEA_90CI_LB,
					    ',',
					    RMSEA_90CI_UB,
					    ']')) %>%
			select(variable,
			       RMSEA,
			       MFI,
			       CFI) %>%
			rename(`RMSEA [90% CI]`=RMSEA) %>%
			kable(digits=2, caption=paste0('Sample: ', asamp),
			      align=c('l', rep('r', 4)))
		print(atable)
		cat('\n\n\n')
		data_frame(table=list(atable), sample=asamp)
	})

#'
#' ## Relative fit
#'
#+results='asis'
nada <- bind_rows(summaryTableLong, summaryDiffs) %>%
  filter(!grepl('_d$', variable)) %>%
	spread(stat, value) %>%
	mutate(modelType=factor(modelType, levels=c('longitudinal', 'group', 'difference'))) %>%
	arrange(sample, variable, modelType) %>%
	mutate(ChiSqM_PValue=ifelse(is.na(ChiSqM_PValue),
				    1-pchisq(ChiSqM_Value, ChiSqM_DF),
				    ChiSqM_PValue)) %>%
	group_by(sample) %>%
	do({
		asamp <- unique(.$sample)
		atable <- as_data_frame(.) %>% select(variable, modelType, Parameters,
			     ChiSqM_Value, ChiSqM_DF, ChiSqM_PValue, MFI,
			     AIC, BIC) %>%
			mutate(Parameters=ifelse(is.na(Parameters),
						 '',
						 Parameters)) %>%
			kable(caption=paste0('Sample: ', asamp))
		print(atable)
		cat('\n\n\n')
		data_frame(table=list(atable), sample=asamp)
	})

nada <- bind_rows(summaryTableLong, summaryDiffs) %>%
  filter(grepl('_d$', variable)) %>%
  spread(stat, value) %>%
  mutate(modelType=factor(modelType, levels=c('longitudinal', 'group', 'difference'))) %>%
  arrange(sample, variable, modelType) %>%
  mutate(ChiSqM_PValue=ifelse(is.na(ChiSqM_PValue),
                              1-pchisq(ChiSqM_Value, ChiSqM_DF),
                              ChiSqM_PValue)) %>%
  group_by(sample) %>%
  do({
    asamp <- unique(.$sample)
    atable <- as_data_frame(.) %>% select(variable, modelType, Parameters,
                                          ChiSqM_Value, ChiSqM_DF, ChiSqM_PValue, MFI,
                                          AIC, BIC) %>%
      mutate(Parameters=ifelse(is.na(Parameters),
                               '',
                               Parameters)) %>%
      kable(caption=paste0('Sample: ', asamp))
    print(atable)
    cat('\n\n\n')
    data_frame(table=list(atable), sample=asamp)
  })

#'
#' # Group-invariant stability
#'
#' Correlation estimates assuming longitudinal invariance in college sample,
#' and longitudinal and group invariance in the national sample.
#'

paramsummaries %>% filter(modelType=='group'| sample=='Col',
			  paramgroup %in% c('A WITH B', 'A WITH C', 'A WITH D'),
			  Group=='D2' | sample=='Col') %>%
	select(sample, variable, est, paramgroup) %>%
	group_by(sample, variable) %>%
	spread(paramgroup, est) %>%
	kable(digits=2)

#'
#' # Longitudinal-invariant stability
#'
#' Correlation estimates assuming longitudinal invariance only in the national sample.
#'
#+results='asis'

nada <- paramsummaries %>% filter(modelType=='longitudinal',
			  paramgroup %in% c('A WITH B', 'A WITH C', 'A WITH D'),
			  sample=='Nat') %>%
	select(variable, Group, est, paramgroup) %>%
	group_by(variable, Group) %>%
	spread(paramgroup, est) %>%
  ungroup() %>%
	mutate(Group=str_replace(Group, 'D([2345])', '\\10\'s')) %>%
	group_by(variable) %>%
	do({
		avar <- unique(.$variable)
		atable <- as_data_frame(.) %>% select(-variable) %>%
			kable(digits=2, caption=paste0('Variable: ', avar))
		print(atable)
		cat('\n\n\n')
		data_frame(table=list(atable), variable=avar)
	})

#'
#'
#'
#+fig.width=9, fig.height=6, dpi=300
vVarNames <- c(
  usi ='Unmitigated\nSelf-Interest',
  usi_d ='Unmitigated Self-Interest Invariant',
  vrt_ind ='Vertical\nIndividualism',
  vrt_ind_d ='Vertical Individualism Invariant',
  bfa_mt ='Materialism',
  bfa_mt_d ='Materialism Invariant',
  aspfin ='Financial\nAspirations',
  aspfin_d ='Financial Aspirations Invariant',
  mvi ='Mature\nValues Index',
  vrt_col ='Vertical\nCollectivism',
  vrt_col_d ='Vertical Collectivism Invariant',
  hrz_col ='Horizontal\nCollectivism',
  hrz_col_d ='Horizontal Collectivism Invariant',
  hrz_ind='Horizontal\nIndividualism',
  hrz_ind_d='Horizontal Individualism Invariant'
)

bordergray <- '#dddddd'
meangray <- '#777777'

paramsummaries %>% filter(modelType=='longitudinal',
			  paramgroup %in% c('A WITH B', 'A WITH C', 'A WITH D'),
			  sample=='Nat',
			  !grepl('_d$',variable)) %>%
  mutate(variable = factor(variable, levels = names(vVarNames), labels = vVarNames)) %>%
	select(variable, Group, est, se, paramgroup) %>% ungroup() %>%
	mutate(Group=factor(str_replace(Group, 'D([2345])', '\\10\'s')),
	       LL=est-1.96*se,
	       UL=est+1.96*se,
	       lag=factor(as.numeric(as.factor(paramgroup)), levels = c(1,2,3), labels = c('1-year lag', '2-year lag', '3-year lag'))) %>%
	ggplot(aes(Group, est))+
  geom_hline(yintercept = .6, color = bordergray, linetype = 3) +
	geom_point(size=1)+
	geom_errorbar(aes(ymin=LL, ymax=UL), width=0)+
	facet_grid(lag~variable)+
	coord_cartesian(y=c(.3, 1))+
  scale_y_continuous(breaks = c(.4,.6,.8,1)) +
	theme(axis.text.x=element_text(angle=360-45, hjust=0),
	      panel.border = element_rect(fill = NA, color = bordergray, size = 1, linetype = 1),
	      strip.background = element_rect(fill=bordergray, color = bordergray, size = 1, linetype = 1),
	      axis.line.x = element_line(color = NA, size = .5, linetype = 1),
	      axis.line.y = element_line(color = NA, size = .5, linetype = 1),
	      panel.spacing = unit(0, units = 'in')) +
	labs(x="Age Decade Group",
	     y="Correlation, 95% CI")

paramsummaries %>% filter(modelType=='longitudinal',
                          paramgroup %in% c('A WITH B', 'A WITH C', 'A WITH D'),
                          sample=='Nat',
                          grepl('_d$',variable)) %>%
  mutate(variable = factor(variable, levels = names(vVarNames), labels = vVarNames)) %>%
  select(variable, Group, est, se, paramgroup) %>% ungroup() %>%
  mutate(Group=factor(str_replace(Group, 'D([2345])', '\\10\'s')),
         LL=est-1.96*se,
         UL=est+1.96*se,
         lag=factor(as.numeric(as.factor(paramgroup)), levels = c(1,2,3), labels = c('1-year lag', '2-year lag', '3-year lag'))) %>%
  ggplot(aes(Group, est))+
  geom_hline(yintercept = .6, color = bordergray, linetype = 3) +
  geom_point(size=1)+
  geom_errorbar(aes(ymin=LL, ymax=UL), width=0)+
  facet_grid(lag~variable)+
  coord_cartesian(y=c(.3, 1))+
  scale_y_continuous(breaks = c(.4,.6,.8,1)) +
  theme(axis.text.x=element_text(angle=360-45, hjust=0),
        panel.border = element_rect(fill = NA, color = bordergray, size = 1, linetype = 1),
        strip.background = element_rect(fill=bordergray, color = bordergray, size = 1, linetype = 1),
        axis.line.x = element_line(color = NA, size = .5, linetype = 1),
        axis.line.y = element_line(color = NA, size = .5, linetype = 1),
        panel.spacing = unit(0, units = 'in')) +
  labs(x="Age Decade Group",
       y="Correlation, 95% CI")

paramsummaries %>% filter(modelType=='longitudinal',
                          paramgroup %in% c('A WITH B', 'A WITH C', 'A WITH D'),
                          sample=='Nat',
                          !grepl('_d$',variable)) %>%
  mutate(variable = factor(variable, levels = names(vVarNames), labels = vVarNames)) %>%
  select(variable, Group, est, se, paramgroup) %>% ungroup() %>%
  mutate(Group=factor(str_replace(Group, 'D([2345])', '\\10\'s')),
         LL=est-1.96*se,
         UL=est+1.96*se,
         lag=factor(as.numeric(as.factor(paramgroup)), levels = c(1,2,3), labels = c('1-year lag', '2-year lag', '3-year lag'))) %>%
  ggplot(aes(x = Group, y = est, alpha = lag, group = lag))+
  geom_hline(yintercept = .6, color = bordergray, linetype = 3) +
  geom_point(size=1, position = position_dodge(width = .65))+
  geom_errorbar(aes(ymin=LL, ymax=UL), width=0, position = position_dodge(width = .65))+
  facet_grid(~variable)+
  coord_cartesian(y=c(.3, 1))+
  scale_y_continuous(breaks = c(.4,.6,.8,1)) +
  scale_alpha_discrete(range = c(1, .3)) +
  theme(axis.text.x=element_text(angle=360-45, hjust=0),
        panel.border = element_rect(fill = NA, color = bordergray, size = 1, linetype = 1),
        strip.background = element_rect(fill=bordergray, color = bordergray, size = 1, linetype = 1),
        axis.line.x = element_line(color = NA, size = .5, linetype = 1),
        axis.line.y = element_line(color = NA, size = .5, linetype = 1),
        panel.spacing = unit(0, units = 'in')) +
  labs(x="Age Decade Group",
       y="Correlation, 95% CI")


## quick QC to check array quality

setwd("/gpfs/mrc0/projects/Research_Project-MRC190311/DNAm/")
library(bigmelon)
library(gplots)

## load data

sampleSheet<-read.csv("SampleSheets/Run1June2019.csv")
sampleSheet$Basename<-paste(sampleSheet$Chip.ID, sampleSheet$Chip.Location, sep = "_")
setwd("iDats")

for(each in sampleSheet$Basename){
	gfile <- iadd2(".", gds = 'run1.gds') ## this only reads in a single gds
}

 gfile <- openfn.gds('run1.gds')

### three quick checks:

msetEPIC <- readEPIC(idatPath="iDats", barcodes=sampleSheet$Basename, parallel = FALSE, force=T)

m_intensities<-methylated(msetEPIC)
u_intensities<-unmethylated(msetEPIC)
M.median<-apply(m_intensities, 2, median)
U.median<-apply(u_intensities, 2, median)
QCmetrics<-cbind(pheno,M.median, U.median)

plot(M.median, U.median, col = as.factor(sampleSheet$Cell.type), pch = 16)

betas.tmp<-betas(msetEPIC)
sigma<-apply(betas.tmp, 1, sd, na.rm = TRUE)
heatmap.2(betas.tmp[which(sigma > quantile(sigma, 0.995, na.rm = TRUE)),], trace = "none", dendrogram = "column", ColSideColors = as.factor(sampleSheet$Cell.type), labRow = "", labCol = "")

grep("rs", rownames(betas.tmp))
heatmap.2(betas.tmp[grep("rs", rownames(betas.tmp)),], trace = "none", dendrogram = "column", ColSideColors = c("black", "blue", "red", "forestgreen")[as.factor(sampleSheet$Cell.type)], labRow = "", labCol = sampleSheet$Individual)

Individual

## see if samples cluster by type
betas.tmp<-read.gdsn(betas(gfile))
betas.tmp<-read.gdsn(fData(gfile))
sigma<-apply(betas.tmp, 1, sd, na.rm = TRUE)

heatmap.2(betas.tmp[which(sigma > quantile(sigma, 0.95, na.rm = TRUE)),], trace = "none")
hclust(dist(betas.tmp[which(sigma > quantile(sigma, 0.99, na.rm = TRUE)),]))

## see if samples cluster by individual across snp probes

grep("rs", fData(gfile))


#' Count Number of NAs in a Vector or a Data Frame.
#'
#' @param x A vector or a data frame.
#' @return The number of NAs in the object x.
#' @examples
#' x <- c(NA, 'a', 'b', NA, 'c')
#' na_count(x)
#' #=> 2
#'
#' df <- data.frame(x=c(1, 2), y=c(3, NA), z=c(NA, NA))
#' na_count(df)
#' #=> x y z
#' #=> 0 1 2
#' @seealso \code{\link{nas}}
na_count <- function(x) {
    if(is.data.frame(x)) {
        sapply(x, function(λ) sum(is.na(λ)))
    } else {
        sum(is.na(x))
    }
}

#' Alias for \code{na_count}
#' @seealso \code{\link{na_count}}
nas <- function(x) na_count(x)

#' Proportion of NAs in a Vector or a Data Frame.
#'
#' What proportion of NA values are in a vector or in each variable of a
#' data frame?
#'
#' @param x A vector or data frame.
#' @return The proportion between 0 (no NAs) and 1 (all values are NAs)
#' of the object x.
#' @examples
#' x <- c(NA, 'a', 'b', NA, 'c')
#' na_prop(x)
#' #=> 0.4
#'
#' df <- data.frame(x=c(1, 2), y=c(3, NA), z=c(NA, NA))
#' na_prop(df)
#' #=>   x   y   z
#' #=> 0.0 0.5 1.0
#' @seealso \code{\link{na_percent}}
na_prop <- function(x) {
    vector_prop <- function(λ) na_count(λ) / length(λ)
    if(is.data.frame(x)) {
        sapply(x, vector_prop)
    } else {
        vector_prop(x)
    }
}

#' Percentage of NAs in a Vector or a Data Frame.
#'
#' What percentage of NA values are in a vector or in each variable of a
#' data frame?
#'
#' @param x A vector or a data frame.
#' @return The percentage (between 0: no NAs, and 100: all values are
#' NAs) of the object x.
#' @examples
#' x <- c(NA, 'a', 'b', NA, 'c')
#' na_percent(x)
#' #=> 40
#'
#' df <- data.frame(x=c(1, 2), y=c(3, NA), z=c(NA, NA))
#' na_percent(df)
#' #=> x   y   z
#' #=> 0  50 100
#' @seealso \code{\link{na_prop}}
na_percent <- function(x) {
    vector_percent <- function(λ) na_prop(λ) * 100
    if(is.data.frame(x)) {
        sapply(x, vector_percent)
    } else {
        vector_percent(x)
    }
}

#' Replace NAs with zeros.
#'
#' @param x A vector, data frame, or matrix.
#' @return The object x with all NAs replaced by zeros.
#' @examples
#' na_zero(c(1, NA, 2))
#' #=> 1 0 2
na_zero <- function(x) {
    x[is.na(x)] <- 0
    x
}