pdf_file<-"pdf/maps_germany_cities_points_outline_1x2.pdf"
cairo_pdf(bg="lavender", pdf_file,width=12,height=6)

par(mai=c(0,0,0,0), omi=c(0.15,0.25,0.55,0.25),mfcol=c(1,2),family="Lato Light",las=1)
library(sp); library(RColorBrewer); library(geoR)
source("scripts/inc_datadesign_dbconnect.r")

# Import data and prepare chart

sql<-"select substr(sighting,7,4) year, lng, lat, identification from v_ufos where substr(sighting,7,4) in (2006, 2012)"
myDataset<-dbGetQuery(con,sql)
myDataset$myYear<-as.numeric(myDataset$year)
attach(myDataset)

myYear1<-2006; myYear2<-2012

myYear1id<-subset(myDataset,myYear == myYear1 & identification != "-")
myYear1ui<-subset(myDataset,myYear == myYear1 & identification == "-")

myYear2id<-subset(myDataset,myYear == myYear2 & identification != "-")
myYear2ui<-subset(myDataset,myYear == myYear2 & identification == "-")

myData<-c(myYear1ui,myYear2ui,myYear1id,myYear2id)
load("myData/gadm2/DEU_adm1.RData")
myColour<-"linen"
myColour_uid<-rgb(128,0,0,200,maxColorValue=255)
myColour_id<-rgb(0,153,0,120,maxColorValue=255)

# Create chart and other elements

plot(gadm,border="white",col=myColour)
par(family="Quivira")
text(jitterDupCoords(cbind(myYear1ui$lng,myYear1ui$lat),max=0.01),"👽",col=myColour_uid,cex=2.3)
points(jitterDupCoords(cbind(myYear1id$lng,myYear1id$lat),max=0.01),pch=15,col=myColour_id,cex=1.6)

mtext("👽", side=1, line=-3, col=myColour_uid, cex=1.5, adj=0)
mtext("◼", side=1, line=-1.9, col=myColour_id, cex=1.15, adj=0)
par(family="Lato Light")
mtext("not identified", side=1, line=-3, cex=1.1, adj=0.05)
mtext("identified", side=1, line=-2, cex=1.1, adj=0.05)

text(5,53,myYear1,cex=2.7,col="azure4")

plot(gadm,border="white",col=myColour)
par(family="Quivira")
text(jitterDupCoords(cbind(myYear2ui$lng,myYear2ui$lat),max=0.01),"👽",col=myColour_uid,cex=2.3)
par(family="Lato Light")
points(jitterDupCoords(cbind(myYear2id$lng,myYear2id$lat),max=0.01),pch=15,col=myColour_id,cex=1.6)
text(5,53,myYear2,cex=2.7,col="azure4")

# Titling

mtext("UFO Sightings in Germany",line=0,adj=0,cex=2.2,family="Lato Black",outer=T)
mtext("Source: www.ufo-datenbank.de.",side=1,line=-1,adj=1,cex=0.9,font=3,outer=T)
dev.off()


#!/usr/bin/env Rscript

#########################################################################################
#  __  o  __   __   __  |__   __                                                         #
# |__) | |  ' (__( |  ) |  ) (__(                                                        #
# |                                                                                #
#                                                                                #
# File: calcAlignmentPIS.r (Rscript)                                                     #
#  VERSION="v1.2"                                                                        #
# Author: Justin C. Bagley                                                               #
# Date: Created by Justin Bagley on Fri, 19 Aug 2016 00:23:07 -0300.                     #
# Last update: March 6, 2019                                                             #
# Copyright (c) 2016-2019 Justin C. Bagley. All rights reserved.                         #
# Please report bugs to <jbagley@jsu.edu>.                                               #
#                                                                                #
# Description:                                                                           #
#                                                                                #
#########################################################################################

####################################### START ###########################################

cat('INFO      | $(date) |----------------------------------------------------------------\n')
cat('INFO      | $(date) | calcAlignmentPIS.r, v1 March 2019                              \n')
cat('INFO      | $(date) | Copyright (c) 2016-2019 Justin C. Bagley. All rights reserved. \n')
cat('INFO      | $(date) |----------------------------------------------------------------\n')

# R code for looping through set of FASTA files in dir and calculating parsimony-informative
# sites for each alignment, then saving and outputting to file. Written for Anoura UCE
# data analysis, March 6, 2019

# Be sure to do the following OUTSIDE of R before running R on your machine (assuming
# you have set up the prepR function in your ~/.bashrc (Linux) or ~/.bash_profile (Mac)
# files on machine).
# $ prepR

############ I. SETUP
# Load needed packages, R code, or other prelim stuff. Install packages if not present.
packages <- c('phyloch')
if (length(setdiff(packages, rownames(installed.packages()))) > 0) {
	install.packages(setdiff(packages, rownames(installed.packages())))
}
library(phyloch)
#setwd('')	# With my current R setup, no need to set wd because this is done automatically at start up.
getwd()

############ II. CALCULATE PARSIMONY-INFORMATIVE SITES (PIS) FOR ALL FASTA FILES.
files <- list.files(path=getwd(), pattern='*.fas', full.names=TRUE, recursive=FALSE)
iterations <- length(files)
variables <- 1
output <- matrix(ncol=variables, nrow=iterations)

# Use loop through FASTA files in files (above) to calculate PIS for each file and save
# to output matrix:
for(i in 1:iterations){
	# Read FASTA file
	fas <- read.fas(files[i])
	# Apply function to estimate parsimony-informative sites (PIS)
	pis_out <- pis(fas, abs = TRUE, use.ambiguities = FALSE)
	# Add PIS result to data matrix
	output[i,] <- pis_out
}

write.table(output, 'pis_output_table.txt', sep='	', quote=FALSE, row.names=FALSE, col.names=TRUE)

output

write.table(files, 'input_file_order.txt', sep='	')

######################################### END ############################################


library(here)
library(purrr)
library(ggplot2)
library(socialmixr)
library(dplyr)

source(here::here("scripts", "read.R"))
prev <- read_cis()

p <- ggplot(prev %>%
         filter(level == "national"),
       aes(x = end_date, ymin = lower, ymax = upper)) +
  geom_ribbon() +
  scale_x_date(breaks = "2 months", labels = date_format("%b %Y")) +
  theme_minimal() +
  facet_wrap(~ variable) +
  xlab("")

p_natural <- p +
  scale_y_continuous("Prevalence of SARS-CoV-2 positivity",
                label = scales::percent_format(accuracy = 0.1))

p_log <- p +
  scale_y_log10("Prevalence of SARS-CoV-2 positivity",
                label = scales::percent_format(accuracy = 0.1))

ggsave(here::here("figures", "national_prevalence.pdf"), p_natural,
       width = 12, height = 8)
ggsave(here::here("figures", "national_prevalence_log.pdf"), p_log,
       width = 12, height = 8)

p <- ggplot(prev %>%
         filter(level == "regional"),
       aes(x = end_date, ymin = lower, ymax = upper)) +
  geom_ribbon() +
  scale_x_date(breaks = "2 months", labels = date_format("%b %Y")) +
  theme_minimal() +
  facet_wrap(~ variable) +
  xlab("")

p_natural <- p +
  scale_y_continuous("Prevalence of SARS-CoV-2 positivity",
                label = scales::percent_format(accuracy = 0.1))

p_log <- p +
  scale_y_log10("Prevalence of SARS-CoV-2 positivity",
                label = scales::percent_format(accuracy = 0.1))

ggsave(here::here("figures", "regional_prevalence.pdf"), p_natural,
       width = 16, height = 12)
ggsave(here::here("figures", "regional_prevalence_log.pdf"), p_log,
       width = 16, height = 12)

age <- prev %>%
  filter(level == "age_school") %>%
  mutate(variable =
           factor(variable, levels = c("2-10", "11-15", "16-24", "25-34",
                                       "35-49", "50-69", "70+")))

p <- ggplot(age,
            aes(x = end_date, ymin = lower, ymax = upper,
                colour = variable, fill = variable)) +
  geom_ribbon(alpha = 0.5) +
  scale_x_date(breaks = "2 months", labels = date_format("%b %Y")) +
  scale_colour_brewer("Age", palette = "Set1") +
  scale_fill_brewer("Age", palette = "Set1") +
  theme_minimal() +
  ggtitle("England") +
  xlab("")

p_natural <- p +
  scale_y_continuous("Prevalence of SARS-CoV-2 positivity",
                label = scales::percent_format(accuracy = 0.1))

p_log <- p +
  scale_y_log10("Prevalence of SARS-CoV-2 positivity",
                label = scales::percent_format(accuracy = 0.1))

ggsave(here::here("figures", "age_prevalence.pdf"), p_natural,
       width = 12, height = 8)
ggsave(here::here("figures", "age_prevalence_log.pdf"), p_log,
       width = 12, height = 8)


nox<-2; noy<-2;
paper<-T      # graphics on paper=file (TRUE) or on screen (FALSE)
run.ID<-'NielsH'         # file id used for paper output
run.ID<-'ICES_SMS'
cleanup()

doGrid<-T
extent.SSB<-F  # plot SSB for the year after last assessment year

first.year.on.plot<-1970
last.year.on.plot<-2018
plot.MCMC<-F                        # plot values from MCMC scenarios. FALSE=plot hindcast values from "summary_table_raw.out"
single.species<-T                   # single species mode or multispecies mode

include.assess.forcast.line<-F      # verical line at last assessment year
include.F.reference.points<-F
include.SSB.reference.points<-F
include.1.std<-FALSE                   # Include values plus/minus 1 times the standard deviation
include.2.std<-F

incl.sp<-c("Cod","Whiting","Haddock","Saithe",'Herring',"Sprat",'Nor. pout')                      # species number to be included. Numbers or "all"
incl.sp<-"all"

first.pch<-0    # first pch symbol
first.color<-1   # first color

palette("default")                # good for clolorfull plots
#palette(gray(seq(0,.9,len=10)))  # gray scale for papers, use len =500 to get black only

if (makeAllGraphs) {
  dirs<-c("NS_key-2014-ver17","NS_key-2017-ver05")
  labels<-c("2014-run","2017-run")
}

if (FALSE) {

dirs<-c("Baltic-2019-single","Baltic-2019-ICES-results")
labels<-c("SMS-single","ICES-single")

dirs<-c("Baltic-2019-no_size_selection0","Baltic-2019-no_size_selection4","Baltic-2019-keyRun")
labels<-c("Uniform","Constraint uniform","2019 key run")

dirs<-c("Baltic-2012-keyRun-results","Baltic-2019-keyRun")
labels<-c("2012 keyrun","2019 keyrun")

}

dirs<-c("Baltic-2019-old_stomachs","Baltic-2019-old-new_stomachs","Baltic-2019-keyRun")
labels<-c("old stomachs","old & new stomachs","2019 keyrun")

dirs<-c("Baltic-2019-ICES-results","Baltic-2019-keyRun")
labels<-c("ICES single species","2019 keyrun")

 #####################
for (dir in dirs) {
  if ( file.access(file.path(root,dir,"sms.dat"), mode = 0)!=0)  stop(paste('Directory',dir,'does not exist'))
}

for (dir in dirs) {
  Init.function(dir=file.path(root,dir)) # get SMS.contol object  including sp.names

 if (plot.MCMC) {
  if (!single.species) {
    file<-file.path(root,dir,'mcout2_average_eaten_M2.out')
    if ( file.access(file, mode = 0) ==0) {
       eaten<-read.table(file,header=TRUE)
       eaten<-data.frame(scen=dir,vari='Eaten',eaten)
       names(eaten)<-c("scenario","Variable","Species.n","Year","Value","std")
    }
  }

  file<-file.path(root,dir,'mcout2_average_recruit.out')
  rec<-read.table(file,header=TRUE)
  rec<-data.frame(scen=dir,vari='Rec',rec)
  names(rec)<-c("scenario","Variable","Species.n","Year","Value","std")

  file<-file.path(root,dir,'mcout2_average_mean_F.out')
  FF<-read.table(file,header=TRUE)
  FF<-data.frame(scen=dir,vari='F',FF)
  names(FF)<-c("scenario","Variable","Species.n","Year","Value","std")

  file<-file.path(root,dir,'mcout2_average_SSB.out')
  ssb<-read.table(file,header=TRUE)
  ssb<-data.frame(scen=dir,vari='SSB',ssb)
  names(ssb)<-c("scenario","Variable","Species.n","Year","Value","std")

  file<-file.path(root,dir,'mcout2_average_yield.out')
  yield<-read.table(file,header=TRUE)
  yield<-data.frame(scen=dir,vari='Yield',yield)
  names(yield)<-c("scenario","Variable","Species.n","Year","Value","std")
  yield.hat<-yield
 } else {

 # hindcast only

   a<-Read.summary.table(dir=file.path(root,dir),read.init.function=FALSE)
   a<-subset(a,(Year>=first.year.on.plot & Year<=last.year.on.plot) ,drop=T)

   if (!single.species) {
     eaten<-subset(a,select=c(Species, Year,Eaten))
     eaten<-data.frame(scen=dir,vari='Eaten',eaten,std=0)
     names(eaten)<-c("scenario","Variable","Species","Year","Value","std")
   }

   rec<-subset(a,select=c(Species, Year, Rec))
   rec<-data.frame(scen=dir,vari='Rec',rec,std=0)
   names(rec)<-c("scenario","Variable","Species","Year","Value","std")

   FF<-subset(a,select=c(Species, Year,mean.F),!is.na(mean.F))
   max.year<-max(FF$Year)
   FF<-data.frame(scen=dir,vari='F',FF,std=0)
   names(FF)<-c("scenario","Variable","Species","Year","Value","std")

   ssb<-subset(a,select=c(Species, Year, SSB))
   if (!extent.SSB) ssb<-subset(ssb,Year<=max.year)
   ssb<-data.frame(scen=dir,vari='SSB',ssb,std=0)
   names(ssb)<-c("scenario","Variable","Species","Year","Value","std")

   yield<-subset(a,select=c(Species, Year, SOP))
   yield<-data.frame(scen=dir,vari='Yield',yield,std=0)
   names(yield)<-c("scenario","Variable","Species","Year","Value","std")

   yield.hat<-subset(a,select=c(Species, Year, SOP.hat))
   yield.hat<-data.frame(scen=dir,vari='Yield.hat',yield.hat,std=0)
   names(yield.hat)<-c("scenario","Variable","Species","Year","Value","std")

 }
 if (!single.species) { if (dir==dirs[1]) all<-rbind(rec,FF,ssb,yield,yield.hat,eaten) else all<-rbind(all,rec,FF,ssb,yield,yield.hat,eaten)}
 else {if (dir==dirs[1]) {all<-rbind(rec,FF,ssb,yield,yield.hat)} else all<-rbind(all,rec,FF,ssb,yield,yield.hat)}
 a$label<-labels[which(dirs==dir)]
 #if (dir==dirs[1]) all2<-a else all2<-rbind(all2,a)
}

all<-subset(all,(Year>=first.year.on.plot & Year<=last.year.on.plot) ,drop=T)
values<-tapply(all$Value,list(all$Year,all$scenario,all$Species,all$Variable),sum)/1000
stds<-  tapply(all$std,  list(all$Year,all$scenario,all$Species,all$Variable),sum)/1000

#subset(all,Species=='Plaice' & Variable=='SSB')

#values[,,"S. sandeel",'Rec']

y<-as.numeric(dimnames(values)[[1]])

if (include.F.reference.points | include.SSB.reference.points) ref.points<-Read.reference.points()

if (paper) dev<-"png" else dev<-"screen"
if (incl.sp[1]=="all") sp.plot<-unique(yield$Species) else sp.plot<-incl.sp

if (makeAllGraphs) dev<-'png'

len.dir<-length(dirs)

  plotvar<-function(sp=sp,vari='SSB',tit=vari,ylab='(1000t)') {
    v<-values[,,sp,vari]
    s<-stds[,,sp,vari]
    if (vari=='F') {v<-v*1000; s<-s*1000;}
    if (vari=='Rec') {v<-v/1000; s<-s/1000;}

    maxval<-max(v,na.rm=T)
    if (include.1.std) maxval<-max(v+s,na.rm=T)
    if (include.2.std) maxval<-max(v+2*s,na.rm=T)

    if ((gi %% (nox*noy))==0  | gi==0) {

      filename<-paste0("compare_",run.ID,'_',sp)
      if (makeAllGraphs) filename=file.path(compare.dir,filename)

      newplot(dev,nox,noy,filename=filename,Portrait=F);

      # make legends
      if (paper) lwds<-2  else lwds<-2
      par(mar=c(0,0,0,0))
      plot(10,10,axes=FALSE,xlab=' ',ylab=' ',xlim=c(0,1),ylim=c(0,1))
      legend("center",legend=labels,col=first.color:(first.color+len.dir-1),
              pch=first.pch:(first.pch-1+len.dir),cex=2,title=sp)
      gi<<-gi+1
      par(mar=c(2.5,5,3,1))   # c(bottom, left, top, right)
    }

    gi<<-gi+1

    gt0<-sum(v[,dirs[1]],na.rm=T)>0.01
    if (gt0) typ<-'b'  else typ<-'n'
    if (paper) lwds<-2 else lwds<-2;

    plot(y,v[,dirs[1]],main=tit,xlab="",ylab=ylab,
          type=typ,lwd=lwds,ylim=c(0,maxval),col=first.color,pch=first.pch)
    if (doGrid) grid()
    for (i in (2:len.dir)) {
      ii<-dirs[i]
      gt0<-sum(v[,ii],na.rm=T)>0.01
      #if (paper) lwds<-1 else  lwds<-2;

      if (gt0) lines(y,v[,ii],col=first.color+i-1,pch=first.pch+i-1,type='b',lwd=lwds)
    }

    if (include.1.std) {
       for (i in (1:len.dir)) lines(y,v[,ii]+s[,i],lty=2,col=i)
       for (i in (1:len.dir)) lines(y,v[,ii]-s[,i],lty=3,col=i)
    }
     if (include.2.std) {
       for (i in (1:len.dir)) lines(y,v[,ii]+2*s[,i],lty=2,col=i)
       for (i in (1:len.dir)) lines(y,v[,ii]-2*s[,i],lty=3,col=i)
    }

    if (include.assess.forcast.line) abline(v=SMS.control@last.year.model)

    if (include.SSB.reference.points & vari=="SSB") {
      if (ref.points[sp,"Blim"] >0) abline(h=ref.points[sp,"Blim"]/1000,lty=2)
      if (ref.points[sp,"Bpa"] >0) abline(h=ref.points[sp,"Bpa"]/1000,lty=3)
    }
    if (include.F.reference.points & vari=="F") {
      if (ref.points[sp,"Flim"] >0) abline(h=ref.points[sp,"Flim"],lty=2)
      if (ref.points[sp,"Fpa"] >0) abline(h=ref.points[sp,"Fpa"],lty=3)
    }
  }

  sp<-sp.plot[1]  #test only
 for (sp in (sp.plot)) {
  gi<-0

  plotvar(sp=sp,vari="Rec",tit="Recruits",ylab="(billions)")
  plotvar(sp=sp,vari="F",ylab=' ')
  plotvar(sp=sp,vari="SSB")
  #plotvar(sp=sp,vari="Yield",tit="Yield")
  #plotvar(sp=sp,vari="Yield.hat",tit="Expected Yield")
  #if (!single.species) plotvar(sp=sp,vari="Eaten",tit="Eaten biomass")
  if (dev %in% c('png','print')) cleanup()

}


# par <- c(3.961847,29.046383,37.934329,21.104493)
# Edit fun
APSIMEditFun <- function(par, nodes = editNodes){
  no.ofPara = length(par)
  id = paste0(abs(round(par,idLength)), collapse = '_')

  f = file(paste0(apsimx_sims_dir,"temp", id, ".txt"), "w")

  for(i in seq_len(no.ofPara)){
    line = paste0(nodes[i] , par[i])
    cat(line, "\r",
        sep ="\r",
        file = f,
        append = TRUE)
  }
  # Close the file and clean it from memory
  close(f)
  rm(f)
  gc()
}
# Run fun
APSIMRun = function(par)
{
  # Create a new name for the apsimx file

  id = paste0(abs(round(par,idLength)), collapse = '_')
  # Create a new name for the apsimx file
  newname = paste0(apsimx_sims_dir, 'temp', id, ".apsimx")

  # Copy base apsimx file to its new name
  system(paste("cp", apsimx_file, newname))

  # Modify the apsimx file
  system(paste(apsimx, newname, apsimx_flag,
               paste0(apsimx_sims_dir,"temp", id, ".txt")))

  # Execute the new apsimx file
  system(paste(apsimx, newname, "/NumberOfProcessors:8"))

}

library(RSQLite)

cost.function <- function(par, obspara){

    id = paste0(abs(round(par,idLength)), collapse = '_')
  print(par)

  APSIMEditFun(par)

  APSIMRun(par)

  # make(plan)

  totalCost = 0

  if (file.exists(paste0(apsimx_sims_dir, 'temp', id, '.db')))
  {
    db <- RSQLite::dbConnect(RSQLite::SQLite(),
                             paste0(apsimx_sims_dir, 'temp', id,'.db'))

    if("PredictedObserved" %in% dbListTables(db))
    {
    PredictedObserved <-   RSQLite::dbReadTable(db,"PredictedObserved")

    no.ofobspara = length(obspara)
    l = vector("list", length = no.ofobspara)
    names(l) = obspara

    for (i in seq_len(no.ofobspara)){
      pre_col = paste0("Predicted.", obspara[i])
      obs_col = paste0("Observed.", obspara[i])

      if(length(na.omit(PredictedObserved[[pre_col]]))> 1 &&
         length(na.omit(PredictedObserved[[obs_col]]))> 1)
      {
        l[[i]] = sum(na.omit(PredictedObserved[[pre_col]]-
                             PredictedObserved[[obs_col]])^2)

      } else {totalCost = 1e6;}

    }

    totalCost = sum(unlist(l))
    RSQLite::dbDisconnect(db)
    rm(db)
    gc()

  } else {totalCost = 1e6;}

  } else {totalCost = 1e6;}

  if(totalCost < 1)
    totalCost = 1e6

  # Generate multiple cost depends on user input of observation variables
  # obspara = "BudBurstDAWS"

  system(paste("rm", paste0(apsimx_sims_dir, "temp", id, "*")))

  return(totalCost)
}


use.prediction.M2<-F

######
#  simple average tables
a<-Read.part.M2.data()

# annual part M2
b<-tapply(a$Part.M2,list(a$Year,a$Predator,a$Prey,a$Prey.age),sum)
b[is.na(b)]<-0

c<-apply(b,c(3,4,2),mean)
#dimnames(c)[[3]]<-name[2:(npr+1)]
print(round(c[,1:4,],digits=4), zero.print=".")
print(round(c[,,],digits=4), zero.print=".")

ftable(round(c,3))

c<-apply(b,c(2,4,3),mean)
#dimnames(c)[[1]]<-name[2:(npr+1)]
print(round(c[,1:5,],digits=4), zero.print=".")

c2<-apply(c,c(3,2),sum)
print(round(c2,digits=3), zero.print = ".")

#########################

a<-Read.part.M2.data()
 print(unique(a$Predator))

## add prediction M2
if (use.prediction.M2) {
  b<-Read.part.M2.prediction.data()
  a<-rbind(a,b)
}
#

# annual part M2
b<-tapply(a$Part.M2,list(a$Year,a$Predator,a$Predator.age,a$Prey,a$Prey.age),sum)
b[is.na(b)]<-0

#print(round(b[,'Cod','1','Cod','0'],digits=3), zero.print = ".")
#print(round(b[,'Cod',,'Cod',1:3],digits=3), zero.print = ".")
#print(round(b[,'Whiting',,'Whiting',1:3],digits=3), zero.print = ".")
##########################################
#a<-subset(a,Part.M2>0 & Prey=='Sandeel' & Prey.age<=4)
a<-subset(a,Part.M2>0 &  Prey.age<=2)

# Special, condense of predators
if (T) {
  file<-file.path(data.path,'pred_format.dat')
  s<-read.table(file,header=TRUE)
  head(a)
  head(s)
  s<-merge(x=a,y=s,by='Predator',all.y=T)
   print(unique(s$Predator))
  #subset(s,is.na(Part.M2))
  s<- subset(s,!is.na(Part.M2))
  a<-aggregate(s$Part.M2,list(s$new,s$Year,s$new.no,s$Prey,s$Prey.no,s$Prey.age),sum)
  names(a)<-c("Predator","Year","Predator.no","Prey","Prey.no","Prey.age","Part.M2")

  print(unique(a$Predator))

  cleanup()
  dev<-"print"
  dev<-"screen"
  dev<-"testprint"
  nox<-2
  noy<-2

  i<-0
  all.pred.col<-sort(unique(a$Predator.no),decreasing = TRUE)
  all.prey.col<-sort(unique(a$Prey.no),decreasing = TRUE)
  all.names<-rep('aaa',length(all.pred.col))
  new.names<- c('Birds','R.radiata','G.gurnards','Mackerel','H. mackerel','Grey seal','Harbour porpoise','Cod','Whiting','Haddock','Saithe')
  for (s in (1:length(all.pred.col))) all.names[s]<-new.names[all.pred.col[s]]

  palette(rainbow(11))
  palette(c('red','green','plum','blue','cyan','yellow','coral','skyblue','purple','magenta','limegreen' ))

 cleanup()
 by(a,list(a$Prey),function(x) {
      b<- tapply(x$Part.M2,list(x$Predator.no,x$Year),sum)
      b[is.na(b)]<-0
      pred.no<-as.numeric(dimnames(b)[[1]])
      v<-pred.no
      for (l in (1:length(v))) pred.no[l]<-v[length(v)-l+1]
      pred.names<-rep('aaa',length(pred.no))
      v<-pred.names
      for (l in (1:length(v))) pred.names[l]<-v[length(v)-l+1]
      for (s in (1:length(pred.no))) pred.names[s]<-new.names[pred.no[s]]

  by(x,list(x$Prey.age,x$Prey),function(x) {

      b<- tapply(x$Part.M2,list(x$Predator.no,x$Year),sum)
      b[is.na(b)]<-0
      pred.no.age<-as.numeric(dimnames(b)[[1]])
      pred.names.age<-rep('aaa',length(pred.no.age))
      for (s in (1:length(pred.no.age))) pred.names.age[s]<-new.names[pred.no[s]]

      length.names<-dimnames(b)[[2]]
      if ((i %% (nox*noy-1))==0) {
        #newplot(dev,nox,noy,Portrait=TRUE);
        newplot(dev,nox,noy,w8=12,w11=12,Portrait=TRUE,pointsize=12);

         par(mar=c(3,2,2,1))  #  c(bottom, left, top, right)
        plot.new(); legend(x=0,y=1,pred.names,fill=pred.no,cex=1.0,col=pred.no)
        }
      i<<-i+1

      barplot(b,space=0.4,names=length.names,col=pred.no.age)
      title(main=paste(x[1,]$Prey,"age:",x[1,]$Prey.age))
  })
  })

}

cleanup()
dev<-"print"
dev<-"screen"
nox<-2
noy<-2

i<-0
all.pred.col<-sort(unique(a$Predator.no),decreasing = TRUE)
all.prey.col<-sort(unique(a$Prey.no),decreasing = TRUE)
all.names<-rep('aaa',length(all.pred.col))
for (s in (1:length(all.pred.col))) all.names[s]<-sp.names[all.pred.col[s]]

by(a,list(a$Prey.age,a$Prey),function(x) {
    b<- tapply(x$Part.M2,list(x$Predator.no,x$Year),sum)
    b[is.na(b)]<-0

    pred.no<-as.numeric(dimnames(b)[[1]])
    pred.names<-rep('aaa',length(pred.no))
    for (s in (1:length(pred.no))) pred.names[s]<-sp.names[pred.no[s]]
    print(names)
    length.names<-dimnames(b)[[2]]
    if ((i %% (nox*noy-1))==0) {
      newplot(dev,nox,noy,Portrait=TRUE);
      par(mar=c(3,5,3,2))
      plot.new(); legend(x=0,y=1,pred.names,fill=pred.no,cex=1.0,ncol=2)
    }
    i<<-i+1
    barplot(b,space=0.4,names=length.names,col=pred.no)
    title(main=paste(x[1,]$Prey,"age:",x[1,]$Prey.age))
})

cleanup()
newplot(dev,nox,noy,Portrait=TRUE);

ii<-1
for (prey in (1:dim(c)[3])) {
 cat(paste("\nprey:",dimnames(c)[[3]][prey],'\n'))
 bb<-c[,,prey]
 bb<-rbind(bb,c2[prey,])
 dimbb<-dim(bb)[2]
 cut<-0
 for (i in (dimbb:1)) { if (c2[prey,i]==0) cut=cut+1 else break}
 out<-bb[,1:(dimbb-cut)]
 print(round(out,digits=3), zero.print = ".")

 out<-out[1:(dim(out)[1]-1),]

 psum<-apply(out,1,sum)

 d<-dim(out)[1]
 for (i in (d:1)) if (psum[i]==0) out<-out[-i,]

 if ((ii %% (nox*noy))==0) {
      newplot(dev,nox,noy,Portrait=TRUE);
 }
 barplot(out,xlab='age',ylab='M2',col=1:dim(out)[2],names=dimnames(out)[[2]])
 legend(x="topright",legend=dimnames(out)[[1]],fill=1:dim(out)[2])
 title(main=paste(dimnames(c)[[3]][prey]))
 ii<-ii+1
}

a<-Read.part.M2.data()
# annual part M2
b<-tapply(a$Part.M2,list(a$Year,a$Predator,a$Predator.age,a$Prey,a$Prey.age),sum)
b[is.na(b)]<-0
dimnames(b)

c<-apply(b,c(4,5,2,3),mean)

d<-c['Cod',,,]
dimnames(d)

d<-d[1:3,,]
dimnames(d)

e<-apply(d,c(2,3,1),sum)
print(round(e,digits=4), zero.print=".")

# special cod
a<-Read.part.M2.data()
# quarterly part M2
b<-tapply(a$Part.M2,list(a$Year,a$Predator,a$Predator.age,a$Prey,a$Prey.age,a$Quarter.1),sum)
b[is.na(b)]<-0
dimnames(b)

c<-apply(b,c(6,4,5,2,3),mean)
dimnames(c)

#d<-c[,'Cod',,c('Cod','Whiting'),]
d<-c[,'Cod',,c('Cod'),]
dimnames(d)

d<-d[,1:3,]
dimnames(d)

print(round(d,digits=4), zero.print=".")

# sandeel;
a<-Read.part.M2.data()
a<-subset(a,Prey=='Sandeel' & Year>=1983)
a$halfyear<-2
a$halfyear[a$Quarter==1 | a$Quarter==2]<-1
b<-tapply(a$Part.M2,list(a$Year,a$Prey.age,a$halfyear),sum)
b[is.na(b)]<-0
b

cleanup()
nox<-2
noy<-3
dev<-"screen"

newplot(dev,nox,noy,Portrait=TRUE);
par(mar=c(3,5,3,2))
for (age in (0:4)) {
 barplot(t(b[,age+1,]),xlab='Year',ylab='M2',col=1:2 )
  title(main=paste('age ',age,':\nfirst=',formatC(mean(b[,age+1,1]),digits=2),', second=',formatC(mean(b[,age+1,2]),digits=2),sep=''))
}

# sandeel;
a<-Read.part.M2.data()
a<-subset(a,Prey=='Sandeel' & Year>=1983)
a$halfyear<-2
a$halfyear[a$Quarter==1 | a$Quarter==2]<-1
b<-tapply(a$Part.M2,list(a$Year,a$Prey.age,a$halfyear),sum)
b[is.na(b)]<-0
b

  palette(rainbow(9))
cleanup()
nox<-2
noy<-3
dev<-"screen"
b<-b+0.1
b[,1,1]<-0 # first half, age 0

newplot(dev,nox,noy,Portrait=TRUE);
par(mar=c(3,5,3,2))
for (age in (0:4)) {
 barplot(t(b[,age+1,]),xlab='Year',ylab='M1+M2',col=1:2 )
  title(main=paste('age ',age,':\nfirst=',formatC(mean(b[,age+1,1]),digits=2),', second=',formatC(mean(b[,age+1,2]),digits=2),sep=''))
}

b<-tapply(a$Part.M2,list(a$Year,a$Prey.age,a$Quarter),sum)
b[is.na(b)]<-0
b

#cleanup()
X11()
nox<-2
noy<-3

newplot(dev,nox,noy,Portrait=TRUE);
par(mar=c(3,5,3,2))
for (age in (0:4)) {
 barplot(t(b[,age+1,]),xlab='Year',ylab='M2',col=1:4 )
  title(main=paste('age ',age,':\nQ1=',formatC(mean(b[,age+1,1]),digits=2),
                              ', Q2=',formatC(mean(b[,age+1,2]),digits=2),
                              ', Q3=',formatC(mean(b[,age+1,3]),digits=2),
                              ', Q4=',formatC(mean(b[,age+1,4]),digits=2),sep='')
                              )
}

aa<-subset(a,Year>=1982)
b<-tapply(aa$Part.M2,list(aa$Year,aa$Prey.age),sum)
bb<-apply(b,2,mean)


# If you use this code or parts of it, please cite the following paper
# Bruhin A., E. Fehr, D. Schunk (2018): "The Many Faces of Human Sociality: Uncovering the Distribution and Stability of Social Preferences",
# Journal of the European Economic Association, forthcoming.
# ===========================================================================================================================================

rm(list=ls()) # Clear the memory
source("99_estim_functions_aggregate_individual.r") # Load the required functions for performing the estimations
set.seed(51)

d.exp1 <- read.table("choices_exp1.csv", sep=",", header=T)
d.exp2 <- read.table("choices_exp2.csv", sep=",", header=T)

cat("\n\nSESSION 1\n")
iest1 <- f.indivest(d.exp1) # Estimate on Session 1 Data
cat("\n\nSESSION 2\n")
iest2 <- f.indivest(d.exp2) # Estimate on Session 2 Data

# Identify erratic subjects with parameter estiamates outside the identifiable range and drop them (see 2nd paragraph of section 4)
drop        <- f.droperratic(iest1, iest2)
sid.drop    <- as.numeric(names(drop)[drop>0]) # IDs of subjects that need to be dropped
iest1.valid <- iest1[(row.names(iest1) %in% names(drop)[drop>0]) == F,]
iest2.valid <- iest2[(row.names(iest2) %in% names(drop)[drop>0]) == F,]
write.table(sid.drop, "dropped_subjects_section4paragraph2.csv", sep=",", col.names=F, row.names=F) # Create file with IDs of dropped subjects

cat("\n\n\n---- SUMMARY STATS OF INDIVIDUAL ESTIMATES: SESSION 1 ----\n")
print(summary(iest1.valid))
cat("\nStandard Deviations\n")
print(apply(iest1.valid,2,sd))

cat("\n\n\n---- SUMMARY STATS OF INDIVIDUAL ESTIMATES: SESSION 2 ----\n")
print(summary(iest2.valid))
cat("\nStandard Deviations\n")
print(apply(iest2.valid,2,sd))

# Write the results into two csv files
out1 <- cbind(as.numeric(rownames(iest1.valid)), iest1.valid)
out2 <- cbind(as.numeric(rownames(iest2.valid)), iest2.valid)
colnames(out1)[1] <- "sid"
colnames(out2)[1] <- "sid"

write.table(out1, "individual_est_exp1.csv", col.names=T, row.names=F, sep=",")
write.table(out2, "individual_est_exp2.csv", col.names=T, row.names=F, sep=",")


###############################################################################
# Analysis by sample
###############################################################################
i <- 1
cbp <- 5

bindir3 <- paste0(parentdir, "/motif_counts/3-mers/full")
p2 <- "1000kb_full.txt"
bins1Mb <- get_bins(bindir3, p2)
bins1Mb$CHR <- gsub("chr", "", bins1Mb$CHR)

get_mct_b <- function(bins){
  out <- bins %>%
  	group_by(CHR, BIN, Motif) %>%
  	summarise(nMotifs=sum(nMotifs))
  return(out)
}

# Count singletons per 3-mer subtype per individual
ind_counts <- full_data$sites %>%
  mutate(Type=gsub("cpg_", "", Category2),
    SEQA=substr(Motif, cbp-i, cbp+i),
    SEQB=substr(Motif, cbp*3-i, cbp*3+i),
    Motif=paste0(SEQA, "(", SEQB, ")")) %>%
  group_by(ID, Type, Motif) %>%
  summarise(n=n())

# count 3-mer motifs genome-wide
mct3 <- get_mct_b(bins1Mb) %>%
  group_by(Motif) %>%
  summarise(nMotifs=sum(nMotifs))

# get ids in ped file
ped <- read.table(pedfile, header=F, stringsAsFactors=F)
names(ped)[1] <- "ID"

pheno <- read.table(phenofile, header=T, stringsAsFactors=F)
pheno <- pheno %>%
  # filter(DROP==FALSE) %>%
  dplyr::select(ID=SEQID, Sex, Case.Control, Study, DROP) %>%
  filter(!(is.na(ID)))

qplotdat <- read.table(qplotfile, header=T, stringsAsFactors=F)
names(qplotdat)[1] <- "ID"

contam <- read.table(contamfile, header=T, stringsAsFactors=F)
names(contam) <- c("ID", "FREEMIX", "CHIPMIX", "PLATE")

vcfast <- read.table(vcfastfile,
  header=T, stringsAsFactors=F, sep="\t", comment.char=" ")
names(vcfast) <- c("ID", "SNPs", "Singletons", "Doubletons", "lt0.5", "gt0.5", "Ref", "Het", "Alt", "Heterozygosity")

# ped <- merge(ped, contam, by.x="V1", by.y="SAMPLE")
# ped2a<-merge(ped, vcfast, by="ID")

pcs <- read.table(pcfile, header=F, stringsAsFactors=F, skip=1)
names(pcs) <- c("ID", paste0("PC",1:10), "Study")
pcs <- pcs %>%
  dplyr::select(-Study)

p1 <- merge(pheno, pcs, by="ID")
p2 <- merge(p1, vcfast, by="ID")
p3 <- merge(p2, contam, by="ID", all.x=TRUE) %>% distinct(ID, .keep_all = TRUE)

# Get PED ids ending with B (not in ped2 file)
# paste0(ped2$ID, "B")
ped_b_ids <- p3[!(p3$ID %in% qplotdat$ID),] %>%
  dplyr::select(ID_B=ID) %>%
  mutate(ID=gsub("B", "", ID_B))

ped1B <- ped_b_ids %>%
  filter(ID %in% ped_b_ids$ID_B) %>%
  mutate(ID=gsub("B", "", ID))

 # ped %>%
 #  filter(ID %in% p1_ids$ID)

# Subset ped2 to B ids
qplotB <- qplotdat %>%
  filter(ID %in% ped_b_ids$ID) %>%
  mutate(ID=paste0(ID, "B"))

qplot2 <- rbind(qplotdat, qplotB)
p4 <- merge(p3, qplot2, by="ID")

# ped[(ped$V1 %in% paste0(ped2$ID, "B")),] %>% dplyr::select(V1)

# get per-person rates and filter IDs
ind_counts <- merge(ind_counts, mct3, by="Motif") %>%
  filter(ID %in% p4$ID) %>%
  mutate(ERV_rel_rate=n/nMotifs,
    subtype=paste0(Type, "_", Motif))

# Coerce from long to wide format
# ind_wide <- ind_counts  %>%
#   dplyr::select(ID, subtype, n) %>%
#   spread(subtype, n)

# # Alternative to ERV rates--use
# iw2 <- sweep(ind_wide[,-1], 2, colSums(ind_wide[,-1]),`/`)
# ind_wide <- data.frame(ID=ind_wide[,1], iw2)

# # Run PCA on sample matrix
# ind_pca <- prcomp(scale(ind_wide[,-c(1)]))
#
# # Cumulative variance explained by 96 PCs
# ind_cumvar <- cumsum((ind_pca$sdev)^2) / sum(ind_pca$sdev^2)
#
# # Data frame containing sample IDs and components
# ind_wide_c_pcs <- cbind(ID=ind_wide$ID, as.data.frame(ind_pca$x))
#
# # Run NMF on sample matrix; get top signature for each sample
# # set.seed(36087318)
#
# # ner<-nmfEstimateRank(as.matrix(ind_wide[,-c(1)]), seq(2,5), nrun=10)

###############################################################################
# get signature loadings
###############################################################################
get_loads <- function(widedat, nmfdat){
  sigloads <- data.frame(subtype=names(widedat),
    sig1=coef(nmfdat)[1,],
    sig2=coef(nmfdat)[2,],
    sig3=coef(nmfdat)[3,]) %>%
    mutate(sig1=sig1/sum(sig1), sig2=sig2/sum(sig2), sig3=sig3/sum(sig3)) %>%
    gather(subtype, value)

  names(sigloads) <- c("subtype", "sig", "value")
  sigloads <- sigloads %>%
    mutate(Category=substr(subtype, 1, 5),
      Sequence=substr(subtype, 7, 14))

  return(sigloads)
}

###############################################################################
# plot signature loadings
###############################################################################
plot_loads <- function(sigloads){
  p <- ggplot(sigloads, aes(x=Sequence, y=value, fill=sig))+
    geom_bar(stat="identity")+
    facet_grid(sig~Category, scales="free_x")+
    # geom_label_repel(data=sigloads[sigloads$sig3>0.005,], aes(x=sig2, y=sig3, label=subtype))+
    theme_bw()+
    theme(axis.text.x=element_text(angle=90, hjust=1),
      strip.text=element_text(size=16),
      legend.position="none")
  return(p)
}

###############################################################################
# plot signature contribution across individuals
###############################################################################
plot_ind_sigs <- function(sigdat){
  p <- ggplot(sigdat,
      aes(x=ID, y=prob, group=factor(Signature), colour=factor(Signature)))+
    geom_line()+
    scale_x_discrete(expand=c(0,0))+
    scale_y_continuous(expand=c(0,0), limits=c(0,1))+
    facet_wrap(~Study, scales="free_x", nrow=1)+
    ylab("signature contribution")+
    theme_bw()+
    theme(axis.text.x=element_blank(),
      legend.position="bottom")

  return(p)
}

plot_ind_sigs2 <- function(sigdat){
  p <- ggplot(sigdat,
      aes(x=ID, y=prob, group=factor(Signature), colour=factor(Signature)))+
    geom_line()+
    scale_x_discrete(expand=c(0,0))+
    scale_y_continuous(expand=c(0,0), limits=c(0,1))+
    facet_wrap(~top_r, scales="free_x", nrow=1)+
    ylab("signature contribution")+
    theme_bw()+
    theme(axis.text.x=element_blank(),
      legend.position="bottom")

  return(p)
}

###############################################################################
# Prepare data and run NMF
###############################################################################
ind_wide <- ind_counts  %>%
  dplyr::select(ID, subtype, ERV_rel_rate) %>%
  # dplyr::select(ID, subtype, n) %>%
  spread(subtype, ERV_rel_rate)
  # spread(subtype, n)

ind_wide[is.na(ind_wide)] <- 0

# ind_wide <- ind_wide[,-c(64,60,56,52)]

ind_nmf <- nmf(as.matrix(ind_wide[,-c(1)]), 3, nrun=10)
ind_pred <- predict(ind_nmf, "rows", prob=T)

sigloads <- get_loads(ind_wide[,-c(1)], ind_nmf)
plot_loads(sigloads)
ggsave(paste0(parentdir, "/images/sigloads.png"), width=12, height=6)

# Add NMF basis and predicted class to data frame
nmfdat1 <- data.frame(ID=ind_wide$ID, basis(ind_nmf), sig=ind_pred[[1]])

# head(nmfdat)
# summary(nmfdat1$sig)
#
# samples <- ped %>%
#   dplyr::select(ID=V1, Study=V7, BP=V6, PC1=V14, PC2=V15, PC3=V16, PC4=V17)

nmfdat1 <- merge(nmfdat1, p4, by="ID") %>%
  mutate(sum=X1+X2+X3,
    sig1=X1/sum,
    sig2=X2/sum,
    sig3=X3/sum) %>%
  mutate(top_r=apply(.[,51:53], 1, function(x) names(x)[which.max(x)]))

nmfdat1$ID <- factor(nmfdat1$ID, levels = unique(nmfdat1$ID))

svmdat <- nmfdat1 %>%
  filter(!(is.na(PLATE))) %>%
  filter(!(is.na(CHIPMIX)))

# nsvm<-svm(factor(top_r)~Singletons+Heterozygosity+CHIPMIX+PLATE+insmedian+zeromap+coverage+gcbias, svmdat)
# nsvm<-svm(sig1~Singletons+Heterozygosity+CHIPMIX+PLATE+insmedian+zeromap+coverage+gcbias, svmdat)
# pred_class <- predict(nsvm, svmdat)
# cor(svmdat$sig1, pred_class)

# plates <- read.table(plates, header=F, stringsAsFactors=F)
# names(plates) <- c("ID", "PLATE")
# nmfdat1 <- merge(nmfdat1, plates, by="ID")

ind_nmf_long <- nmfdat1 %>%
  gather(Signature, prob, sig1:sig3) %>%
  mutate(Signature=as.numeric(gsub("sig", "", Signature))) %>%
  arrange(Study, sum)

plot_ind_sigs(ind_nmf_long)
ggsave(paste0(parentdir, "/images/by_ind_all.png"), width=8, height=6)

plot_ind_sigs2(ind_nmf_long)
ggsave(paste0(parentdir, "/images/by_ind_all_by_sig.png"), width=8, height=6)

inl2 <- ind_nmf_long %>%
  group_by(ID) %>%
  # filter(Signature!=1) %>%
  filter(prob==max(prob))

ggplot(inl2, aes(x=PC1, y=PC2, colour=Signature))+
  geom_point(alpha=0.5)
ggsave(paste0(parentdir, "/images/ind_pc_proj.png"), width=8, height=6)

ggplot()+
  geom_point(data=inl2[inl2$sig==3,],
    aes(x=PC1, y=PC2, colour="gray70"))+
  geom_point(data=inl2[inl2$sig==2,],
    aes(x=PC1, y=PC2, colour="red"), size=3)+
  geom_point(data=inl2[inl2$sig==1,],
    aes(x=PC1, y=PC2, colour="cyan"), size=3)+
  scale_colour_manual(name = 'Dominant\nSignature',
    values = c('cyan'='cyan', 'red'='red', 'gray70'='gray70'),
    breaks = c('cyan', 'red', 'gray70'),
    labels = c(1,2,3))+
  theme_bw()+
  theme(axis.title.x=element_text(size=16),
    axis.title.y=element_text(size=16),
    legend.title=element_text(size=16),
    legend.text=element_text(size=14),
    legend.position = c(.1, .1),
    legend.box.background = element_rect())
ggsave(paste0(parentdir, "/images/sig_snp_pcs.png"), width=8, height=8)

sumdat <- nmfdat1 %>%
  # filter(sig!=2) %>%
  group_by(sig) %>%
  dplyr::select(ID, sig, Singletons, CHIPMIX, gcbias, insmedian, Heterozygosity, coverage) %>%
  filter(coverage < 15) %>%
  gather(var, val, Singletons:coverage) %>%
  group_by(sig, var)

sumdat %>%
  summarise(mean=mean(val, na.rm=T))

ggplot(sumdat, aes(x=sig, y=val, group=sig, fill=sig))+
  geom_boxplot()+
  facet_wrap(~var, scales="free")
ggsave(paste0(parentdir, "/images/gp_qc.png"))

# cbind(ind_wide, g2=nmfdat1$sig) %>%
#   mutate(g2=ifelse(g2==1, TRUE, FALSE)) %>%
#   mutate(key=paste0(ID, "+", g2)) %>%
#   dplyr::select(-c(ID, g2)) %>%
#   gather(key, val) %>% setNames(c("IDf", "key2", "val")) %>%
#   tidyr::separate(IDf, into=c("ID", "g2"), sep="[+]") %>% #head
#   mutate(Category=substr(key2, 1, 5),
#     Sequence=substr(key2, 7, 14)) %>%
#   group_by(Category, Sequence) %>%
#   do(tidy(t.test(val~g2, data=.))) %>% #head %>% data.frame
#   dplyr::select(Category, Sequence, estimate1, estimate2, p.value) %>%
#   # filter(Category=="GC_TA")
#   filter(p.value<0.05/96)

###############################################################################
# IDs to keep
###############################################################################
keep_cis <- ind_nmf_long %>%
  dplyr::select(Signature, prob) %>%
  group_by(Signature) %>%
  summarise_each(funs(mean,sd)) %>%
  mutate(conf.low=mean-1.96*sd, conf.high=mean+1.96*sd)
  # do(tidy(t.test(.$prob))) %>%
  # dplyr::select(cluster, conf.low, conf.high)

nmfdat1 <- nmfdat1 %>%
  mutate(flag=ifelse(sig1 > keep_cis[1,]$conf.high, "sig1",
   ifelse(sig3 > keep_cis[3,]$conf.high, "sig3", "sig2")))

keep_ids <- nmfdat1 %>%
  filter(sig1 > keep_cis[1,]$conf.low & sig1 < keep_cis[1,]$conf.high) %>%
  filter(sig2 > keep_cis[2,]$conf.low & sig2 < keep_cis[2,]$conf.high) %>%
  filter(sig3 > keep_cis[3,]$conf.low & sig3 < keep_cis[3,]$conf.high) %>%
  dplyr::select(ID)

drop_ids <- nmfdat1 %>%
  filter(!(ID %in% keep_ids$ID)) %>%
  dplyr::select(ID, flag)

ind_nmf_long %>%
  filter(ID %in% keep_ids$ID) %>%
plot_ind_sigs()
ggsave(paste0(parentdir, "/images/by_ind_post_filter.png"), width=8, height=6)

# cnv_drops <- read.table("/net/snowwhite/home/jedidiah/drops.txt", header=F)
# names(cnv_drops) <- "ID"
# cnv_drops$gp <- "CNV"

# ped2$drop <- (ped2$HAID %in% drop_ids$ID)
# ped2 %>% do(tidy(t.test(gcbias~drop, data=.)))
# ped2 %>%
#   group_by(drop) %>%
#   summarise(cov=mean(coverage),
#     sing=mean(Singletons),
#     gcbias=mean(gcbias),
#     insmedian=mean(insmedian))

# plates <- read.table(plates, header=F, stringsAsFactors=F)
# names(plates) <- c("ID", "PLATE")
# nmfdat1 <- merge(nmfdat1, plates, by="ID")

###############################################################################
# Repeat with kept IDs
###############################################################################
ind_wide2 <- ind_wide %>%
  filter(ID %in% keep_ids$ID)
ind_nmf2 <- nmf(ind_wide2[,-c(1)], 3, nrun=10)
ind_pred2 <- predict(ind_nmf2, "rows", prob=T)

sigloads <- get_loads(ind_wide2[,-c(1)], ind_nmf2)
plot_loads(sigloads)
ggsave(paste0(parentdir, "/images/sigloads2.png"), width=12, height=6)

nmfdat2 <- data.frame(ID=ind_wide2$ID, basis(ind_nmf2), sig=ind_pred2[[1]])

nmfdat2 <- merge(nmfdat2, p4, by="ID") %>%
  mutate(sum=X1+X2+X3,
    sig1=X1/sum,
    sig2=X2/sum,
    sig3=X3/sum)

nmfdat2$ID <- factor(nmfdat2$ID, levels = unique(nmfdat2$ID))

ind_nmf_long <- nmfdat2 %>%
  gather(Signature, prob, sig1:sig3) %>%
  arrange(Study, sum)

plot_ind_sigs(ind_nmf_long)
ggsave(paste0(parentdir, "/images/by_ind_keep.png"), width=12, height=8)

# test for significant differences between groups
cbind(ind_wide2, g2=nmfdat2$sig) %>%
  mutate(g2=ifelse(g2==1, TRUE, FALSE)) %>%
  # mutate(g2=(ID %in% s2ids$ID)) %>% # dplyr::select(ID, AT_CG_AAA.TTT., g2) %>% group_by(g2) %>% summarise(val=mean(AT_CG_AAA.TTT.))
  # group_by(g2) %>%
  mutate(key=paste0(ID, "+", g2)) %>%
  dplyr::select(-c(ID, g2)) %>%
  gather(key, val) %>% setNames(c("IDf", "key2", "val")) %>%
  tidyr::separate(IDf, into=c("ID", "g2"), sep="[+]") %>% #head
  # tidyr::separate(key2, into=c("ID", "g2"), sep="[+]") %>%
  mutate(Category=substr(key2, 1, 5),
    Sequence=substr(key2, 7, 14)) %>%
  group_by(Category, Sequence) %>%
  do(tidy(t.test(val~g2, data=.))) %>% #head %>% data.frame
  dplyr::select(Category, Sequence, estimate1, estimate2, p.value) %>%
  # filter(Category=="GC_TA")
  filter(p.value<0.05/96)

ggplot()+
  geom_point(data=nmfdat2[nmfdat2$sig==3,],
    aes(x=PC4, y=PC2), colour="gray30", alpha=0.3)+
  geom_point(data=nmfdat2[nmfdat2$sig==1,],
    aes(x=PC4, y=PC2), colour="blue", alpha=0.3)+
  geom_point(data=nmfdat2[nmfdat2$sig==2,],
    aes(x=PC4, y=PC2), colour="yellow", alpha=0.3)+
  theme_bw()
ggsave("/net/bipolar/jedidiah/mutation/images/sig_snp_pcs.png", width=8, height=8)

###############################################################################
# Correlate with Alexandrov's somatic signatures
###############################################################################

somatic_corr <- 0

if(somatic_corr){
  cs <- read.table(paste0(parentdir, "/cancer_sigs.txt"), header=T, sep="\t")

  cs <- cs[,1:33]

  snames <- paste0("S", 1:30)

  names(cs) <- c("Category", "Seq3", "Type", snames)

  cs$Category <- as.factor(cs$Category)
  levels(cs$Category) <- c("GC_TA", "GC_CG", "GC_AT", "AT_TA", "AT_GC", "AT_CG")

  cs$Seq3a <- as.character(reverse(complement(DNAStringSet(cs$Seq3))))
  #cs<-cs %>% mutate(Seq3b=revcomp(Seq3))
  #cs$Seq3a<-apply(cs$Seq3, 2, function(x) revcomp(x))

  cs$Sequence <- ifelse(
    substr(cs$Seq3,2,2)<substr(cs$Seq3a,2,2),
    paste0(cs$Seq3,"(",cs$Seq3a,")"),
    paste0(cs$Seq3a,"(",cs$Seq3,")")
  )

  cs2 <- cs %>%
    arrange(Category, Sequence) %>%
    mutate(subtype=paste0(Category, "_", Sequence))

  bin_coefs <- data.frame(subtype=colnames(coef(bins_nmf)), t(coef(bins_nmf)))
  names(bin_coefs) <- c("subtype", "binsig1", "binsig2", "binsig3")

  ind_coefs <- data.frame(subtype=colnames(coef(ind_nmf)), t(coef(ind_nmf)))
  names(ind_coefs) <- c("subtype", "indsig1", "indsig2", "indsig3")

  cs2 <- merge(cs2, bin_coefs, by="subtype")
  cs2 <- merge(cs2, ind_coefs, by="subtype")

  corrheat <- cs2 %>%
    dplyr::select(c(S1:S30, binsig1:binsig3, indsig1:indsig3)) %>%
    correlate() %>%
    focus(c(binsig1:binsig3, indsig1:indsig3)) %>%
    gather(key, correlation, -rowname)

  corrheat$rowname <- as.factor(corrheat$rowname)
  levels(corrheat$rowname) <- paste0("S", 1:30)

  ggplot(corrheat, aes(x=key, y=rowname, fill=correlation))+
    geom_tile()+
    xlab("ERV Signature")+
    ylab("Somatic Signature")+
    scale_fill_gradient(low="white",high="darkgreen")
  ggsave(paste0(parentdir, "/images/sigheat.png"))

}

###############################################################################
# Additional QC
###############################################################################
ind_extra <- 0
if(ind_extra){
  sig1 <- ind_wide_c %>%
    filter(sig==1)

  sig1 <- nmfdat1 %>% filter(sig==1)
  sig2 <- nmfdat1 %>% filter(sig==2)

  ped2 %>%
    filter(HAID %in% sig1$ID)

  ped2 %>%
    dplyr::select(HAID, N_SNPs, Singletons, Study, coverage, qcfail) %>%
    filter(HAID %in% sig2$ID)

  gcb_hi<-ped2 %>%
    arrange(desc(gcbias)) %>%
    dplyr::select(ID=HAID, gcbias, Study) %>%
    head(300) %>%
    arrange(ID)

  sig1_2<-nmfdat1 %>%
    filter(sig==1) %>%
    arrange(desc(prob)) %>%
    dplyr::select(ID, Study, sig, PLATE) %>%
    arrange(ID) %>%
    distinct(ID, .keep_all = TRUE)

  sig1_2 %>% group_by(PLATE) %>% summarise(n=n())

  sig1_2$gcb_hi <- sig1_2$ID %in% gcb_hi$ID
  sig1_2 <- merge(sig1_2, gcb_hi, by="ID", all.x=T)
  sig1_2 %>% arrange(desc(gcbias)) %>% head(50)

}


#' Estimate cell counts from a reference
#'
#' Estimate cell type ratios from methylation profiles of purified cell populations
#' (Infinium HumanMethylation450 BeadChip).
#'
#' @param object An object created by \code{\link{meffil.create.qc.object}()}.
#' @param verbose If \code{TRUE}, then status messages are printed during execution
#' (Default: \code{FALSE}).
#' @param cell.type.reference Character string name of the cell type reference
#' to use for estimating cell counts.
#' See \code{\link{meffil.list.cell.type.references}()} for a list of available
#' references.  New references can be created using
#' \code{\link{meffil.create.cell.type.reference}()}.
#' @return A list:
#' - \code{counts} Cell count estimates.
#' - \code{beta} Normalized methylation levels of sites used to differentiate
#' - \code{reference} Name of the cell type reference used.
#' between reference cell types.
#'
#' Results should be nearly identical to \code{\link[minfi]{estimateCellCounts}()}.
#'
#' @export
meffil.estimate.cell.counts <- function(qc.object, cell.type.reference, verbose=T) {
    stopifnot(is.qc.object(qc.object))
    stopifnot(is.character(cell.type.reference) && cell.type.reference %in% meffil.list.cell.type.references())

    reference.object <- get.cell.type.reference(cell.type.reference)

    if (is.null(qc.object$featureset)) { ## backwards compatibility
        qc.object$chip <- qc.object$featureset <- "450k"
    }

    rg <- read.rg(qc.object$basename, verbose=verbose)
    probes <- meffil.probe.info(qc.object$chip, reference.object$featureset)
    rg <- background.correct(rg, probes, verbose=verbose)
    rg <- dye.bias.correct(rg, probes, qc.object$dye.intensity, verbose=verbose)
    mu <- rg.to.mu(rg, probes)

    estimate.cell.counts.from.mu(mu, cell.type.reference, verbose)
}

estimate.cell.counts.from.mu <- function(mu, cell.type.reference, verbose=F) {
    stopifnot(is.character(cell.type.reference) && cell.type.reference %in% meffil.list.cell.type.references())

    reference.object <- get.cell.type.reference(cell.type.reference)

    mu <- quantile.normalize.signals(mu, reference.object$subsets, reference.object$quantiles, verbose=F)
    beta <- get.beta(mu$M, mu$U)
    beta <- beta[rownames(reference.object$beta)]
    counts <- estimate.cell.counts.from.beta(beta, reference.object$beta)

    list(class="cell.counts",
         version=packageVersion("meffil"),
         counts=counts,
         beta=beta,
         reference=cell.type.reference)
}

is.cell.count.object <- function(object)
    is.list(object) &&
    ("class" %in% names(object) && object$class == "cell.counts"
     || "origin" %in% names(object) && object$origin == "meffil.estimate.cell.counts") ## backwards compatibility

quantile.normalize.signals <- function(mu, subsets, quantiles, verbose=F) {
    stopifnot(is.mu(mu))
    stopifnot(length(subsets) == length(quantiles))
    stopifnot(all(names(subsets) %in% names(quantiles)))

    for (subset.name in names(subsets)) {
        subset <- subsets[[subset.name]]
        for (target in c("M","U")) {
            data <- matrix(mu[[target]][subset])
            full.quantiles <- quantiles[[subset.name]][[target]]
            full.quantiles <- approx(1:length(full.quantiles), full.quantiles, 1:length(data))$y
            mu[[target]][subset] <- preprocessCore::normalize.quantiles.use.target(data,full.quantiles)
        }
    }
    mu
}

## Input:
## beta[CpG] = methylation level of the CpG in the sample
## beta.cell.types[CpG,cell type] = methylation level of CpG in the cell type
##
## Output:
## counts[cell type] = proportion of cell type in the sample
## that minimizes ( beta - beta.cell.types * counts )^2
## subject to counts >= 0.
##
## Based on code from PMID 22568884.
estimate.cell.counts.from.beta <- function(beta, beta.cell.types) {
    stopifnot(length(beta) == nrow(beta.cell.types))

    ## Let r = counts[cell type],
    ##     b = beta[cpg]
    ##     bc = beta.cell.types[cpg,cell type]
    ## for a given sample.
    ## We want to find r >= 0 that minimizes (b - bc r)^2.
    ## The unknown r is quadratic in the expression so
    ## we need a quadratic program solver.
    ##
    ## We use the function solve.QP(D,d,A,b0).
    ## It finds a vector b1 that minimizes
    ##   b1T D b1 - 2 dT b1 subject to AT b1 >= b0.
    ## We need to put (b - bc r)^2 into this form.
    ##
    ## (b - bc r)^2
    ## = (b - bc r)T (b - bc r)
    ## = bT b - 2 bT bc r - rT bcT bc r
    ## <=> finding r to minimize -2 bT bc r + rT (bcT bc) r
    ## = rT (bcT bc) r - 2 (bcT b)T r
    ## <=> solve.QP(bcT bc, bcT b, I, z) where I = identity matrix, z = 0
    require(quadprog)
    I <- diag(ncol(beta.cell.types))
    zero <- rep(0, ncol(beta.cell.types))
    cpg.idx <- which(!is.na(beta))
    bcT.x.bc <- t(beta.cell.types[cpg.idx,]) %*% beta.cell.types[cpg.idx,]
    bcT.x.b <- t(beta.cell.types[cpg.idx,]) %*% matrix(beta[cpg.idx], nrow=length(cpg.idx))
    counts <- solve.QP(bcT.x.bc, bcT.x.b, I, zero)$sol
    names(counts) <- colnames(beta.cell.types)
    counts
}

#' Estimate cell counts for a beta matrix from a reference
#'
#' Estimate cell type ratios from methylation profiles of purified cell populations
#' (Infinium HumanMethylation450 BeadChip).
#'
#' @param beta Matrix of Illumina 450K methylation levels (rows = CpG sites, columns = subjects).
#' @param verbose If \code{TRUE}, then status messages are printed during execution
#' (Default: \code{FALSE}).
#' @param cell.type.reference Character string name of the cell type reference
#' to use for estimating cell counts.
#' See \code{\link{meffil.list.cell.type.references}()} for a list of available
#' references.  New references can be created using
#' \code{\link{meffil.create.cell.type.reference}()}.
#' @return A matrix of cell count estimates.
#'
#' Results should be nearly identical to \code{\link[minfi]{estimateCellCounts}()}.
#'
#' @export
meffil.estimate.cell.counts.from.betas <- function(beta, cell.type.reference, verbose=F) {
    stopifnot(is.matrix(beta))
    reference.object <- get.cell.type.reference(cell.type.reference)

    beta <- quantile.normalize.betas(beta, reference.object$subsets, reference.object$quantiles, verbose=verbose)

    cpg.sites <- intersect(rownames(beta), rownames(reference.object$beta))
    stopifnot(length(cpg.sites) > 0)

    beta <- beta[cpg.sites,]
    reference.beta <- reference.object$beta[cpg.sites,]

    t(apply(beta, 2, estimate.cell.counts.from.beta, reference.beta))
}

quantile.normalize.betas <- function(beta, subsets, quantiles, verbose=F) {
    stopifnot(is.matrix(beta))
    stopifnot(length(subsets) == length(quantiles))
    stopifnot(all(names(subsets) %in% names(quantiles)))

    for (subset.name in names(subsets)) {
        subset <- intersect(subsets[[subset.name]], rownames(beta))
        if (length(subset) == 0)
            stop(paste("subset", subset.name, "and beta matrix have no features in common"))
        full.quantiles <- quantiles[[subset.name]]$beta
        full.quantiles <- approx(1:length(full.quantiles), full.quantiles, 1:length(subset))$y
        beta[subset,] <- preprocessCore::normalize.quantiles.use.target(beta[subset,,drop=F],
                                                                        full.quantiles)
    }
    beta
}


#!/usr/bin/env Rscript
library(data.table)
library("optparse")
library("qqman")
t_col <- function(color, percent = 50, name = NULL) {
  #      color = color name
  #    percent = % transparency
  #       name = an optional name for the color

## Get RGB values for named color
rgb.val <- col2rgb(color)

## Make new color using input color as base and alpha set by transparency
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
             max = 255,
             alpha = (100 - percent) * 255 / 100,
             names = name)

## Save the color
invisible(t.col)
}

computedher<-function(beta, se, af,N){
#https://journals.plos.org/plosone/article/file?type=supplementary&id=info:doi/10.1371/journal.pone.0120758.s001
maf<-af
maf[!is.na(af) & af>0.5]<- 1 - maf[!is.na(af) & af>0.5]
ba<-!is.na(beta) & !is.na(se) & !is.na(maf) & !is.na(N)
a<-rep(NA, length(beta))
b<-rep(NA, length(beta))
a<-2*(beta[ba]**2)*(maf[ba]*(1-maf[ba]))
b<-2*(se[ba]**2)*N[ba]*maf[ba]*(1-maf[ba])
res<-rep(NA, length(beta))
res[ba]<-a[ba]/(a[ba]+b[ba])
res
}

option_list = list(
  make_option(c( "--gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c( "--gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c( "--clump_file"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c( "--pheno"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--chr_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--bp_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--ps_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--a1_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--a2_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--bim"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--beta_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--se_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--af_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--N_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--ps_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--chr_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--p_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--min_pvalue"), type="numeric", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--min_r2"), type="numeric", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--info_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--out"), type="character", default="out.txt",
              help="output file name [default= %default]", metavar="character")
);

checkhead<-function(head,Data, type){
if(length(which(head %in% names(Data)))==0){
print(names(Data))
print(paste('not found ', head,'for',type ,'data'))
q(2)
}
}

#--chr_gwas ${params.head_chr} --ps_gwas ${params.head_bp} --a1_gwas ${params.head_A1} --a2_gwas ${params.head_A2
opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);
#opt=list(gwascat='out_all.csv',gwas='out_range.init',chr_gwas='chr',ps_gwas='ps',a1_gwas='allele1',a2_gwas='allele0',beta_gwas='beta',se_gwas='se',af_gwas='af',chr_gwascat='chrom',bp_gwascat='chromEnd',p_gwas='p_wald',ps_gwascat='chromEnd',chr_gwascat='chrom','out'='out_ld',clump_file='out.clumped',min_pvalue=0.1,min_r2=0.1,info_gwascat="pubMedID;author;trait;initSample",bim='all_imputed_map_qc.bim')

headse=opt[['se_gwas']];headbp=opt[['ps_gwas']];headchr=opt[['chr_gwas']];headbeta=opt[['beta_gwas']];heada1=opt[['a1_gwas']];heada2=opt[['a2_gwas']];headpval=opt[['p_gwas']];headaf<-opt[['af_gwas']];headbeta=opt[['beta_gwas']]
headchrcat=opt[['chr_gwascat']];headbpcat=opt[['ps_gwascat']];heada1catrs<-"riskAllele";headzcat="z.cat";headafcat<-'risk.allele.af';heada1cat<-'risk.allele.cat'
outhead=opt[['out']]

filegwascat<-opt[['gwascat']];filegwas=opt[['gwas']];fileclump=opt[['clump_file']];filebim=opt[['bim']]
#filegwascat<-"out_all.csv";filegwas="out_pos.init";fileclump="out.clumped";filebim="all_imputed_map_qc.bim"

datagwascat=read.csv(filegwascat)
#datagwascat[,heada1cat]<-sapply(strsplit(as.character(datagwascat[,heada1catrs]),split='-'),function(x)x[2])
datagwas<-read.table(filegwas, header=T)
checkhead(headpval, datagwas,'pval');checkhead(headse, datagwas,'se');checkhead(headbp, datagwas,'bp');checkhead(headchr, datagwas, 'chr');checkhead(headbeta, datagwas, 'beta')

checkhead(headbpcat,datagwascat,'bp cat');checkhead(headchrcat,datagwascat,'chro cat');

# CHR_A         BP_A         SNP_A  CHR_B         BP_B         SNP_B           R2
dataclump<-read.table(fileclump,header=T)
databim<-fread(filebim)[,c(1,4,2)];names(databim)<-c('chr','bp','rs_bim')

datagwascat<-merge(datagwascat, databim,by.x=c(headchrcat, headbpcat), by.y=c('chr','bp'),all=F)
datagwas<-merge(datagwas, databim,by.x=c(headchr, headbp), by.y=c('chr','bp'),all=F)

headN<-opt[['N_value']]
if(is.null(opt[['N_gwas']])){
if(is.null(opt[['N_value']]))Nval<-10000 else Nval=opt[['N_value']]
datagwas[,'N_gwas']<-Nval
headN<-'N_gwas'
}

aliseh2=F
if(!is.null(headaf)){
checkhead(headaf, datagwas,'af');
datagwas$h2.gwas<-computedher(datagwas[,headbeta], datagwas[,headse], datagwas[,headaf],datagwas[,headN])
datagwas$z.gwas<-datagwas[,headbeta]/datagwas[,headse]
}else{
cat('no frequencie\n')
datagwas$h2.gwas<-NA
datagwas$z.gwas<-NA
baliseh2=T

}

datagwasf<-datagwas[datagwas[,headpval]<headpval,]

tmpsp2<-strsplit(gsub('\\([1-9]+\\)','',as.character(dataclump$SP2)), split=',')
names(tmpsp2)<-as.character(dataclump$SNP)
cmt<-1
for(wind in names(tmpsp2)){
tmprs<-data.frame(rsclump=wind, rs_wind=c(tmpsp2[[wind]],wind))
if(cmt==1)resclump<-tmprs
else resclump<-rbind(resclump ,tmprs)
cmt<-cmt+1
}
resclumpgwas<-merge(resclump,datagwas,by.x='rs_wind',by.y="rs_bim")
resclumpgwascat<-merge(resclump,datagwascat,by.x='rs_wind',by.y="rs_bim")
resall<-merge(resclumpgwas,resclumpgwascat,by=c('rsclump'), all=T,suffixes = c("_gwas","_gwascat"))
write.csv(resall,file=paste(opt[['out']],'_detailall.csv',sep=''), row.names=F)
balise<-!is.na(resall$rs_wind_gwas)
resall$info_gwas[balise]<-paste(resall[balise,headchr],':',resall[balise,headbp],'-beta:',resall[balise,headbeta], ',se:',resall[balise,headse],',pval:',resall[balise,headpval],sep='')

resall$info_gwascat<-""
infocat=strsplit(opt[['info_gwascat']],split=';')[[1]]
balise<-!is.na(resall$rs_wind_gwascat)
if(all(balise==F)){
datacatinfo<-resall[F,c('info_gwascat','rsclump')]
datacatinfors<-resall[F,c('rs_wind_gwascat','rsclump')]
datainfo<-resall[F,c('info_gwas','rsclump')]
datainfors<-resall[F,c('rs_wind_gwas','rsclump')]
}else{
resall$info_gwascat[balise]=paste(resall$rs_wind_gwascat[balise],':',resall[balise,headchrcat], ':',resall[balise,headbpcat],',',sep='')
for(cat in infocat)resall$info_gwascat[balise]<-paste(resall$info_gwascat[balise],cat,':',resall[balise,cat],',',sep='')

datacatinfo<-aggregate(info_gwascat~rsclump,data=resall,FUN=function(x)paste(unique(x),collapse=';'))
datacatinfors<-aggregate(rs_wind_gwascat~rsclump,data=resall,FUN=function(x)paste(unique(x),collapse=';'))

datainfo<-aggregate(info_gwas~rsclump,data=resall,FUN=function(x)paste(unique(x),collapse=';'))
datainfors<-aggregate(rs_wind_gwas~rsclump,data=resall,FUN=function(x)paste(unique(x),collapse=';'))
}

allcati<-merge(merge(merge(datacatinfo,datacatinfors, by='rsclump'), datainfo,by='rsclump'),datainfors,by='rsclump')
allcati<-merge(allcati,dataclump[,c('SNP','CHR','BP','TOTAL','NSIG', 'P')],by.x='rsclump', by.y='SNP',all=F)
write.csv(allcati ,file=paste(opt[['out']],'_allresum.csv',sep=''), row.names=F)


library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats)
library(optparse)

source('utils/read-data.r')
source('utils/process-covariates.r')

# Commandline options and parsing
parser <- OptionParser()
parser <- add_option(parser, c("-D", "--debug"), action="store_true",
                     help="Perform a debug run of the model")
parser <- add_option(parser, c("-F", "--full"), action="store_true",
                     help="Perform a full run of the model")
cmdoptions <- parse_args(parser, args = commandArgs(trailingOnly = TRUE), positional_arguments = TRUE)

# Default run parameters for the model
if(is.null(cmdoptions$options$debug)) {
  DEBUG = Sys.getenv("DEBUG") == "TRUE"
} else {
  DEBUG = cmdoptions$options$debug
}

if(is.null(cmdoptions$options$full)) {
  FULL = Sys.getenv("FULL") == "TRUE"
} else {
  FULL = cmdoptions$options$full
}

if(DEBUG && FULL) {
  stop("Setting both debug and full run modes at once is invalid")
}

if(length(cmdoptions$args) == 0) {
  StanModel = 'base'
} else {
  StanModel = cmdoptions$args[1]
}

print(sprintf("Running %s",StanModel))
if(DEBUG) {
  print("Running in DEBUG mode")
} else if (FULL) {
  print("Running in FULL mode")
}

# Read which countires to use
countries <- read.csv('data/regions.csv', stringsAsFactors = FALSE)
# Read deaths data for regions
d <- read_obs_data(countries)
# Read ifr
ifr.by.country <- read_ifr_data()

# Read interventions
interventions <- read_interventions(countries)

forecast <- 7 # increase to get correct number of days to simulate
# Maximum number of days to simulate
N2 <- (max(d$DateRep) - min(d$DateRep) + 1 + forecast)[[1]]

processed_data <- process_covariates(countries = countries, interventions = interventions,
                                     d = d , ifr.by.country = ifr.by.country, N2 = N2)
stan_data = processed_data$stan_data
dates = processed_data$dates
deaths_by_country = processed_data$deaths_by_country
reported_cases = processed_data$reported_cases

options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
m = stan_model(paste0('stan-models/',StanModel,'.stan'))

if(DEBUG) {
  fit = sampling(m,data=stan_data,iter=40,warmup=20,chains=2)
} else if (FULL) {
  fit = sampling(m,data=stan_data,iter=1800,warmup=1000,chains=5,thin=1,control = list(adapt_delta = 0.95, max_treedepth = 15))
} else {
  fit = sampling(m,data=stan_data,iter=1000,warmup=500,chains=4,thin=1,control = list(adapt_delta = 0.95, max_treedepth = 10))
}

out = rstan::extract(fit)
prediction = out$prediction
estimated.deaths = out$E_deaths
estimated.deaths.cf = out$E_deaths0

JOBID = Sys.getenv("PBS_JOBID")
if(JOBID == "")
  JOBID = as.character(abs(round(rnorm(1) * 1000000)))
print(sprintf("Jobid = %s",JOBID))

countries <- countries$Regions
save.image(paste0('results/',StanModel,'-',JOBID,'.Rdata'))
save(fit,prediction,dates,reported_cases,deaths_by_country,countries,estimated.deaths,estimated.deaths.cf,out,file=paste0('results/',StanModel,'-',JOBID,'-stanfit.Rdata'))

## Ensure that output directories exist
dir.create("results/", showWarnings = FALSE, recursive = TRUE)
dir.create("figures/", showWarnings = FALSE, recursive = TRUE)
dir.create("web/", showWarnings = FALSE, recursive = TRUE)
dir.create("web/data", showWarnings = FALSE, recursive = TRUE)

library(bayesplot)
filename <- paste0(StanModel,'-',JOBID)

print("Generating covariate size effects plot")
covariate_size_effects_error <- system(paste0("Rscript covariate-size-effects.r ", filename,'-stanfit.Rdata'),intern=FALSE)
if(covariate_size_effects_error != 0){
  stop(sprintf("Error while plotting covariate size effects! Code: %d", covariate_size_effects_error))
}

mu = (as.matrix(out$mu))
colnames(mu) = countries
g = (mcmc_intervals(mu,prob = .9))
ggsave(sprintf("results/%s-mu.png",filename),g,width=4,height=6)
tmp = lapply(1:length(countries), function(i) (out$Rt_adj[,stan_data$N[i],i]))
Rt_adj = do.call(cbind,tmp)
colnames(Rt_adj) = countries
g = (mcmc_intervals(Rt_adj,prob = .9))
ggsave(sprintf("results/%s-final-rt.png",filename),g,width=4,height=6)

print("Generate 3-panel plots")
plot_3_panel_error <- system(paste0("Rscript plot-3-panel.r ", filename,'-stanfit.Rdata'),intern=FALSE)
if(plot_3_panel_error != 0){
  stop(sprintf("Generation of 3-panel plots failed! Code: %d", plot_3_panel_error))
}

print("Generate forecast plot")
plot_forecast_error <- system(paste0("Rscript plot-forecast.r ",filename,'-stanfit.Rdata'),intern=FALSE)
if(plot_forecast_error != 0) {
  stop(sprintf("Generation of forecast plot failed! Code: %d", plot_forecast_error))
}

print("Make forecast table")
make_table_error <- system(paste0("Rscript make-table.r results/",filename,'-stanfit.Rdata'),intern=FALSE)
if(make_table_error != 0){
  stop(sprintf("Generation of alpha covar table failed! Code: %d", make_table_error))
}

verify_result_error <- system(paste0("Rscript web-verify-output.r ", filename,'.Rdata'),intern=FALSE)
if(verify_result_error != 0){
  stop(sprintf("Verification of web output failed! Code: %d", verify_result_error))
}


.b = import('../../base')

#' Function to normalize expression objects
#'
#' @param rawData  A raw data object, or a list thereof
#' @param method   Method to use for normalization: rma, gcrma, frma
#' @return         The normalized data
normalize = function(rawData, ...) {
    UseMethod("normalize")
}

normalize.list = function(rawData, ...) {
    re = lapply(rawData, function(x) normalize(x, ...) %catch% NA)
    if (any(is.na(re)))
        warning("dropping ", names(re)[is.na(re)])
    if (all(is.na(re)))
        stop("all normalizations failed")
    re[!is.na(re)]
}

normalize.FeatureSet = function(rawData, method="rma") {
    if (method == "rma")
        oligo::rma(rawData)
    else
        stop("invalid method")
}

normalize.AffyBatch = function(rawData, method="rma") {
    if (method == "rma")
        affy::rma(rawData)
    else if (method == "gcrma")
        gcrma::gcrma(rawData)
    else if (method == "frma")
        frma::frma(rawData, target="core")
    else
        stop("invalid method")
}

normalize.EListRaw = function(rawData, method="quantile") {
    rawData %>%
        limma::backgroundCorrect(method="normexp") %>%
        limma::normalizeBetweenArrays(method=method)
}

normalize.RGList = function(rawData, method="loess") {
    rawData %>%
        limma::backgroundCorrect(method="normexp") %>%
        limma::normalizeWithinArrays(method=method)
}

normalize.NChannelSet = function(rawData, ...) {
    ad = as.list(Biobase::assayData(rawData))
    ad$genes = Biobase::fData(rawData)

    if ("E" %in% names(ad)) { # one-color
        norm = normalize.EListRaw(new("EListRaw", ad), ...)
        ad = with(norm, Biobase::assayDataNew(E = E))
    } else { # two-color
        norm = normalize.RGList(new("RGList", ad), ...)
        ad = with(norm, Biobase::assayDataNew(R = R, G = G))
    }

    features = new("AnnotatedDataFrame", norm$genes)
    normeset = new("NChannelSet", assayData = ad)
    featureData(normeset) = features
    phenoData(normeset) = phenoData(rawData)
    normeset
}


#################
# Example script to reproduce
# analysis from:
# Hertzog et al Model-based data integration
# problems can be reported by mailing:
# lionel.hertzog@thuenen.de
#############

# note that due to data sharing policy
# only artificial data are provided
# in the repo
# please contact the main author
# for request of sharing the actual data

# set the working directory to the
# local file path of the repo
setwd("")

# load the libraries
library(tidyverse)
library(rtrim)
library(greta)
library(greta.checks)
library(greta.multivariate)

## load functions
source("script/01_function_scripts.r")

## where to save the model outputs
path_out <- "model_output/"

## load the example data
mhb <- read.csv("data/example_mhb.csv", stringsAsFactors = FALSE)

ornitho_list <- list_all <- read.csv("data/example_ornitho_list.csv", stringsAsFactors = FALSE)

ornitho_unstr <- unstr_all <- read.csv("data/example_ornitho_unstr.csv", stringsAsFactors = FALSE)

## loop across the species
for(species in unique(mhb$Artname)){
  # for saving the model objects check that the species has a folder existing
  if(!dir.exists(paste0(path_out, species))){
    dir.create(paste0(path_out, species))
  }
  print(paste0("Starting species: ", species))
  # fit the models
  fit_model1(species, path = path_out)
  fit_model2(species, path = path_out, one_by_one = TRUE)
  fit_model3(species, path = path_out, one_by_one = TRUE)
  fit_model4(species, path = path_out, one_by_one = TRUE)
  fit_model5(species, path = path_out, one_by_one = TRUE)
  fit_model6(species, path = path_out, one_by_one = TRUE)
}


bootREMLRT.asreml <- function(h0.asreml.obj, h1.asreml.obj,
                              nboot = 100, max.retries = 5, seed = NULL,
                              means=NULL, V = NULL, extra.matrix = NULL, ignore.terms = NULL,
                              fixed.spline.terms = NULL,
                              bound.exclusions = c("F","B","S","C"),
                              tolerance = 1E-10, update = TRUE, trace = FALSE,
                              ncores = detectCores(), ...)
{
  #asreml codes:
  #  B - fixed at a boundary (!GP)
  #  F - fixed by user
  #  ? - liable to change from P to B
  #  P - positive definite
  #  C - Constrained by user (!VCC)
  #  U - unbounded
  #  S - Singular Information matrix

  asr4 <- isASRemlVersionLoaded(4, notloaded.fault = TRUE)

  #Check that have a valid objects of class asreml
  validasr <- validAsreml(h0.asreml.obj)
  if (is.character(validasr))
    stop(validasr)
  #Check that have a valid object of class asreml
  validasr <- validAsreml(h1.asreml.obj)
  if (is.character(validasr))
    stop(validasr)

  #Check that fixed and sparse models are the same
  if (asr4)
  {
    fixed.labels <- lapply(list(h1.asreml.obj,h0.asreml.obj),
                           function(x) {attr(terms(x$formulae$fixed), "term.labels")})
    sparse.labels <- lapply(list(h1.asreml.obj,h0.asreml.obj),
                            function(x) {attr(terms(x$formulae$sparse), "term.labels")})
    mu <- sapply(list(h1.asreml.obj,h0.asreml.obj),
                 function(x) {attr(terms(x$formulae$fixed), "intercept")})
  } else
  {
    fixed.labels <- lapply(list(h1.asreml.obj,h0.asreml.obj),
                           function(x) {attr(terms(x$fixed.formula), "term.labels")})
    sparse.labels <- lapply(list(h1.asreml.obj,h0.asreml.obj),
                            function(x) {attr(terms(x$sparse), "term.labels")})
    mu <- sapply(list(h1.asreml.obj,h0.asreml.obj),
                 function(x) {attr(terms(x$fixed.formula), "intercept")})
  }

  if (!all(mu == mu[1]))
    stop("Fixed models must be identical with respect to the intercept")
  if (!all(diff(sapply(fixed.labels, function(x) length(x))) == 0))
    stop("Fixed models differ in length")
  if (all(sapply(fixed.labels, function(x) length(x)) > 0))
  {
    for (i in 2:length(fixed.labels))
    {
      if (!all(is.element(fixed.labels[[1]], fixed.labels[[i]])))
        stop("Fixed models differ")
    }
  }
  if (!all(diff(sapply(sparse.labels, function(x) length(x))) == 0))
    stop("sparse models differ in length")
  if (all(sapply(sparse.labels, function(x) length(x)) > 0))
  {
    for (i in 2:length(sparse.labels))
    {
      if (!all(is.element(sparse.labels[[1]], sparse.labels[[i]])))
        stop("sparse models differ")
    }
  }

  #Set up expectation
  if (is.null(means))
  {
    if (!asr4 & !is.null(fixed.spline.terms))
      stop("Cannot incorporate fixed spline terms in asreml ver. 3 - must supply means yourself")
    if (asr4)
    {
      mu <- fitted.values(h0.asreml.obj)
      if (!is.null(fixed.spline.terms)) #add fixed spline terms
      {
        #Check whether have the design matrix
        if (is.null(h0.asreml.obj$design))
        {
          asreml::asreml.options(design = TRUE)
          h0.asreml.obj <- eval(h0.asreml.obj$call)
        }
        for (term in fixed.spline.terms)
        {
          if (!grepl("spl", term, fixed = TRUE))
            stop("A term in fixed.spline.terms does not include the spline function")
          Z <- as.matrix(getTermDesignMatrix(term, h0.asreml.obj))
          G.param <- h0.asreml.obj$G.param
          termvars <- names(G.param[[term]])[-1]
          cond.fac <- ""
          cols <- ""
          for (var in termvars)
          {
            if (cols == "")
              cols <- paste(var, "_", G.param[[term]][[var]]$levels, sep ="")
            else
              cols <- paste(cols, ":", var, "_", G.param[[term]][[var]]$levels, sep ="")
          }
          BLUPs <- h0.asreml.obj$coefficients$random
          BLUPs <- BLUPs[match(cols, rownames(BLUPs)), 1]
          mu <- mu + Z %*% BLUPs
        }
      }
    }
    else
      mu <- fitted(h0.asreml.obj) #asreml::fitted.asreml(h0.asreml.obj)
  }
  else
  {
    mu <- means
  }

  if (is.null(V))
  {
    if (!asr4)
      stop("It appears that asreml4 is not loaded and so V must be supplied to bootREMLRT.asreml.")
    V <- estimateV(h0.asreml.obj, extra.matrix = extra.matrix, ignore.terms = ignore.terms,
                   fixed.spline.terms = fixed.spline.terms,
                   bound.exclusions = bound.exclusions)
    n <- nrow(V)
  }
  else #check supplied V
  {
    if (!isSymmetric(V))
      stop("Variance matrix must be symmetric")
    n <- length(h0.asreml.obj$residuals)
    if (!is.null(means) & length(means) != n)
      stop("The lengths of means  and the response variable are not the same")
    if (!all(dim(V) == c(n, n)))
      stop("V is not a square matrix whose order equals the length of the response variable")
  }

  #use eigenvalue decomposition to establish transformation matrix
  eigdecomp <- eigen(V, symmetric = TRUE)
  eigenval <- eigdecomp$values
  if (!all(eigenval >= -tolerance * abs(max(eigenval))))
    stop("Variance matrix is not nonnegative definite")
  R <- eigdecomp$vectors %*% diag(sqrt(pmax(eigenval, 0)), n)

  #check and get info in calls
  h1.call <- h1.asreml.obj$call
  h0.call <- h0.asreml.obj$call
  if (!("data" %in% names(h1.call) & "data" %in% names(h0.call)))
    stop("bootREMLRT.asreml assumes that data has been set in the two asreml objects")
  sim.dat <- eval(h1.call$data)
  h0.dat <- eval(h0.call$data)
  if (ncol(sim.dat) != ncol(h0.dat) ||
      nrow(suppressMessages(dplyr::anti_join(sim.dat,h0.dat)))!=0)
    stop("The data argument is not the same for the two asreml calls")
  #check that the y var is in both asreml objects and has the same values
  h1.y <- languageEl(h1.call$fixed, which = 2)
  if (1 - (abs(var(sim.dat[[as.character(h1.y)]], na.rm = TRUE) /
               var(h0.dat[[as.character(h1.y)]], na.rm = TRUE))) > 1e-03)
      stop("The values of y in data for the two asreml objects appear not to be the same")

  #set up calls
  h1.object.sim <- h1.asreml.obj
  h1.call <- h1.object.sim$call
  elno <- grep("data", names(h1.call))
  languageEl(h1.call, which=elno) <- quote(sim.dat)
  languageEl(h1.call$fixed, which=2) <- quote(y.sim)
  h0.call$trace <- trace
  h0.object.sim <- h0.asreml.obj
  h0.call <- h0.object.sim$call
  elno <- grep("data", names(h0.call))
  languageEl(h0.call, which=elno) <- quote(sim.dat)
  languageEl(h0.call$fixed, which=2) <- quote(y.sim)
  h0.call$trace <- trace

  #Deal with the R.param and G.param arguments
  if (update)
  {
    #If update, set R.param and G.param
    languageEl(h1.call, which = "R.param") <- h1.asreml.obj$R.param
    languageEl(h1.call, which = "G.param") <- h1.asreml.obj$G.param
    languageEl(h0.call, which = "R.param") <- h0.asreml.obj$R.param
    languageEl(h0.call, which = "G.param") <- h0.asreml.obj$G.param
  } else
  {
    #If R.param and G.param already set, make them NULL
    if (!is.null(languageEl(h1.call, which = "R.param")))
      languageEl(h1.call, which = "R.param") <- NULL
    if (!is.null(languageEl(h1.call, which = "G.param")))
      languageEl(h1.call, which = "G.param") <- NULL
    if (!is.null(languageEl(h0.call, which = "R.param")))
      languageEl(h0.call, which = "R.param") <- NULL
    if (!is.null(languageEl(h0.call, which = "G.param")))
      languageEl(h0.call, which = "G.param") <- NULL
  }

  #deal with args coming via ...
  #- this will overwite previously set values, except data and models are protectd
  tempcall <- list(...)
  if (length(tempcall))
  {
    for (z in names(tempcall))
      if (z == "data")
        sim.dat <- data
      else
      {
        if (z %in% c("fixed", "random", "residual", "rcov", "sparse"))
          stop("attempt to change model to be fitted")
        else
        {
          languageEl(h0.call, which = z) <- tempcall[[z]]
          languageEl(h1.call, which = z) <- tempcall[[z]]
        }
      }
  }

  #Get bound values
  asr4 <- isASRemlVersionLoaded(4, notloaded.fault = TRUE)
  if (asr4)
  {
    bound.h0 <- asreml::vpc.char(h0.asreml.obj)
    bound.h1 <- asreml::vpc.char(h1.asreml.obj)
  }
  else
  {
    bound.h0 <- names(h0.asreml.obj$gammas.con)
    names(bound.h0) <- names(h0.asreml.obj$gammas)
    bound.h1 <- names(h1.asreml.obj$gammas.con)
    names(bound.h1) <- names(h1.asreml.obj$gammas)
  }
  #Calculate observed p-value
  DF.diff <- DFdiff(bound.h1, bound.h0, bound.exclusions = bound.exclusions)
  DF <- DF.diff$DF
  NBound.h1 <- DF.diff$NBound.h1
  NBound.h0 <- DF.diff$NBound.h0

  REMLRT <- 2*(h1.asreml.obj$loglik-h0.asreml.obj$loglik)

  #Set up for simulation
  conv <- FALSE
  cl <- makeCluster(ncores)
  registerDoParallel(cl)
  #process seed argument
  if (!is.null(seed))
  {
    RNGkind("L'Ecuyer-CMRG")
    set.seed(seed)
    ## start ncores workers
    s <- .Random.seed
    for (i in 1:ncores) {
      s <- nextRNGStream(s)
      # send s to worker i as .Random.seed
    }
  }
  #generate nboot data sets and analyse them
  if (asr4)
  {
    REMLRT.out <- foreach (i = 1:nboot, .combine = rbind, .inorder=FALSE,
                           .packages = c("asreml","asremlPlus"))  %dopar%
                           {
                             asreml::asreml.options(fail = "soft")
                             while (!conv)
                             {
                               nnonconv <- 0
                               sim.dat <- within(sim.dat,
                                                 {y.sim <- as.vector(mu + R %*% rnorm(n))})
                               h1.asr <- eval(h1.call)
                               conv <- h1.asr$converge
                               if (conv)
                               {
                                 h0.asr <- eval(h0.call)
                                 conv <- h0.asr$converge
                               }
                               if (!conv)
                               {
                                 nnonconv <- nnonconv + 1
                                 REMLRT.sim <- NA
                                 if (max.retries > nnonconv)
                                   break()
                               } else
                               {
                                 #Perform the test
                                 REMLRT.sim <- 2*(h1.asr$loglik-h0.asr$loglik)
                               }
                             }
                             conv=FALSE
                             cbind(REMLRT.sim, nnonconv)
                           }
  } else
  {
    REMLRT.out <- foreach (i = 1:nboot, .combine = rbind, .inorder=FALSE,
                           .packages = c("asreml","asremlPlus"))  %dopar%
                           {
                             loadASRemlVersion(3, lib.loc = "D:\\Analyses\\R oldpkg")
                             while (!conv)
                             {
                               sim.dat <- within(sim.dat,
                                                 {y.sim <- as.vector(mu + R %*% rnorm(n))})
                               h1.asr <- eval(h1.call)
                               conv <- h1.asr$converge
                               if (conv)
                               {
                                 h0.asr <- eval(h0.call)
                                 conv <- h0.asr$converge
                               }
                               if (!conv)
                               {
                                 nnonconv <- nnonconv + 1
                                 REMLRT.sim <- NA
                                 if (max.retries > nnonconv)
                                   break()
                               } else
                               {
                                 #Perform the test
                                 REMLRT.sim <- 2*(h1.asr$loglik-h0.asr$loglik)
                               }
                             }
                             conv=FALSE
                             cbind(REMLRT.sim, nnonconv)
                           }
  }
  stopCluster(cl)

  REMLRT.sim <- na.omit(REMLRT.out[,1])
  nunconverged <- REMLRT.out[,2]
  totalunconverged <- sum(nunconverged)
  ksim <- length(REMLRT.sim)

  #Calculate bootstrap p-value
  p <- (sum(REMLRT.sim >= REMLRT) + 1) / (ksim + 1)
  list(REMLRT = REMLRT, p = p, DF = DF, totalunconverged = totalunconverged,
       REMLRT.sim = REMLRT.sim, nunconverged = nunconverged)
}


#Makes plots of the spatial predictions from ArcticCulturalES_maxent_models.r
#Not optimised for speed!

library(raster)
library(rasterVis)
library(rgdal)

wd <- "C:/Claire/Arctic_Cultural_ES/"
#wd <- "/home/runge/Data/Arctic_Cultural_ES/"
setwd(wd)

modelDir <- paste0(wd, "Maxent runs/")
plotDir <- paste0(wd, "figures/")

currDate <- paste(strsplit(as.character(Sys.Date()), "-")[[1]], collapse="") #formatting the date for folder naming

########################
## Setting system preferences for better work with raster
# Define your temp folder
# my_tmpdir=paste0(wd, "tmpRaster")

# # Create it (handles the case where the folder already exists)
# dir.create(my_tmpdir, showWarnings=F)

# # Set the raster option to this folder
# rasterOptions(tmpdir= my_tmpdir)

# ## Maximum Memory
# # Often server has more RAM than desktop. Therefore the mamximum amount of memory that can be allocated
# # to process a raster can be increased. Aurora has a lot of RAM (384GB), so we recommend to use the following
# # settings:
# rasterOptions(maxmemory =1e+09)
# rasterOptions(chunksize=1e+08)

######################
#a function to capitalise first letter of a word
capwords <- function(s, strict = FALSE) {
    cap <- function(s) paste(toupper(substring(s, 1, 1)),
                  {s <- substring(s, 2); if(strict) tolower(s) else s},
                             sep = "", collapse = " " )
    sapply(strsplit(s, split = " "), cap, USE.NAMES = !is.null(names(s)))
}

######################

cultESlist <- c("biological", "cabin", "cleanwater", "cultureident", "gathering", "hunt_fish", "income", "pasture", "recreation","scenic", "social", "specialplace", "spiritual", "therapuetic", "undisturbnature")

folderlist <- paste0(rep(c("Combined model", "North model", "South model"), each=2), paste0(c("/Base run ", "/Base run bias grid "), c("20170116/")))
plotnames <- c("Norway", "", "North", "", "South")
plotfilename <- c("_LatentvsRealised_Norway_", "", "_LatentvsRealised_North_", "", "_LatentvsRealised_South_")

#Set up masks
mtemprast <- raster(paste0(modelDir, folderlist[1], cultESlist[1], "/", cultESlist[1], "_prediction_alpine.tif"))
northshp <- readOGR("Spatial data/Processed/Templates and boundaries", "North_municipalities_alpine")
northmask <- raster("Spatial data/Processed/Templates and boundaries/North_municipalities_alpine.tif")
northmask <- crop(northmask, mtemprast)

southshp <- readOGR("Spatial data/Processed/Templates and boundaries", "South_municipalities")
southmask <- raster("Spatial data/Processed/Templates and boundaries/South_municipalities.tif")
southmask <- crop(southmask, mtemprast)

for (x in cultESlist){
	for (i in c(1,3,5)){
			rreal <- raster(paste0(modelDir, folderlist[i], x, "/", x, "_prediction_alpine.tif"))
			rlat <- raster(paste0(modelDir, folderlist[i+1], x, "/", x, "_prediction_alpine.tif"))
			plotStack <- stack(rreal, rlat)
			names(plotStack) <- c("Realised", "Latent")
		if (i==1) {
			plotStack <- plotStack
		} else if (i==3){
			plotStack <- mask(plotStack, northmask)
			plotStack <- crop(plotStack, extent(northshp), snap='out')
		} else if (i==5) {
			plotStack <- mask(plotStack, southmask)
			plotStack <- crop(plotStack, extent(southshp), snap='out')
		}
		#make plots
		print(paste0("Starting plot ", x))
		png(filename=paste0(plotDir, capwords(x), plotfilename[i], currDate, ".png"),width=1024*0.707*2, height=1024, res=300)
		print(levelplot(plotStack, main=paste0(capwords(x), " - ", plotnames[i]), scales=list(draw=FALSE)) )#remove latlon
		dev.off()

	}

}

#latent vs realised for combined model
#latent vs realised for N region
#latent vs realilsed for S region


#scenario<-'aa'
my.data.path<-file.path(data.path,scenario)
#my.data.path<-data.path  #default
plot.recruit<-T

nox<-3; noy<-2; Portrait<-F
if (!plot.recruit) nox<-2
paper<-FALSE        # graphics on paper=file (TRUE) or on screen (FALSE)
if ("scenario" %in% ls()) run.ID<-scenario else run.ID<-"b"         # file id used for paper output

cleanup()

species.in.title<-T
first.year.on.plot<-2015
last.year.on.plot<-2100

include.assess.forcast.line<-TRUE
include.F.reference.points<-TRUE
include.SSB.reference.points<-TRUE
Use.SSB.rec.param<-"out"               #Read SSB recruitment parameters from in=SSB_R.in or out=SSB_R.out

Reps<-c(1,1)  # Select MCMC repetion
Iter<-c(1)  # Select Iterations within a MCMC Repetion
Iter<-seq(1,2)  # Select Iterations within a MCMC Repetion

incl.sp<-seq(1,3)  # species number to be included
incl.sp<-1
#incl.sp<-"all"
#sp.plot<-incl.sp

max.color<-5

do.plot.forecast1<-function(sp.plot=c(1),incl.prob=FALSE,incl.closure=FALSE,incl.M2=FALSE,plot.residuals=F,dir=my.data.path) {
#########################################
    control<-read.FLSMS.control(file='SMS.dat')
    last.year.model<-control@last.year.model
    HCR<-read.FLSMS.predict.control(control=control,file=file.path(dir,'HCR_options.dat'))

    sp.names<<-control@species.names
    years<-c(control@first.year,control@last.year.model)

    lReps<-length(Reps)

    make.assess.forcast.line<-function() if (include.assess.forcast.line) abline(v=last.year.model,col='red',lwd=2)

    if (incl.closure) {
      closure <-Read.MCMC.closure.data(dir=dir)
      closure<-subset(closure,Year>=first.year.on.plot & Year<=last.year.on.plot,drop=T)
    }

    if (incl.M2) {
      M2<-Read.MCMC.detailed.M2(dir=dir,del.zero=F)
      M2<-droplevels(subset(M2,Year>=first.year.on.plot & Year<=last.year.on.plot & M2>0 & Age<=2 & Repetion %in% Reps  & Iteration %in% Iter))
      M2<-tapply(M2$M2,list(M2$Species.n,M2$Year,M2$Age,M2$Repetion,M2$Iteration),sum)
    }

   ref.points<-Read.reference.points()

    ssb.r<-Read.MCMC.SSB.rec.data(dir=dir)
    ssb.r<-subset(ssb.r,(Year>=first.year.on.plot & Year<=last.year.on.plot) ,drop=T)

    F.yield<-Read.MCMC.F.yield.data(dir=dir)
    F.yield<-subset(F.yield,Year>=first.year.on.plot & Year<=last.year.on.plot,drop=T)

    if (paper) dev<-"wmf" else dev<-"screen"

    if (is.character(incl.sp)) if (incl.sp=="all") {
       info<-control@species.info
       n.pred<-0; n.oth<-0
       for (s in (1:control@no.species)) {
         if(info[s,'predator']>=1) n.pred<-n.pred+1;
         if(info[s,'predator']==2) n.oth<-n.oth+1;
       }
       first.VPA<-n.oth+1
       n.VPA<-control@no.species-first.VPA+1

       sp.plot<-seq(first.VPA,length(unique(ssb.r$Species))+n.oth)
    }

for (sp in (sp.plot)) {
  newplot(dev,nox,noy,filename=paste("trend_",run.ID,'_',sp.names[sp],sep=''),Portrait=Portrait);
  par(mar=c(3,5,3,2))
  loc.name<-sp.names

  if (!species.in.title) loc.name[]<-""

  a<-subset(ssb.r,Species.n==sp & Repetion %in% Reps & Iteration %in% Iter)
  b<-tapply(a$SSB,list(a$Year,a$Repetion ,a$Iteration), sum)/1000
  bSSB<-b*1000
  y<-as.numeric(dimnames(b)[[1]])
  plot(y,b[,1,1],main=paste(loc.name[sp], "SSB"),xlab="",ylab='SSB (1000t)',type='l',lwd=2,ylim=c(0,max(b)))
    for (i in (1:dim(b)[2])) for (j in (1:dim(b)[3])) lines(y,b[,i,j],lty=min(i,max.color),col=min(i,max.color),lwd=2)
  if (include.SSB.reference.points) {
    if (ref.points[sp,3] >0) abline(h=ref.points[sp,3]/1000,lty=2)
    if (ref.points[sp,4] >0) abline(h=ref.points[sp,4]/1000,lty=3)
  }
  make.assess.forcast.line()

  a<-subset(ssb.r,Species.n==sp & Repetion %in% Reps  & Iteration %in% Iter)
  b<-tapply(a$rec,list(a$Year,a$ Repetion ,a$Iteration), sum)/1000
  y<-as.numeric(dimnames(b)[[1]])
  plot(y,b[,1,1],main=paste(loc.name[sp], "Recruits"),xlab="",ylab='Recruits (1000)',
        type='l',lwd=2,ylim=c(0,max(b)))
   for (i in (1:dim(b)[2])) for (j in (1:dim(b)[3]))  lines(y,b[,i,j],lty=min(i,max.color),col=min(i,max.color),lwd=2)
  make.assess.forcast.line()

  #read SSB/R parameters
  if (Use.SSB.rec.param=='out') p<-Read.SSB.Rec.data() else p<-Read.SSB.Rec.data.in()

  model.name<-c('Ricker','Bev. & Holt','Geom. mean','Hockey stick')
  spp<-sp-first.VPA+1
  model<-p[spp,'model']
  alfa<-p[spp,'alfa']
  beta<-p[spp,'beta']
  CV<-p[spp,'std']
  info1<-p[spp,'info1']
  info2<-p[spp,'info2']

  ssbR<-function(x) {
    if (model==1 & Use.SSB.rec.param=='in') y<-alfa*x*exp(-beta/control@beta.cor[sp]*x)
    else if (model==1 & Use.SSB.rec.param=='out') y<-alfa*x*exp(-beta*x)
    else if (model==51 | model==52) y<-alfa*x*exp(-beta*x+info1*info2)
    else if (model==2) y<-alfa*x/(1+x*beta)
    else if (model==3) y<-rep(exp(alfa),length(x))
    else if (model==4) {for (i in (1:length(x))) y[i]<-exp(alfa)*min(x[i],exp(beta))}

    else if (model==100) {for (i in (1:length(x))) y[i]<-exp(alfa)*min(x[i],beta)}
    y
  }

  if (plot.recruit) {  # recruitment plots
  ssb<-seq(0,max(bSSB),max(bSSB)/100)
  rec<- ssbR(ssb)

  rec<-rec/1000;
  ssb<-ssb/1000
  firstVPA<-control@no.species-length(control@SSB.R.year.first)+1
   spidx<-sp-firstVPA+1
  if (control@SSB.R.year.first[spidx] != -1) fyrc<-control@SSB.R.year.first[spidx] else fyrc<-control@first.year
  if (control@SSB.R.year.last[spidx] != -1) lyrc<-control@SSB.R.year.last[spidx] else lyrc<-control@last.year.model

  a<-subset(ssb.r,Species.n==sp & Repetion %in% Reps & Iteration %in% Iter)
  a$recruit[a$Year<fyrc | (a$Year>lyrc & a$Year<control@last.year.model)]<-NA
  plot(ssb,rec,main="SSB recruit",type='l',ylab='Recruits (1000)',ylim=c(0,max(a$recruit,na.rm=T)/1000))
  fa<-control@first.age
  b<-data.frame(Year=a$Year-control@first.age,recruit=a$recruit,Repetion=a$Repetion,Iteration=a$Iteration)
  c<-data.frame(Year=a$Year,SSB=a$SSB,Repetion=a$Repetion,Iteration=a$Iteration)

  d<-merge(b,c)
  d$recruits[d$Year<fyrc | (d$Year>lyrc & d$Year<control@last.year.model)]<-NA
  d$color<-ifelse(d$Year<=last.year.model,1,3)
  lines(d$SSB/1000,d$recruit/1000,type='p',col=d$color)

  # residuals
  if (plot.residuals) {
    d<-data.frame(d, pred.rec=ssbR(as.vector(d$SSB)))
    e<-transform(d,resid=log(recruit)-log(pred.rec))

    e$resid[e$Year<fyrc | (e$Year>lyrc & e$Year<control@last.year.model)]<-NA
    plot(e$Year,e$resid,type='p',main='Stock recruitment residuals',ylab='log(obs)-log(predicted)',,col=d$color)
    abline(h=0,lty=3)
  }
 }

  if (F) {
    aa<-acf(e$resid,xlab='Lag(years)',main='Autcorrelation',lag.max=5)
    print(loc.name[sp])
    print(aa)

    a<-as.vector(e$resid)
    n<-length(a)
    sum<-0
    for (i in (2:n)) sum<-sum+(a[i]-a[i-1])^2
    d<-sum/sum(a^2)
    # Durbin-Watson d statistics. The traditional test for the presence of first-order autocorrelation
    # Its value always lies between 0 and 4.
    # A value of 2 indicates there appears to be no autocorrelation.
    # If the Durbin-Watson statistic is substantially less than 2, there is evidence of positive serial correlation.
    # As a rough rule of thumb, if Durbin-Watson is less than 1.5, there may be cause for alarm.
    # Small values of d indicate successive error terms are, on average, close in value to one another, or positively correlated.
    # Large values of d indicate successive error terms are, on average, much different in value to one another, or negatively correlated.

    cat(paste("\n# Durbin-Watson d statistics:",round(d,2),"\n"))
  }

  #plot(e$ssb,e$rec)

  a<-subset(F.yield,Species.n==sp & Repetion %in% Reps & Iteration %in% Iter)

  b<-tapply(a$mean.F,list(a$Year,a$ Repetion ,a$Iteration), sum)
  y<-as.numeric(dimnames(b)[[1]])

  plot(y,b[,1,1],main=paste(loc.name[sp], 'Mean F'),xlab="",ylab='Mean F',
        type='l',lwd=2,ylim=c(0,max(b)))
  for (i in (1:dim(b)[2])) for (j in (1:dim(b)[3])) lines(y,b[,i,j],lty=min(i,max.color),col=min(i,max.color),lwd=2)
   make.assess.forcast.line()

  b<-tapply(a$Yield,list(a$Year,a$ Repetion ,a$Iteration), sum)/1000
  y<-as.numeric(dimnames(b)[[1]])
  plot(y,b[,1,1],main=paste(loc.name[sp], "Yield"),xlab="",ylab='Yield (1000 t)',
        type='l',lwd=2,ylim=c(0,max(b)))
  for (i in (1:dim(b)[2])) for (j in (1:dim(b)[3])) lines(y,b[,i,j],lty=min(i,max.color),col=min(i,max.color),lwd=2)
   make.assess.forcast.line()

  if (incl.M2) {
      print(dim(M2))
      print(dimnames(M2))
      if (as.character(sp) %in% dimnames(M2)[[1]]) {
        b<-M2[as.character(sp),,,,]
        print(dimnames(b))

        if (sum(b,na.rm=T)>=0.01) {
          y<-as.numeric(dimnames(b)[[1]])
          plot(y,b[,1,1],main=paste("M2 at age"),xlab="",ylab='M2',
                  type='l',lwd=1.5,ylim=c(0,max(b,na.rm=T)))
          for (a in (2:(dim(b)[2]))) for (i in (2:(dim(b)[3]))) if(max(b[,a,i],na.rm=T)>0.001) lines(y,b[,a,i],lty=a,col=a,lwd=2)
        }
      }
     }

  if (incl.closure) {
    a<-subset(closure,Species.n==sp & Repetion %in% Reps  & Iteration %in% Iter)
    b<-tapply(a$closure,list(a$Year,a$ Repetion ,a$Iteration), sum)
   y<-as.numeric(dimnames(b)[[1]])

   plot(y,b[,1,1],main=paste(loc.name[sp], "Sub model"),xlab="",ylab='sub model',
        type='s',lwd=2,ylim=c(0,max(b)))
   for (i in (2:dim(b)[2])) for (j in (1:dim(b)[3]))  lines(y,b[,i,j]+i/lReps/3,lty=min(i,max.color),col=min(i,max.color),lwd=2,type='s')
  }

  if (paper) cleanup()

}

}

#do.plot.forecast1(sp.plot=incl.sp,incl.prob=TRUE,incl.closure=T,dir="TAC_stable")
#do.plot.forecast1(sp.plot=incl.sp,incl.prob=TRUE,incl.closure=F,dir="constantF")
do.plot.forecast1(sp.plot=incl.sp,incl.prob=TRUE,incl.M2=F)


#' @export
#'
#' @title summary.eoar - summary method for EoAR objects
#'
#' @description Summarizes an EoAR model object output by \code{eoar()}.
#'
#' @param obj An object of class \code{eoar}.  See function \code{\link{eoar}}.
#'
#' @return NULL.  This function prints a summary of the model on screen.
#'
#' @author Trent McDonald
#'
#' @seealso \code{\link{eoar}}, \code{\link{coef.eoar}}.
#'
#'
#' @examples
#' # A 3 year study of 7 sites. 21 "cells". lambda change = 20/year
#' set.seed(9430834) # fixes Y and g of this example, but not the RNG's used in chains
#' ns <- 3
#'
#' ny <- 7
#' g <- data.frame(
#'  alpha = rnorm(ns*ny,70,2),
#'  beta = rnorm(ns*ny,700,25)
#' )
#' Y <- rbinom(ns*ny, c(rep(20,ny), rep(40,ny), rep(60,ny)), g$alpha/(g$alpha+g$beta))
#'
#' df <- data.frame(year=factor(c(rep("2015",ny),rep("2016",ny),rep("2017",ny))),
#'    Year=c(rep(1,ny),rep(2,ny),rep(3,ny)))
#'
#' # Uninformed eoar (use low number of iterations because it's and example)
#' eoa.1 <- eoar(Y~year, g, df, nburn = 1000, niters= 50*10, nthins = 10 )
#'
#' summary(eoa.1)
#'
summary.eoar <- function(obj){

  cat("Call:\n")
  print(obj$call)
  cat("\n")

  cat("Coefficients:\n")
  cis <- obj$intervals[labels(obj),,drop=FALSE]
  dimnames(cis)[[2]] <- paste0("CI.",dimnames(cis)[[2]])
  ests <- cbind(obj$estimates[labels(obj),,drop=FALSE], cis)
  print(ests)
  cat("\n")

  cat("Total estimated targets:\n")
  ests <- c(obj$estimates[labels(obj,"Mtot"),], obj$intervals[labels(obj,"Mtot"),])
  ests <- matrix(ests,1)
  dimnames(ests) <- list("Mtot", c("Estimate","SD",paste0("CI.",dimnames(obj$intervals)[[2]])))
  print(ests)
  cat("\n")

  cat("MCMC Information:\n")
  cat(paste(nchain(obj$out), "chains,", start(obj$out)-thin(obj$out), "burn-in steps,",
            end(obj$out)-start(obj$out), "iterations thinned by", thin(obj$out), "to", niter(obj$out), "total.\n"))

  # the following lines will print Rhats and autocorrelations
  #tmp <- cbind(obj$Rhats, obj$autoCorrs)
  #dimnames(tmp)[[2]] <- c("R-hat","Corr.Lag(2)")
  #print(tmp)

  cat("The chains likely", ifelse(obj$converged, "converged.", "DID NOT CONVERGE (try additional burn-in)."), "\n")
  if(obj$autoCorrelated){
    ncovars <- length(labels(obj))
    nchains <- nchain(obj$out)
    acf0mat <- matrix(NA, ncovars, nchains)
    for( i in 1:ncovars ){
      for(j in 1:nchains){
        tmp.2 <- acf(as.matrix(obj$out[[j]][,i]), lag.max = niter(obj$out)/2, plot=FALSE)
        tmp.2 <- data.frame(acf=tmp.2$acf,lag=tmp.2$lag)
        if( sum(tmp.2$acf>0) >0){
          tmp.2 <- tmp.2[tmp.2$acf>0,]
          acf0mat[i,j] <- min(which(diff(tmp.2$lag)>1))  # first lag acf below 0
        }
      }
    }
    cat("Within chain auto-correlation is HIGH.")
    cat(paste0(" (try nthins = ", round(mean(acf0mat,na.rm = TRUE)*thin(obj$out)), ")\n"))
  } else {
    cat("Within chain auto-correlation is acceptable.\n")
  }

}