setwd("~/Documents/rexpense/")
roundDown <- function(x) floor(x / 1000) * 1000

this_month = as.character(cut(Sys.Date(), "month"))

# Import transactions
transactions = read.csv(file = '../pytink/transactions_2020-04-27_2014.csv', na.strings = "None", fileEncoding = "UTF-8-BOM")
transactions$Date = as.Date(transactions$Date, "%Y-%m-%d")
income   = transactions[transactions$Balance > 0, ]
expense = transactions[transactions$Balance < 0, ]

# Filter out incomplete months
income = income[(income$Date > '2017-11-01') & (income$Date < this_month), ]
expense = expense[(expense$Date > '2017-11-01') & (expense$Date < this_month), ]

# Aggregate over month
library(zoo)
income_month  = aggregate(Balance ~ zoo::as.yearmon(Date), income, sum)
expense_month = aggregate(Balance ~ zoo::as.yearmon(Date), expense, sum)
names(income_month)[names(income_month) == 'zoo::as.yearmon(Date)'] <- 'Date'   # Change name of variable
names(expense_month)[names(expense_month) == 'zoo::as.yearmon(Date)'] <- 'Date' # Change name of variable

#tss$Date = as.Date(tss$Date, '%Y-%m-%d', frac=1)            # Converts datatype to Date

library(ggplot2)

#### Expense vs Savings Bar Charts
category = c(rep('Saving', nrow(income_month)),
             rep('TExpense', nrow(expense_month)))
dates = c(income_month$Date,
          expense_month$Date)
balance = c(income_month$Balance - abs(expense_month$Balance),
            abs(expense_month$Balance))
data = data.frame(category, dates, balance)

ggplot(data, aes(fill=category, x=dates, y=balance)) +
  geom_bar(position="stack", stat="identity")

ggplot(data, aes(fill=category, x=dates, y=balance)) +
  geom_bar(position="fill", stat="identity")

#### Histogram plot

data = data.frame(Saving = roundDown(income_month$Balance + expense_month$Balance), Expense = roundDown(abs(expense_month$Balance)))

ggplot(data, aes(x=x) ) +
  geom_histogram( aes(x = Saving), fill="#69b3a2", binwidth=1000, alpha=0.6) +
  geom_label( aes(x=25000, y=5, label="Saving"), color="#69b3a2") +
  geom_histogram( aes(x = Expense), fill= "#404080", binwidth=1000, alpha=0.6) +
  geom_label( aes(x=5000, y=5, label="Expense"), color="#404080") +
  xlab("Kr")


library(dplyr)
library(readr)

source("shared_code/flybase.r")

read_cuffdiff <- function(filename) {
  cuffdiff <- read_tsv(filename, progress=FALSE)

  cuffdiff <- cuffdiff[, c("gene_id", "gene", "sample_1", "sample_2", "status", "value_1", "value_2", "log2(fold_change)", "q_value", "significant")]
  names(cuffdiff) <- c("fb_gene_id", "fb_symbol","sample_1", "sample_2", "status", "RPKM_1", "RPKM_2", "fold_change", "q_value", "significant")

  cuffdiff <- transform(cuffdiff, direction = ifelse(fold_change < 0, "down", "up"))
  cuffdiff <- transform(cuffdiff, significant = ifelse(significant == "yes", TRUE, FALSE))

  genes.df <- unique(flybase_txs()[, c("fb_gene_id", "fb_symbol")])
  cuffdiff <- merge(genes.df, cuffdiff, all.y=TRUE)
  subset(cuffdiff, fb_gene_id != "-")
}

read_fpkms <- function(filename, match_str) {
  fpkms <- read.delim(filename, stringsAsFactors=FALSE, header=TRUE)
  gene_id_col <- grep("gene_id", names(fpkms))
  sample_cols <- grep(match_str, names(fpkms))
  fpkms <- fpkms[, c(gene_id_col, sample_cols)]
  names(fpkms)[1] <- "fb_gene_id"
  genes.df <- unique(flybase_txs()[, c("fb_gene_id", "fb_symbol")])
  fpkms <- merge(genes.df, fpkms, all.y=TRUE)
  fpkms
}

summarize_results <- function(cuffdiff.df) {
  summary.df <- cuffdiff.df %>%
                  group_by(sample_1, sample_2) %>%
                  summarize(up_regulated_count   = sum(significant & direction == "up"),
                            down_regulated_count = sum(significant & direction == "down"))
  summary.df
}


library("tidyr")
library("readr")
library("dplyr")
library("stringr")
library("purrr")
data <- read_file("input.txt") %>%
  str_replace_all(" contain ", "\t") %>%
  read_tsv(col_names = FALSE) %>%
  mutate(X2 = str_remove_all(X2, "\\.")) %>%
  mutate(X2 = str_split(X2, ","))

bags_allowed <- data %>%
  unnest(X2) %>%
  mutate(X1 = str_replace(X1, "bags", "")) %>%
  mutate(X1 = str_trim(X1)) %>%
  mutate(X2 = str_replace(X2, "no other bags", "0 NA")) %>%
  mutate(X2 = str_replace(X2, "bags", "")) %>%
  mutate(X2 = str_replace(X2, "bag", "")) %>%
  mutate(X2 = str_trim(X2)) %>%
  separate(X2, c("count", "inside_bag"), sep = "(?<=\\d) ")

find_bags <- function(bag_type) {
  step_results <- bags_allowed %>% filter(inside_bag == bag_type)
  if(count(step_results) > 0 ){
    for(i in 1:nrow(step_results)) {
      parent <- step_results[i,]
      if(count(parent) > 0 && as.numeric(parent$count) != 0) {
        parent_bag <- find_bags(parent$X1)
        if(!is.null(parent_bag)) {
          step_results <- step_results %>%
           add_row(parent_bag)
        }
      }
    }
    return(step_results)
  }
  return()
}

# Part 1
res <- find_bags("shiny gold")
print(length(unique(res$X1)))

# Part 2
bags_allowed <- bags_allowed %>% mutate(count  = as.numeric(count))

count_contained_bags <- function(mult, bag) {
  inside <- filter(bags_allowed, X1 == bag$inside_bag)
  total <- total + (mult * bag$count)
  mult <- mult * bag$count
  if(count(inside) > 0) {
    for(i in 1:nrow(inside)) {
      total <- total + count_contained_bags(mult, inside[i,])
    }
  }
  return(total)
}

shiny_gold <- filter(bags_allowed, X1 == "shiny gold")
total <- 0
for(i in 1:nrow(shiny_gold)) {
  total <- total +  count_contained_bags(1, shiny_gold[i,])
}
print(total)


paper<-FALSE                    # output on paper (TRUE) or screen (FALSE)
file.name<-'myfile'             # graphical output file if paper<-"Y"
Portrait<-FALSE                 # graphical output orientation

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

#####  Annual
cleanup()

if (paper) dev<-"wmf" else dev<-"screen"
nox<-1; noy<-1;
nox.noy<-nox*noy
plot.no<-nox.noy-1

if (!paper) cleanup()
#newplot(dev,nox,noy,filename=file.name,Portrait=Portrait)
#par(mar=c(3,4,3,2))

s<-Read.summary.data()

c.hat<-tapply(s$C.hat*s$weca,list(s$Year,s$Species),sum)/1000
c.obs<-tapply(s$C.obs*s$weca,list(s$Year,s$Species),sum)/1000

for (sp in first.VPA:nsp) {
  plot.no<-plot.no+1
  if (plot.no%%nox.noy==0){
      newplot(dev,nox,noy,Portrait=Portrait)
      par(mar=c(5,4,4,2)+0.1)
  }
  ssp<-sp.names[sp]
  if (nsp>1) main<-ssp else main<-' '
  year<-as.numeric(names(c.hat[,ssp]))
  plot(year,c.obs[,ssp],type='b',lwd=2,xlab='',lty=1,ylab='1000 tonnes',main=main,
                 ylim=c(0,max(c.hat[,ssp],c.obs[,ssp])),pch="o")
  legend("topleft",c('Observed','Predicted'),pch="o*",lty=c(1,3),lwd=rep(2,2),col=c(1,2))

  lines(year,c.hat[,ssp],type='b',lwd=2,lty=3,pch="*",col=2)

}
if (paper) cleanup()

#### Seasonal

cleanup()
if (paper) dev<-"wmf" else dev<-"screen"
nox<-2; noy<-2;
nox.noy<-nox*noy
plot.no<-nox.noy-1

#newplot(dev,nox,noy,filename=file.name,Portrait=Portrait)
#par(mar=c(2,4,2,2))  #c(bottom, left, top, right)

s<-Read.summary.data()

c.hat<-tapply(s$C.hat*s$weca,list(s$Species,s$Year,s$Quarter),sum)/1000
c.obs<-tapply(s$C.obs*s$weca,list(s$Species,s$Year,s$Quarter),sum)/1000
ftable(round(c.hat/c.obs,1))

c.hat<-tapply(s$C.hat*s$weca,list(s$Year,s$Species,s$Quarter),sum)/1000
c.obs<-tapply(s$C.obs*s$weca,list(s$Year,s$Species,s$Quarter),sum)/1000

for (sp in first.VPA:nsp) for (q in (1:dim(c.hat)[3])) {
  plot.no<-plot.no+1
  if (plot.no%%nox.noy==0){
      newplot(dev,nox,noy,Portrait=Portrait)
      par(mar=c(2,4,4,2)+0.1)
  }
  ssp<-sp.names[sp]
  if (nsp>1) main<-paste(ssp,' Q',q,sep='') else main<-paste('Season',q)
  year<-as.numeric(names(c.hat[,ssp,q]))
  plot(year,c.obs[,ssp,q],type='b',lwd=2,xlab='',lty=1,ylab='1000 tonnes',main=main,
                 ylim=c(0,max(c.hat[,ssp,q],c.obs[,ssp,q])),pch="o")
  legend("topleft",c('Observed','Predicted'),pch="o*",lty=c(1,3),lwd=rep(2,2),col=c(1,2))

  lines(year,c.hat[,ssp,q],type='b',lwd=2,lty=3,pch="*",col=2)

}
if (paper) cleanup()


library(shiny)
library(ggplot2)
library(dplyr)
library(RCurl)
library(zoo)

us_counties = read.csv(text = getURL("https://raw.githubusercontent.com/nytimes/covid-19-data/master/us-counties.csv"))
us_counties$date = as.Date(us_counties$date)
us_counties = us_counties[order(us_counties$county),]

# Define UI for covid by county app
ui <- pageWithSidebar(

  # App title ----
  headerPanel("Covid-19 Daily Cases per County"),

  # Sidebar panel for inputs ----
  sidebarPanel(

    #State selector
    selectInput("state", "State:",
                choices = sort(unique(us_counties$state))),

    #county selector
    selectInput("county", "County:",
                choices = NULL)

  ),

  # Main panel for displaying outputs ----
  mainPanel(
    # Output: Formatted text for caption ----
    h3(textOutput("caption")),

    plotOutput("countyPlot"),
    #HTML(
     ##     "
New York Times github!
"
    #  )
    tagList("Data Source:",a("New York Times GitHub", href="https://raw.githubusercontent.com/nytimes/covid-19-data/master/us-counties.csv"))
  )
)

# Define server logic to plot cases by county
server <- function(session,input, output) {

  observe({
    counties_in_state <- us_counties %>%
    filter(state == input$state) %>%
    select(county)
    updateSelectInput(session, "county", "County:", choices = unique(counties_in_state))
  })

  filtered_data<-reactive({
    us_counties %>%
      filter(state==input$state, county==input$county) %>%
      arrange("date") %>%
      mutate(daily_cases = cases - lag(cases, default = first(cases))) %>%
      mutate(rollavg=rollapply(daily_cases,7,mean, align='right',fill=NA))

  })

  # Compute the formula text ----
  formulaText <- reactive({
    paste("Cases in", input$county, "county", input$state)
  })

  # Return the formula text for printing as a caption ----
  output$caption <- renderText({
    formulaText()
  })

  # Generate a plot of daily cases by county
  output$countyPlot <- renderPlot({
    ggplot(filtered_data(), aes(x=date,y = daily_cases)) +
      geom_col(fill = "dark blue") +
      xlab("Date") +
      ylab("New Cases") +
      scale_x_date(date_breaks = "1 month", date_labels =  "%b %Y") +
      geom_line(data=filtered_data(), aes(x=date, y=rollavg), colour="red", size = 1.3)
  })

}

shinyApp(ui, server)


# Uvozimo funkcije za pobiranje in uvoz zemljevida.
source('lib/uvozi.zemljevid.r')
source('lib/libraries.r', encoding = 'UTF-8')

#========================================================================================================

# graf: prikaz BDP per capita glede na Slovenijo in leto

graf_bdp_slo <- ggplot((data = bruto_slovenija), aes(x=Leto, y=BDP)) + geom_point() + geom_line(group = 1)

#========================================================================================================

# Graf: Razmerje med otroci vkljucenimi v vrtec in ljudmi, ki zivijo v doloceni reg

graf_otroci_indeks <- ggplot((data = razmerje), aes(x=Leto, y=Indeks, col=Regija)) + geom_point() + geom_line() +
  scale_x_continuous('Leto', breaks = seq(2007, 2017, 1), limits = c(2007,2017))

#========================================================================================================
# Graf: Zemljevid

Slovenija <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1") %>% fortify()
colnames(Slovenija)[12] <- 'Regija'
Slovenija$Regija <- gsub('Notranjsko-kraška', 'Primorsko-notranjska', Slovenija$Regija)
Slovenija$Regija <- gsub('Spodnjeposavska', 'Posavska', Slovenija$Regija)

graf_slovenija <- ggplot(Slovenija, aes(x=long, y=lat, group=group, fill=Regija)) +
  geom_polygon() +
  labs(title="Slovenija") +
  theme_classic()
#========================================================================================================
#Tabele za zemljevide

diplomanti.2007 <- filter(diplomanti, Leto == '2007')
diplomanti.2011 <- filter(diplomanti, Leto == '2011')
diplomanti.2016 <- filter(diplomanti, Leto == '2016')

#========================================================================================================
#Zemljevidi diplomantov na 1000 ljudi

zemljevid.2007.diplomanti <- ggplot() +
  geom_polygon(data = right_join(diplomanti.2007,Slovenija, by = c('Regija')),
               aes(x = long, y = lat, group = group, fill = Stevilo))+
  xlab("") + ylab("") + ggtitle('Diplomanti v letu 2007 na 1000 prebivalcev') +
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#25511C', high='#2BFF00', limits = c(6,17))
zemljevid.2007.diplomanti$labels$fill <- 'Diplomanti na 1000 prebivalcev'

zemljevid.2011.diplomanti <- ggplot() +
  geom_polygon(data = right_join(diplomanti.2011,Slovenija, by = c('Regija')),
               aes(x = long, y = lat, group = group, fill = Stevilo))+
  xlab("") + ylab("") + ggtitle('Diplomanti v letu 2011 na 1000 prebivalcev') +
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#25511C', high='#2BFF00', limits = c(6,17))
zemljevid.2011.diplomanti$labels$fill <- 'Diplomanti na 1000 prebivalcev'

zemljevid.2016.diplomanti <- ggplot() +
  geom_polygon(data = right_join(diplomanti.2016,Slovenija, by = c('Regija')),
               aes(x = long, y = lat, group = group, fill = Stevilo))+
  xlab("") + ylab("") + ggtitle('Diplomanti v letu 2016 na 1000 prebivalcev') +
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#25511C', high='#2BFF00', limits = c(6,17))
zemljevid.2016.diplomanti$labels$fill <- 'Diplomanti na 1000 prebivalcev'

#========================================================================================================
#plotly

graf_indeks <- ggplot(data = indeks, aes(x=Studenti, y=Diplomanti, color=Regija)) + geom_point(aes(frame=Leto, ids=Regija)) + scale_x_log10()
graf_indeks <- graf_indeks + xlab('Terciarno šolanje') + ylab('Diplomanti')
graf_indeks <- ggplotly(graf_indeks)

#========================================================================================================
#Cluster

osnovne_sole1 <- dcast(osnovne_sole, Regija ~ Leto)
dijaki1 <- dcast(dijaki, Regija ~ Leto)

sole <- left_join(osnovne_sole1, dijaki1, by=c('Regija'))

sole1 <- sole[,-1]
fit<-hclust(dist(scale(sole1)))
skupine <- cutree(fit, 4)

cluster <- mutate(sole, skupine)

zemljevid_cluster <- ggplot() +
  geom_polygon(data = right_join(cluster[c(-2:-23)], Slovenija, by=c('Regija')), aes(x=long, y=lat, group = group, fill=factor(skupine))) +
  geom_line() +
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank(), legend.position = 'None') +
  ggtitle('Osnovnošolci in dijaki med letoma 2007 in 2017')


library(edgeR)
library(dplyr)
library(tibble)

getCountObj <- function(x){
  #print(paste(x))
  featureCountRDS <- readRDS(x)
  return(featureCountRDS$count)
}

fpkmToTpm <- function(fpkm){
    exp(log(fpkm) - log(sum(fpkm)) + log(1e6))
  }

normalize <- function(countObj, workdir="", annotName = "", method="", fileName="", annotationRDS="", Refcol =1, priorCount=0, merge=T, saveFiles=F,
                        condition=""){

    Annotation <- data.frame(readRDS(annotationRDS))

    #drop       <- which( apply(countObj,1,sum) <= 1); print(paste("Droping ", length(drop))) ; countObj <- countObj[-drop,]
    #Annotation <- Annotation[-drop,]

    if(priorCount == 0) { tolog = FALSE}  else{ tolog = TRUE }

    ########################################### Choose the Annotation
    #print(paste("Chooseing the Annotation"))
    if( annotName == "exon")
    {
      #print(paste("I am Exon"))
      rownames(Annotation) <- Annotation$ExonID
      Annotation$ExonID    <- factor(Annotation$ExonID, levels=rownames(countObj))
      Annotation           <- Annotation %>% dplyr::arrange(ExonID)

      genesObj <- Annotation[,c("ExonID", "Length")]
    }
    else if(annotName == "trans"){
      rownames(Annotation) <- Annotation$TranscriptID
      Annotation$TranscriptID <- factor(Annotation$TranscriptID, levels=rownames(countObj))
      Annotation <- Annotation %>% dplyr::arrange(TranscriptID)
      genesObj <- Annotation[,c("TranscriptID", "Length")]
    }
    else{
      rownames(Annotation) <- Annotation$GeneID
      Annotation$GeneID <- factor(Annotation$GeneID, levels=rownames(countObj))
      Annotation           <- Annotation %>% dplyr::arrange(GeneID)
      Annotation <- Annotation %>% dplyr::filter(GeneID %in% rownames(countObj))
      genesObj <- Annotation[,c("GeneID", "Length")]
    }

    ########################################### Choose the Method
    #print(paste("Chooseing the Normalization Method"))
    if( method=="EdgeR") {

   #### EdgeR
      ##  Make EdgeR Object
      colnames(genesObj) <- c("GeneID", "Length")
      length(countObj)
      length(genesObj)
      GeneDF_EdgeR       <- DGEList(counts=countObj, genes=genesObj)
      ## Estimate Normalising Factors
      GeneDF.Norm  <- calcNormFactors(GeneDF_EdgeR, refColumn = Refcol) ;
      ## Regularized Log Transformation using CPM, FPKM & TPM values
      #GeneDF.tpm   <- as.data.frame(cpm(GeneDF.Norm,  normalized.lib.sizes = TRUE,log = tolog, prior.count = priorCount))
      GeneDF.rpkm  <- as.data.frame(rpkm(GeneDF.Norm, normalized.lib.sizes = T, gene.length=genesObj$Length))
      GeneDF.tpm   <- apply(rpkm(GeneDF.Norm, normalized.lib.sizes = T, gene.length=genesObj$Length), 2 , fpkmToTpm)
      #GeneDF.ScaledTpm <- t(t(GeneDF.tpm) / GeneDF.Norm$samples$norm.factors)
      #GeneDF.ScaledTpm <- GeneDF.tpm
    }
    else if( method == "DESeq") {
    #### DESeq
      ##Make DESeq Object
      GeneDF_DESeq      <- DESeqDataSetFromMatrix(countData = as.matrix(countObj), colData = DataFrame(condition), design = ~ condition)
      mcols(GeneDF_DESeq)$basepairs <- genesObj$Length-175+1
      ## Estimate SizeFactors
      GeneDF.Norm <- estimateSizeFactors(GeneDF_DESeq)
      ## Regularized Log Transformation using CPM, FPKM & TPM values
      GeneDF.fpm   <- as.data.frame(fpm(object = GeneDF.Norm,  robust = TRUE))
      GeneDF.rpkm  <- as.data.frame(fpkm(object = GeneDF.Norm,  robust = TRUE))
      GeneDF.tpm   <- apply(GeneDF.rpkm, 2 , fpkmToTpm)
    }

    ########################################### Prepare final files
    if( annotName == "Exon")
    {
      #GeneDF_Norm_CPM  <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID", "GeneName","TranscriptID","ExonID")]), GeneDF.CPM )
      GeneDF_Norm_rpkm <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID", "GeneName","TranscriptID","ExonID")]), GeneDF.rpkm )
      GeneDF_Norm_tpm  <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID", "GeneName","TranscriptID","ExonID")]), GeneDF.tpm )

    }
    else if(annotName == "trans"){

      #GeneDF_Norm_CPM  <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID","GeneName","TranscriptID")]), GeneDF.CPM )
      GeneDF_Norm_rpkm <- cbind(data.frame(Annotation[,c("TranscriptID", "GeneID", "GeneName")]), GeneDF.rpkm )
      GeneDF_Norm_tpm  <- cbind(data.frame(Annotation[,c("TranscriptID", "GeneID", "GeneName")]), GeneDF.tpm)

    }
    else{
      #GeneDF_Norm_CPM  <- cbind(data.frame(Annotation[,c("Chr","Start","End","GeneID","GeneName")]), GeneDF.CPM)
      GeneDF_Norm_rpkm <- cbind(data.frame(Annotation[,c("GeneID", "GeneID", "GeneName")]), GeneDF.rpkm)
      GeneDF_Norm_tpm  <- cbind(data.frame(Annotation[,c("GeneID", "GeneID", "GeneName")]), GeneDF.tpm)
    }

    ########################################### Choose approprite folder and write files
    if(merge) {   RawCount=FPKM=CPM=TPM="/MergedFiles/" }
    else { RawCount="/RawCount/"; FPKM="/FPKM/" ; CPM="/CPM/" ; TPM="/TPM"}

    if(saveFiles)
    {
      #write.table(countObj, paste(workdir,fileName,"_Count_",annotName,".txt", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
      #write.table(GeneDF_Norm_rpkm, paste(workdir,fileName,"_Norm_rpkm_",annotName,".txt", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
      #write.table(GeneDF_Norm_CPM, paste(workdir, fileName,"_Norm_cpm_",annotName,".txt", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
      #write.table(GeneDF_Norm_tpm, paste(workdir,fileName,"_Norm_tpm_",annotName,".txt", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
    }
    return(list("tpm" = GeneDF_Norm_tpm, "rpkm" = GeneDF_Norm_rpkm))

}

getColName <- function(x){
  sample <- gsub("Sample_", "", gsub(".*\\.(.*)\\.star_.*", "\\1", c(x)))
  idx <- grep(sample,f[,1])
  if ( identical(idx, integer(0)) ) {
    return (sample)
  }
  return (f[idx[1],2])
}

Args<-commandArgs()
inFile<-Args[6]
annotationRDS <- Args[7]
annotationType <- Args[8]
outDIR <- Args[9]
outFile <- Args[10]

f<-read.table(inFile, header=F)
f<-as.matrix(f)
countObj<- do.call(cbind,lapply(f[,3],getCountObj))
#fileList=c("/mnt/webrepo/fr-s-bsg-onc-d/htdocs/onco.data/ProcessedResults/clinomics/CL0045/20160415/CL0045_T2R_T/TPM_UCSC/CL0045_T2R_T_counts.Gene.fc.RDS","/mnt/webrepo/fr-s-bsg-onc-d/htdocs/onco.data/ProcessedResults/clinomics/CL0045/20160415/CL0045_T1R_T4/TPM_UCSC/CL0045_T1R_T4_counts.Gene.fc.RDS")
#annotationRDS = "/mnt/webrepo/fr-s-bsg-onc-d/htdocs/clinomics_dev/app/storage/data/AnnotationRDS/annotation_UCSC_gene.RDS"

GeneDF_Norm<-normalize(countObj=countObj, workdir=outDIR, annotName=annotationType, method="EdgeR", annotationRDS=annotationRDS ,
  priorCount=0, fileName=outFile, merge=T, saveFiles=T)

old_cols <- colnames(GeneDF_Norm$tpm, do.NULL = FALSE)
new_cols <-lapply(old_cols, getColName)
colnames(GeneDF_Norm$tpm) <- new_cols
colnames(GeneDF_Norm$rpkm) <- new_cols

write.table(GeneDF_Norm$tpm, paste(outDIR,outFile,".tpm.tsv", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)
write.table(GeneDF_Norm$rpkm, paste(outDIR,outFile,".tmm-rpkm.tsv", sep= ""), sep="\t",row.names = FALSE, quote = FALSE)


# Expression profiling by array-breast cancer

#   Differential expression analysis with limma
library(GEOquery)
library(limma)
library(umap)

# load series and platform data from GEO

gset <- getGEO("GSE118981", GSEMatrix =TRUE, AnnotGPL=FALSE)
if (length(gset) > 1) idx <- grep("GPL15950", attr(gset, "names")) else idx <- 1
gset <- gset[[idx]]

# make proper column names to match toptable
fvarLabels(gset) <- make.names(fvarLabels(gset))

# group membership for all samples
gsms <- "0122XX10X102"
sml <- strsplit(gsms, split="")[[1]]

# filter out excluded samples (marked as "X")
sel <- which(sml != "X")
sml <- sml[sel]
gset <- gset[ ,sel]

# log2 transformation
ex <- exprs(gset)
qx <- as.numeric(quantile(ex, c(0., 0.25, 0.5, 0.75, 0.99, 1.0), na.rm=T))
LogC <- (qx[5] > 100) ||
          (qx[6]-qx[1] > 50 && qx[2] > 0)
if (LogC) { ex[which(ex <= 0)] <- NaN
  exprs(gset) <- log2(ex) }

# assign samples to groups and set up design matrix
gs <- factor(sml)
groups <- make.names(c("A","C","B"))
levels(gs) <- groups
gset$group <- gs
design <- model.matrix(~group + 0, gset)
colnames(design) <- levels(gs)

fit <- lmFit(gset, design)  # fit linear model

# set up contrasts of interest and recalculate model coefficients
cts <- paste(groups, c(tail(groups, -1), head(groups, 1)), sep="-")
cont.matrix <- makeContrasts(contrasts=cts, levels=design)
fit2 <- contrasts.fit(fit, cont.matrix)

# compute statistics and table of top significant genes
fit2 <- eBayes(fit2, 0.01)
tT <- topTable(fit2, adjust="fdr", sort.by="B", number=250)

tT <- subset(tT, select=c("ID","adj.P.Val","P.Value","F","SPOT_ID","GB_ACC","SEQUENCE"))
write.table(tT, file=stdout(), row.names=F, sep="\t")

# Visualize and quality control test results.
# Build histogram of P-values for all genes. Normal test
# assumption is that most genes are not differentially expressed.
tT2 <- topTable(fit2, adjust="fdr", sort.by="B", number=Inf)
hist(tT2$adj.P.Val, col = "grey", border = "white", xlab = "P-adj",
  ylab = "Number of genes", main = "P-adj value distribution")

# summarize test results as "up", "down" or "not expressed"
dT <- decideTests(fit2, adjust.method="fdr", p.value=0.05)

# Venn diagram of results
vennDiagram(dT, circle.col=palette())

# create Q-Q plot for t-statistic
t.good <- which(!is.na(fit2$F)) # filter out bad probes
qqt(fit2$t[t.good], fit2$df.total[t.good], main="Moderated t statistic")

# volcano plot (log P-value vs log fold change)
colnames(fit2) # list contrast names
ct <- 1        # choose contrast of interest
volcanoplot(fit2, coef=ct, main=colnames(fit2)[ct], pch=20,
  highlight=length(which(dT[,ct]!=0)), names=rep('+', nrow(fit2)))

# MD plot (log fold change vs mean log expression)
# highlight statistically significant (p-adj < 0.05) probes
plotMD(fit2, column=ct, status=dT[,ct], legend=F, pch=20, cex=1)
abline(h=0)

################################################################
# General expression data analysis
ex <- exprs(gset)

# box-and-whisker plot
ord <- order(gs)  # order samples by group
palette(c("#1B9E77", "#7570B3", "#E7298A", "#E6AB02", "#D95F02",
          "#66A61E", "#A6761D", "#B32424", "#B324B3", "#666666"))
par(mar=c(7,4,2,1))
title <- paste ("GSE118981", "/", annotation(gset), sep ="")
boxplot(ex[,ord], boxwex=0.6, notch=T, main=title, outline=FALSE, las=2, col=gs[ord])
legend("topleft", groups, fill=palette(), bty="n")

# expression value distribution
par(mar=c(4,4,2,1))
title <- paste ("GSE118981", "/", annotation(gset), " value distribution", sep ="")
plotDensities(ex, group=gs, main=title, legend ="topright")

# UMAP plot (dimensionality reduction)
ex <- na.omit(ex) # eliminate rows with NAs
ex <- ex[!duplicated(ex), ]  # remove duplicates
ump <- umap(t(ex), n_neighbors = 4, random_state = 123)
par(mar=c(3,3,2,6), xpd=TRUE)
plot(ump$layout, main="UMAP plot, nbrs=4", xlab="", ylab="", col=gs, pch=20, cex=1.5)
legend("topright", inset=c(-0.15,0), legend=levels(gs), pch=20,
col=1:nlevels(gs), title="Group", pt.cex=1.5)
library("maptools")  # point labels without overlaps
pointLabel(ump$layout, labels = rownames(ump$layout), method="SANN", cex=0.6)

# mean-variance trend, helps to see if precision weights are needed
plotSA(fit2, main="Mean variance trend, GSE118981")


################################################################################################################################################
#                                                Script to create vars for the diversity domain                                                #                                                                                #
# I) National Diversity                                                                                #
# Vars: % of                                                                                #
# 1. multiples (independent, small multiples [<10], large multiples [>10]),                                                                    #
# 2. retail diversity (comparison + convenience)                                                                                #
# 3. services diversity (leisure + services)                                                                                #
# 4. total number of stores                                                                                #
# 5. most popular comparison, convenience and leisure chains                                                                                #
################################################################################################################################################

library(sf)
library(stringr)
library(data.table)
library(clusterCrit)
library(parallel)

ru <- st_read("~/Dropbox/liverpool/catchments/catchments2/retail_units/retail_units_all_data_area_id_names_fin.shp", stringsAsFactors = F)
ru2 <- as.data.frame(ru)
setDT(ru2)

setkey(ru2, cluster_id)
ru2[, store_name2 := str_to_lower(str_trim(store_name))]
################################################################################################################################################
#                                                           National Diversity                                                                 #
################################################################################################################################################
comp_conv <- ru2[classifica %in% c("Comparison", "Convenience") & !category %in% c("Chemists, Toiletries & Health", "Discount & Surplus Stores"), ]
count_stores <- table(comp_conv$store_name)

##### 1. Independent multiples (1 unique store name for comparison and convenience) ############################################################

independent_stores <- names(which(count_stores == 1))
indie <- comp_conv[, 100 * sum(store_name %in% independent_stores) / .N, by = cluster_id]
setnames(indie, "V1", "indie_pct")

##### 2. Small multiples ( > 1 & <= 10 stores for comparison and convenience) ##################################################################

small_multi_names <- names(which(count_stores > 1 & count_stores <= 10))
small_multi <- comp_conv[, 100 * sum(store_name %in% small_multi_names) / .N, by = cluster_id]
setnames(small_multi, "V1", "small_multi_pct")

##### 3. Large multiples ( > 10 stores for comparison and convenience) #########################################################################

large_multi_names <- names(which(count_stores > 10))
large_multi <- comp_conv[, 100 * sum(store_name %in% large_multi_names) / .N, by = cluster_id]
setnames(large_multi, "V1", "large_multi_pct")

##### 4. Retail diversity (number of unique subcategory / total number of subcategory for comparison and convenience) ##########################

total_subcat <- comp_conv[, length(unique(subcat))]
retail_diversity <- comp_conv[, 100 * length(unique(subcat)) / total_subcat, by = cluster_id]
setnames(retail_diversity, "V1", "retail_diversity_pct")

##### 5. Services diversity (number of unique subcategory / total number of subcategory for leisure and services) ##############################

total_subcat_services <- ru2[classifica %in% c("Leisure", "Services"), length(unique(subcat))]
services_diversity <- ru2[classifica %in% c("Leisure", "Services"), 100 * length(unique(subcat)) / total_subcat_services, by = cluster_id]
setnames(services_diversity, "V1", "services_diversity_pct")

##### 6. Department stores (total number of stores) ############################################################################################

department_stores <- ru2[, 100 * sum(subcat == "Department Stores") / .N, by = cluster_id]
setnames(department_stores, "V1", "department_stores_pct")

##### 7. Attractive comparison (number of unique attractive stores / total number of unique attractive stores) #################################

attractive_comparison_list <- list(# john_lewis = c("john lewis at home", "john lewis", "john lewis of hungerford"),
                               # debenhams = c("debenhams", "desire by debenhams"),
                               boots = "boots the chemist",
                               # primark = "primark",
                               next_ = c("next", "next clearance", "next home", "next furniture"),
                               h_m = c("h&m", "h&m kids", "h&m discounts"),
                               # fraser = c("house of fraser", "house of fraser outlet", "house of fraser binns", "house of fraser beatties",
                               #            "highland house of fraser", "house of fraser outlet store"),
                               # harvey_nichols = "harvey nichols",
                               m_s = c("marks & spencer", "marks & spencer outlet", "marks & spencer home"),
                               # zara = "zara",
                               # b_q = "b&q",
                               # currys = c("currys", "currys megastore", "currys pc world", "currys pc world megastore"),
                               argos = c("argos", "argos extra"),
                               tkmaxx = "tk maxx",
                               # ikea = "ikea",
                               # b_m = c("b&m bargains", "b&m home store"),
                               home_bargains = c("home bargains"),
                               wilko = c("wilko"),
                               whsmith = c("whsmith", "whsmith books", "whsmith bookshop", "whsmith stationery"),
                               holland_barrett = "holland & barrett",
                               superdrug = "superdrug",
                               carphone = "the carphone warehouse",
                               ee = "ee",
                               poundland = "poundland",
                               new_look = "new look",
                               vodafone = "vodafone",
                               clarks = c("clarks", "clarks factory shop", "clarks outlet"),
                               shoe_zone = "shoe zone",
                               o2 = "o2",
                               h.samuel = "h.samuel",
                               jd_sports = "jd sports",
                               sports_direct = "sports direct",
                               peacocks = "peacocks",
                               carpetright = "carpetright",
                               dorothy_perkins = "dorothy perkins",
                               three_store = "3 store",
                               game = "game",
                               poundstretcher = "poundstretcher",
                               brighthouse = "brighthouse",
                               body_shop = c("the body shop", "the body shop depot", "the body shop outlet"),
                               pets_home = "pets at home",
                               river_island = "river island",
                               ryman_stationer = "ryman the stationer",
                               bonmarche = "bonmarche",
                               poundworld = c("poundworld", "poundworld express", "poundworld extra", "poundworld plus"),
                               stores_99p = c("99p stores", "99p stores plus"),
                               mco = c("m&co", "m&co kids"),
                               waterstones = "waterstones",
                               the_works = c("the works", "the works outlet")
)

comparison_stores_lookup <- as.data.frame(do.call(rbind, lapply(names(attractive_comparison_list),
                                                                function(store_name) cbind(store_name, attractive_comparison_list[[store_name]]))),
                                          stringsAsFactors = F)
names(comparison_stores_lookup) <- c("retailer_name", "retailer_store_names")
setDT(comparison_stores_lookup)

ru2[comparison_stores_lookup, attractive_comp := i.retailer_name, on = c(store_name2 = "retailer_store_names")]

attractive_comparison <- ru2[, 100 * (length(unique(attractive_comp)) - 1) / length(attractive_comparison_list), by = "cluster_id"] # -1 to account for NA being among the unique values
setnames(attractive_comparison, "V1", "attractive_comparison_pct")

##### 8. Attractive convenience (number of unique attractive stores / total number of unique attractive stores) #################################

# occur <- sapply(unique(ru$store_name2), function(x) "clintons" %in% unlist(strsplit(x, " ")))
# ru[store_name2 %in% names(occur[occur]), sort(table(store_name2), decreasing = T)]

convenience_list <- list(asda = c("asda", "asda supercentre"),
                         morrisons = "morrisons",
                         sainsburys = c("sainsbury's", "sainsbury's market"),
                         tesco = c("tesco metro", "tesco", "tesco extra"),
                         waitrose = "waitrose",
                         aldi = "aldi",
                         lidl = "lidl",
                         coop = c("the co-operative food", "the midcounties co-operative food", "lincolnshire co-operative foodstores", "the southern co-operative food"),
                         ms =  "marks & spencer simply food",
                         iceland = "iceland",
                         greggs = c("greggs", "greggs bakery outlet", "greggs cafe", "greggs the bakery"),
                         card_factory = "card factory",
                         clintons = c("clintons", "simply clintons"),
                         lloyds_pharmacy = "lloydspharmacy",
                         thorntons = c("cafe thorntons", "thorntons", "thorntons chocolate cafe", "thorntons icecream parlour"),
                         spar = "spar",
                         farmfoods = "farmfoods",
                         heron_foods = "heron foods",
                         hallmark = "hallmark",
                         savers = "savers health & beauty")

convenience_lookup_table <- as.data.frame(do.call(rbind, lapply(names(convenience_list),
                                                         function(store_name) cbind(store_name, convenience_list[[store_name]]))),
                                   stringsAsFactors = F)
names(convenience_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(convenience_lookup_table)

ru2[convenience_lookup_table, attractive_conv := i.retailer_name, on = c(store_name2 = "retailer_store_names")]
attractive_convenience <- ru2[, 100 * (length(unique(attractive_conv)) - 1) / length(convenience_list), by = "cluster_id"]
setnames(attractive_convenience, "V1", "attractive_convenience_pct")

##### 9. Attractive leisure (number of unique attractive stores / total number of unique attractive stores) #################################

leisure_list <- list(starbucks = "starbucks coffee",
                     costa = "costa",
                     caffe_nero = "caffe nero",
                     mcdonalds = "mcdonald's",
                     kfc = "kfc",
                     subway = "subway",
                     dominos = "domino's pizza",
                     pizza_express = "pizzaexpress",
                     nandos = "nando's",
                     pizza_hut = c("pizza hut", "pizza hut delivery", "pizza hut express"),
                     prezzo = "prezzo",
                     frankie_bennys = "frankie & benny's",
                     zizzi = "zizzi",
                     wagamama = "wagamama",
                     ask_italian = "ask italian",
                     william_hill = "william hill",
                     ladbrokes = "ladbrokes",
                     coral = "coral",
                     betfred = "betfred",
                     paddy_power = "paddy power",
                     pret_a_manger = "pret a manger",
                     burger_king = "burger king",
                     papa_johns = "papa john's",
                     eat = "eat.",
                     cashino_gaming = "cashino gaming"
                     )

leisure_lookup_table <- as.data.frame(do.call(rbind, lapply(names(leisure_list),
                                                                function(store_name) cbind(store_name, leisure_list[[store_name]]))),
                                          stringsAsFactors = F)
names(leisure_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(leisure_lookup_table)

ru2[leisure_lookup_table, attractive_leisu := i.retailer_name, on = c(store_name2 = "retailer_store_names")]
attractive_leisure <- ru2[, 100 * (length(unique(attractive_leisu)) - 1) / length(leisure_list), by = "cluster_id"]
setnames(attractive_leisure, "V1", "attractive_leisure_pct")

##### 10. Attractive consumer services (number of unique attractive stores / total number of unique attractive stores) ########################

consumer_list <- list(barclays = "barclays bank plc",
                     natwest = "natwest",
                     lloyds = "lloyds bank",
                     hsbc = "hsbc",
                     santander = "santander",
                     nationwide_building_society = "nationwide building society",
                     halifax = "halifax plc",
                     tsb = "tsb bank",
                     post_office = "post office",
                     thomas_cook = "thomas cook",
                     thomson = "thomson",
                     specsavers = c("specksavers opticians", "specsavers hearcare", "specsavers hearing centre"),
                     sue_ryder_care = "sue ryder care",
                     timpson = "timpson",
                     halfords = c("halfords", "halfords autocentre", "halfords cycle republic")
                     )

consumer_lookup_table <- as.data.frame(do.call(rbind, lapply(names(consumer_list),
                                                            function(store_name) cbind(store_name, consumer_list[[store_name]]))),
                                      stringsAsFactors = F)
names(consumer_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(consumer_lookup_table)

ru2[consumer_lookup_table, attractive_cons := i.retailer_name, on = c(store_name2 = "retailer_store_names")]
attractive_consumer <- ru2[, 100 * (length(unique(attractive_cons)) - 1) / length(consumer_list), by = "cluster_id"]
setnames(attractive_consumer, "V1", "attractive_consumer_pct")

##### 11. Put everything together ####################################################################################################

out <- department_stores[attractive_comparison, on = "cluster_id"]
out <- attractive_consumer[out, on = "cluster_id"]
out <- attractive_convenience[out, on = "cluster_id"]
out <- attractive_leisure[out, on = "cluster_id"]
out <- indie[out, on = "cluster_id"]
out <- large_multi[out, on = "cluster_id"]
out <- small_multi[out, on = "cluster_id"]
out <- retail_diversity[out, on = "cluster_id"]
out <- services_diversity[out, on = "cluster_id"]
out[is.na(services_diversity_pct), services_diversity_pct := 0 ]
out[is.na(retail_diversity_pct), c("retail_diversity_pct", "small_multi_pct", "large_multi_pct", "indie_pct") := list(0, 0, 0, 0)]

fwrite(out, "~/Dropbox/liverpool/retail_typology/analysis/indicators/national_diversity.csv")


tg = dat$tg
nh = dat$tc - dat$hdl

#
idx.r = c(1:nrow(dat))
dat$factor[idx.r] = 6.7
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.5
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 8.1
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 8.8
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 10
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 11.9

#
idx.r = which(tg < 400)
dat$factor[idx.r] = 5.9
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.5
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.0
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.5
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 8.3
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 9.5

#
idx.r = which(tg < 293)
dat$factor[idx.r] = 5.6
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.1
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.5
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.0
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.6
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 8.5

#
idx.r = which(tg < 293)
dat$factor[idx.r] = 5.6
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.1
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.5
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.0
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.6
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 8.5

#
idx.r = which(tg < 248)
dat$factor[idx.r] = 5.4
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.9
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.2
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.6
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.2
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 8.0

#
idx.r = which(tg < 221)
dat$factor[idx.r] = 5.3
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.6
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.0
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.4
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.9
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.6

#
idx.r = which(tg < 202)
dat$factor[idx.r] = 5.2
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.5
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.8
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.2
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.7
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.3

#
idx.r = which(tg < 186)
dat$factor[idx.r] = 5.1
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.4
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.7
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.0
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.5
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 7.0

#
idx.r = which(tg < 174)
dat$factor[idx.r] = 5.0
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.3
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.5
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.9
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.3
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.8
table(dat$factor)

#
idx.r = which(tg < 164)
dat$factor[idx.r] = 4.9
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.2
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.4
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.8
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.2
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.7
table(dat$factor)

#
idx.r = which(tg < 155)
dat$factor[idx.r] = 4.8
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.1
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.4
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.7
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.0
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.5

#
idx.r = which(tg < 147)
dat$factor[idx.r] = 4.8
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.0
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.3
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.6
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.9
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.3

#
idx.r = which(tg < 139)
dat$factor[idx.r] = 4.7
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.0
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.2
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.4
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.8
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.2

#
idx.r = which(tg < 133)
dat$factor[idx.r] = 4.7
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.9
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.1
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.3
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.7
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.1

#
idx.r = which(tg < 127)
dat$factor[idx.r] = 4.6
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.8
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.0
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.3
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.5
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.0

#
idx.r = which(tg < 127)
dat$factor[idx.r] = 4.6
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.8
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.0
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.3
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.5
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 6.0

#
idx.r = which(tg < 121)
dat$factor[idx.r] = 4.6
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.8
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.0
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.2
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.5
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.8

#
idx.r = which(tg < 116)
dat$factor[idx.r] = 4.5
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.7
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.9
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.1
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.4
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.7

#
idx.r = which(tg < 111)
dat$factor[idx.r] = 4.5
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.6
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.8
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.0
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.3
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.6

#
idx.r = which(tg < 106)
dat$factor[idx.r] = 4.5
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.6
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.7
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.0
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.2
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.5

#
idx.r = which(tg < 101)
dat$factor[idx.r] = 4.3
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.5
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.7
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.8
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.1
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.4

#
idx.r = which(tg < 97)
dat$factor[idx.r] = 4.4
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.5
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.7
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.8
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.0
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.3

#
idx.r = which(tg < 93)
dat$factor[idx.r] = 4.3
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.4
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.6
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.7
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.9
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.2

#
idx.r = which(tg < 88)
dat$factor[idx.r] = 4.3
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.4
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.5
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.6
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.8
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.1

#
idx.r = which(tg < 84)
dat$factor[idx.r] = 4.2
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.3
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.4
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.6
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.8
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 5.0

#
idx.r = which(tg < 80)
dat$factor[idx.r] = 4.2
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.3
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.3
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.5
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.6
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.9

#
idx.r = which(tg < 76)
dat$factor[idx.r] = 4.1
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.2
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.2
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.4
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.6
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.8

#
idx.r = which(tg < 72)
dat$factor[idx.r] = 3.9
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.1
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.2
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.3
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.4
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.7

#
idx.r = which(tg < 67)
dat$factor[idx.r] = 3.9
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.9
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.0
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.1
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.3
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.5

#
idx.r = which(tg < 62)
dat$factor[idx.r] = 3.6
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.8
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.9
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.0
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.1
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.3

#
idx.r = which(tg < 57)
dat$factor[idx.r] = 3.4
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.6
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.6
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.7
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.9
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 4.0
table(dat$factor)

#
idx.r = which(tg < 50)
dat$factor[idx.r] = 3.1
idx.c = which(nh < 220)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.2
idx.c = which(nh < 190)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.3
idx.c = which(nh < 160)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.3
idx.c = which(nh < 130)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.4
idx.c = which(nh < 100)
idx1 = intersect(idx.r, idx.c)
dat$factor[idx1] = 3.5

dat$novel = dat$tc - dat$hdl - dat$tg/dat$factor


library(EpiNow2)
library(data.table)
library(optparse)
library(rstan)
source("covidmap/utils.r")

epinow2_options = function(
    first_day_modelled   = NULL,
    last_day_modelled    = NULL,
    weeks_modelled       = NULL,
    days_ignored         = NULL,
    days_per_step        = 7,
    days_predicted       = 0,
    num_steps_forecasted = 3,

    num_iterations      = 2000,
    num_chains          = 4,
    data_directory      = 'data',
    results_directory   = 'fits/test',
    verbose             = TRUE,

    area_index          = 0
) {
  as.list(environment())
}

epinow2_run = function(area_index, opt) {
    print(opt)

    cases = read.csv(sprintf('%s/cases.csv',opt$results_directory))
    areas = rownames(read.csv(sprintf('%s/areas.csv',opt$data_directory),row.names=1))
    area = areas[area_index]
    dates = as.Date(names(cases)[3:ncol(cases)], format="X%Y.%m.%d")

    list[Nstep, Tstep, Tcond, Tlik, Tcur, Tignore] = process_dates_modelled(
        dates,
        first_day_modelled = opt$first_day_modelled,
        last_day_modelled  = opt$last_day_modelled,
        days_ignored       = opt$days_ignored,
        weeks_modelled     = opt$weeks_modelled,
        days_per_step      = opt$days_per_step
    )

    start_date <- dates[Tcond + 1]
    end_date <- dates[Tcond + (Nstep * opt$days_per_step)]
    days_forecast = Tstep * opt$num_steps_forecasted

    input_data = data.frame(date = dates, confirm = as.numeric(cases[area_index, 3:ncol(cases)]))
    input_data = input_data[input_data$date >= start_date & input_data$date <= end_date,]

    # These are just the default parameters that the package suggests in the README
    reporting_delay <- estimate_delay(rlnorm(1000,  log(3), 1), max_value = 15, bootstraps = 1)
    generation_time <- get_generation_time(disease = "SARS-CoV-2", source = "ganyani")
    incubation_period <- get_incubation_period(disease = "SARS-CoV-2", source = "lauer")
    rt_options <- rt_opts(prior = list(mean = 2, sd = 0.2))
    stan_options <- stan_opts(cores = opt$num_chains, samples=opt$num_iterations)
    # setup_logging(threshold = "DEBUG", mirror_to_console = TRUE, file = file.path(opt$results_directory, "epinow2", "output", sprintf("log_%s.txt", area)), name = "EpiNow2")
    # setup_logging(threshold = "DEBUG", mirror_to_console = TRUE, file = file.path(opt$results_directory, "epinow2", "output", sprintf("log_%s.txt", area)), name = "Epinow2.epinow")
    # setup_logging(threshold = "DEBUG", mirror_to_console = TRUE, file = file.path(opt$results_directory, "epinow2", "output", sprintf("log_%s.txt", area)), name = "EpiNow2.epinow.estimate_infections")
    # setup_logging(threshold = "DEBUG", mirror_to_console = TRUE, file = file.path(opt$results_directory, "epinow2", "output", sprintf("log_%s.txt", area)), name = "EpiNow2.epinow.estimate_infections.fit")
    # setup_logging(threshold = "DEBUG", mirror_to_console = TRUE, file = file.path(opt$results_directory, "epinow2", "output", sprintf("log_%s.txt", area)), name = "EpiNow2")

    estimates <- epinow(reported_cases = input_data,
                        generation_time = generation_time,
                        delays = delay_opts(incubation_period, reporting_delay),
                        rt = rt_options,
                        stan = stan_options,
                        horizon = days_forecast,
                        verbose = opt$verbose)

    standata <- rstan::extract(estimates$estimates$fit)
    fitted_r_samples <- standata$R
    fitted_case_samples <- standata$imputed_reports

    write.table(
            fitted_r_samples,
            file = file.path(opt$results_directory, "epinow2", "samples", sprintf("%s_r_samples.txt", area)),
            row.names = FALSE,
            col.names = FALSE
        )

    write.table(
                fitted_case_samples,
                file = file.path(opt$results_directory, "epinow2", "samples", sprintf("%s_case_samples.txt", area)),
                row.names = FALSE,
                col.names = FALSE
            )

    saveRDS(estimates$estimates$fit, file.path(opt$results_directory, "epinow2", "stanfits", sprintf("%s.rds", area)))
}

epinow2_combine = function(opt) {

    print(opt)

    area_date_dataframe <- function(areas,dates,provenance,data,data_names) {
        numareas <- length(areas)
        numdates <- length(dates)
        dates <- rep(dates,numareas)
        dim(dates) <- c(numareas*numdates)
        provenance <- rep(provenance,numareas)
        dim(provenance) <- c(numareas*numdates)
        areas <- rep(areas,numdates)
        dim(areas) <- c(numareas,numdates)
        areas <- t(areas)
        dim(areas) <- c(numareas*numdates)
        df <- data.frame(area=areas,Date=dates,data=data,provenance=provenance)
        colnames(df)[3:(ncol(df)-1)] <- data_names
        df
    }

    cases = read.csv(sprintf('%s/cases.csv',opt$results_directory))
    areas = rownames(read.csv(sprintf('%s/areas.csv',opt$data_directory),row.names=1))
    quoted_areas <- sapply(areas,function(s) paste('"',s,'"',sep=''))
    dates = as.Date(names(cases)[3:ncol(cases)], format="X%Y.%m.%d")

    list[Nstep, Tstep, Tcond, Tlik, Tcur, Tignore] = process_dates_modelled(
        dates,
        first_day_modelled = opt$first_day_modelled,
        last_day_modelled  = opt$last_day_modelled,
        days_ignored       = opt$days_ignored,
        weeks_modelled     = opt$weeks_modelled,
        days_per_step      = opt$days_per_step
    )

    start_date <- dates[Tcond + 1]
    days_modelled = Nstep * Tstep
    end_date <- dates[Tcond + days_modelled]
    days_forecast = Tstep * opt$num_steps_forecasted
    dates_modelled = dates[dates >= start_date & dates <= end_date]
    dates_predicted = seq(end_date,by=1,length.out=days_forecast)
    dates = c(dates_modelled, dates_predicted)

    provenance <- c(rep('inferred',days_modelled),rep('projected',days_forecast))

    N = length(areas)
    Nsample = 1

    ###
    # N = 10
    # areas = areas[1:N]
    # quoted_areas = quoted_areas[1:N]

    percentiles = c(.025,.1,.2,.25,.3,.4,.5,.6,.7,.75,.8,.9,.975)
    str_percentiles = c("2.5%","10%","20%","25%","30%","40%","50%","60%","70%","75%","80%","90%","97.5%")
    num_percentiles = length(percentiles)
    num_samples = opt$num_iterations

    Rt_percentiles = array(NA, c(N, days_modelled + days_forecast, num_percentiles))
    Cpred = array(NA, c(N, days_modelled, num_percentiles))
    Cproj = array(NA, c(N, days_forecast, num_percentiles))

    Xpred = array(NA, c(N, days_modelled, num_percentiles))
    Xproj = array(NA, c(N, days_forecast, num_percentiles))

    for (area_index in 1:N) {
        area <- areas[area_index]
        print(area)

        fit <- readRDS(paste(opt$results_directory, '/epinow2/stanfits/',area,'.rds',sep=''))

        skip <- num_samples / 2 / Nsample
        area_rt = summary(fit, pars = "R", probs=percentiles)$summary
        reports = summary(fit, pars = "reports", probs=percentiles)$summary
        infections = summary(fit, pars = "infections", probs=percentiles)$summary
        # Need to deal with the fact that epinow2 sometimes cuts off days at the start before the first case appears.
        total_days = days_modelled + days_forecast
        missing_days = total_days - dim(area_rt)[1]
        seeding_days = dim(infections)[1] - dim(reports)[1]
        # message("area_rt dims = ",dim(area_rt))
        for (p in 1:num_percentiles) {
            Rt_percentiles[area_index,(missing_days+1):total_days,p] = area_rt[,str_percentiles[p]]
        }

        Cpred[area_index,(missing_days+1):days_modelled,] = reports[1:(days_modelled - missing_days),str_percentiles]
        Cproj[area_index,,] = reports[(days_modelled - missing_days + 1):(total_days - missing_days),str_percentiles]
        Xpred[area_index,(missing_days+1):days_modelled,] = infections[(seeding_days + 1):(seeding_days + days_modelled - missing_days),str_percentiles]
        Xproj[area_index,1:days_forecast,] = infections[(seeding_days + days_modelled - missing_days + 1):(seeding_days + total_days - missing_days),str_percentiles]

    }

    Rt = aperm(Rt_percentiles, c(2,1,3))
    dim(Rt) <- c(N*(days_modelled + days_forecast), num_percentiles)
    Rt <- area_date_dataframe(
        quoted_areas,
        dates,
        provenance,
        format(round(Rt,2),nsmall=2),
        c("Rt_2_5","Rt_10","Rt_20","Rt_25","Rt_30","Rt_40","Rt_50",
        "Rt_60","Rt_70","Rt_75","Rt_80","Rt_90","Rt_97_5")
    )
    write.csv(Rt, paste(opt$results_directory, "/epinow2/Rt.csv", sep=""), quote=FALSE, row.names=FALSE)

    Cpred = aperm(Cpred, c(2,1,3))
    dim(Cpred) <- c(N*days_modelled, num_percentiles)
    Cpred <- area_date_dataframe(
        quoted_areas,
        dates_modelled,
        rep('inferred',days_modelled),
        Cpred,
        c("C_025","C_10","C_20","C_25","C_30","C_40","C_50",
            "C_60", "C_70","C_75","C_80","C_90","C_975")
    )
    write.csv(Cpred, paste(opt$results_directory, "/epinow2/Cpred.csv", sep=""), quote=FALSE, row.names=FALSE)

    Cproj = aperm(Cproj, c(2,1,3))
    dim(Cproj) <- c(N*days_forecast, num_percentiles)
    Cproj <- area_date_dataframe(
        quoted_areas,
        dates_predicted,
        rep('projected',days_forecast),
        Cproj,
        c("C_025","C_10","C_20","C_25","C_30","C_40","C_50",
            "C_60", "C_70","C_75","C_80","C_90","C_975")
    )
    write.csv(Cproj, paste(opt$results_directory, "/epinow2/Cproj.csv", sep=""), quote=FALSE, row.names=FALSE)

    Xpred = aperm(Xpred, c(2,1,3))
    dim(Xpred) <- c(N*days_modelled, num_percentiles)
    Xpred <- area_date_dataframe(
        quoted_areas,
        dates_modelled,
        rep('inferred', days_modelled),
        Xpred,
        c("X_025","X_10","X_20","X_25","X_30","X_40","X_50",
            "X_60", "X_70","X_75","X_80","X_90","X_975")
    )
    write.csv(Xpred, paste(opt$results_directory, "/epinow2/Xpred.csv", sep=""), quote=FALSE, row.names=FALSE)

    Xproj = aperm(Xproj, c(2,1,3))
    dim(Xproj) <- c(N*days_forecast, num_percentiles)
    Xproj <- area_date_dataframe(
        quoted_areas,
        dates_predicted,
        rep('projected',days_forecast),
        Xproj,
        c("X_025","X_10","X_20","X_25","X_30","X_40","X_50",
            "X_60", "X_70","X_75","X_80","X_90","X_975")
    )
    write.csv(Xproj, paste(opt$results_directory, "/epinow2/Xproj.csv", sep=""), quote=FALSE, row.names=FALSE)

}

epinow2_cmdline_options = function(opt = epinow2_options()) {
    list(
    make_option(
        c("--first_day_modelled"),
        type="character",
        default=opt$first_day_modelled,
        help=paste("Date of first day to model; default =",opt$first_day_modelled)
    ),
    make_option(
        c("--weeks_modelled"),
        type="integer",
        default=opt$weeks_modelled,
        help=paste("Number of weeks to model; default =",opt$weeks_modelled)
    ),
    make_option(
        c("--last_day_modelled"),
        type="character",
        default=opt$last_day_modelled,
        help=paste("Date of last day to model; default =",opt$last_day_modelled)
    ),
    make_option(
        c("--days_ignored"),
        type="integer",
        default=opt$days_ignored,
        help=paste("Number of recent days ignored, default",opt$days_ignored)
    ),
    make_option(
        c("--days_per_step"),
        type="integer",
        default=opt$days_per_step,
        help=paste("Days per modelling step, default",opt$days_per_step)
    ),
    make_option(
        c("--days_predicted"),
        type="integer",
        default=opt$days_predicted,
        help=paste("Days predicted; default =",opt$days_predicted)
    ),
    make_option(
        c("--num_steps_forecasted"),
        type="integer",
        default=opt$num_steps_forecasted,
        help=paste("Number of steps to forecast, default",opt$num_steps_forecasted)
    ),
    make_option(
        "--area_index",
        action = "store",
        default = opt$area_index,
        type = "integer",
        help = "Number of the area to model in the cases file"
    ),
    make_option(
        "--num_chains",
        action = "store",
        default = opt$num_chains,
        type = "integer",
        help = "Number of cores to tell stan to use"
    ),
    make_option(
        "--num_iterations",
        action = "store",
        default = opt$num_iterations,
        type = "integer",
        help = "Number of cores to tell stan to use"
    ),
    make_option(
        c("--results_directory"),
        type="character",
        default=opt$results_directory,
        help=paste("Directory to put cleaned results in, default ",opt$results_directory)
    ),
    make_option(
        c("--data_directory"),
        type="character",
        default=opt$data_directory,
        help=paste("Directory to get data from, default ",opt$data_directory)
    ),
    make_option(
        "--verbose",
        action = "store_true",
        default = FALSE,
        type = "logical",
        help = "Whether stan should be verbose"
    )
    )
}

epinow2_get_cmdline_options = function(opt=epinow2_options()) {
  cmdline_opt = epinow2_cmdline_options(opt)
  opt_parser = OptionParser(option_list=cmdline_opt)
  parsed_opt = parse_args(opt_parser)
  for (o in names(parsed_opt)) {
    opt[o] = parsed_opt[o]
  }
  opt
}


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

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

include.assess.forcast.line<-F      # verical line at last assessment year
include.F.reference.points<-F
include.SSB.reference.points<-T
include.1.std<-F                   # Include values plus/minus 1 times the stadndard deviation
include.2.std<-T
incl.sp<-seq(15,23)                      # 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

dirs<-c("T1-T2_stoc_rec_assess_run01", "T1-T2_stoc_rec_assess_run02","T1-T2_stoc_rec_assess_run03")
labels<-c("Run 1 Single sp Fmsy","Run 2 Multi sp Fmsy","Run 3, with TAC constraints")

dirs<-c("T1-T2_stoc_rec_assess_run01_0pctConstraints", "T1-T2_stoc_rec_assess_run01_15pctConstraints","T1-T2_stoc_rec_assess_run01-Icelandic")
labels<-c("Run 1, no constraints","Run 2, +-15% constraints","Run 3, 50-50 constraints")

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

Init.function() # get SMS.contol object  including sp.names

for (dir in dirs) {
 if (plot.MCMC) {
  if (!single.species) {
    file<-file.path(data.path,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(data.path,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(data.path,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")
  FF[FF$std== -1,'std']<-0

  file<-file.path(data.path,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(data.path,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
 }
 if (!single.species) { if (dir==dirs[1]) all<-rbind(rec,FF,ssb,yield,eaten) else all<-rbind(all,rec,FF,ssb,yield,eaten)}
 else {if (dir==dirs[1]) {all<-rbind(rec,FF,ssb,yield)} else all<-rbind(all,rec,FF,ssb,yield)}
 #a$label<-labels[which(dirs==dir)]
 #if (dir==dirs[1]) all2<-a else all2<-rbind(all2,a)
}

head(subset(all,Species.n==1 & scenario=='T1-T2_stoc_rec_assess_run02' & Year>2010 & Year<2020))

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.n,all$Variable),sum)/1000
stds<-  tapply(all$std,  list(all$Year,all$scenario,all$Species.n,all$Variable),sum)/1000

values[,,1,'Yield']

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=="all") sp.plot<-unique(yield$Species.n) else sp.plot<-incl.sp
len.dir<-length(dirs)

  plotvar<-function(sp=sp,vari='SSB',tit=vari,ylab='(1000t)') {
    v<-values[,,as.character(sp),vari]
    s<-stds[,,as.character(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) {
      newplot(dev,nox,noy,filename=paste("com_",run.ID,'_',sp.names[sp],sep=''),Portrait=Portrait);

      # make legends
      if (paper) lwds<-1
      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.names[sp])
      gi<<-gi+1
      par(mar=c(2.5,5,3,1))   # c(bottom, left, top, right)
    }

    gi<<-gi+1

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

    plot(y,v[,1],main=tit,xlab="",ylab=ylab,
          type=typ,lwd=lwds,ylim=c(0,maxval),col=first.color,pch=first.pch)

    for (i in (2:len.dir)) {
      gt0<-sum(v[,i],na.rm=T)>0.01
      if (paper) lwds<-1
      else  lwds<-2;

      if (gt0) lines(y,v[,i],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[,i]+s[,i],lty=2,col=i,lwd=1.5)
       for (i in (1:len.dir)) lines(y,v[,i]-s[,i],lty=3,col=i,lwd=1.5)
    }
     if (include.2.std) {
       for (i in (1:len.dir)) lines(y,v[,i]+2*s[,i],lty=2,col=i,lwd=1.5)
       for (i in (1:len.dir)) lines(y,v[,i]-2*s[,i],lty=3,col=i,lwd=1.5)
    }

    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)
    }
  }

 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 (paper) cleanup()
}


#' fold a lazy stream
#'
#' The order of arguments position is different from that of Haskell's
#'  because it is easy for magrittr's pipe to pass a lazy stream as the first argument.
#' @param x a lazy stream
#' @param f function who must takes two areguments
#' @param init initial value if needed
#' @param g a function that takes one argument and returns lcons or lempty
#' @param f_pred a predicate function for unfold
#' @param f_map a mapping function for unfold
#' @param f_gen a generating function for unfold
#' @name lfold
#' @examples
#' lfoldl(1%..%10, `+`, 0) # => 55
#'
#' lfoldl(1%..%10, function(x,y) paste0("(",x,"+",y,")"), 0)
#' # => "((((((((((0+1)+2)+3)+4)+5)+6)+7)+8)+9)+10)"
#' lfoldr(1%..%10, function(x,y) paste0("(",x,"+",y,")"), 0)
#' # => "(1+(2+(3+(4+(5+(6+(7+(8+(9+(10+0))))))))))"
#' lscanl(1%..%10,`+`, 0) # => llist(0, 1, 3, 6, 10, 15, 21, 28, 36, 45, 55)
#' ## library("magrittr")
#' ## liota() %>% ltake(10) %>% lfoldl1(`+`) # => 45
#'
#' lunfold_haskell(0, function(x) if (x >= 10) lempty else lcons(x, x + 1))
#' lunfoldl(1, function(x) x > 10, function(x) x ^ 2, function(x) x + 1)

NULL

## Reducing lists (folds)
#' @rdname lfold
#' @export
lfoldl <- function(x, f, init) {
  if (lnull(x)) init
  else lfoldl(ltail(x), f, f(init, lhead(x)))
}

#' @rdname lfold
#' @export
lfoldl1 <- function(x, f) {
  if (lnull(x)) stop("x must be non-empty LList")
  else lfoldl(ltail(x), f, lhead(x))
}

#' @rdname lfold
#' @export
lfoldl_dash <- function(x, f, init) {
  if (lnull(x)) init
  else {
    #forceAndCall(3, lfoldl_dash, ltail(x), f, f(init, lhead(x)))
    tmp <- f(init, lhead(x))
    lfoldl_dash(ltail(x), f, tmp)
  }
}

#' @rdname lfold
#' @export
lfoldl1_dash <- function(x, f) {
  if (lnull(x)) stop("x must be non-empty LList")
  else lfoldl_dash(ltail(x), f, lhead(x))
}

#' @rdname lfold
#' @export
lfoldr <- function(x, f, init) {
  if (lnull(x)) init
  else f(lhead(x), lfoldr(ltail(x), f, init))
}

#' @rdname lfold
#' @export
lfoldr1 <- function(x, f) {
  if (lnull(x)) stop("x must be non-empty LList")
  else if (llength(x) == 1) lhead(x)
  else f(lhead(x), lfoldr1(ltail(x), f))
}

## Building lists
#' @rdname lfold
#' @export
lscanl <- function(x, f, init) {
  if (lnull(x)) init %:% lempty
  else init %:% lscanl(ltail(x), f, f(init, lhead(x)))
}
# > lscanl(`+`, 0, 1%..%10)
# list(0, 1, 3, 6, 10, 15, 21, 28, 36, 45, 55)

#' @rdname lfold
#' @export
lscanl1 <- function(x, f) {
  if (lnull(x)) lempty
  else lscanl(ltail(x), f, lhead(x))
}

#' @rdname lfold
#' @export
lscanr <- function(x, f, init) {
  if (lnull(x)) llist(init)
  else {
    tmp <- lscanr(ltail(x), f, init)
    f(lhead(x), lhead(tmp)) %:% tmp
  }
}

#' @rdname lfold
#' @export
lscanr1 <- function(x, f) {
  if (lnull(x)) lempty
  else if (llength(x) == 1) x
  else {
    tmp <- lscanr1(ltail(x), f)
    f(lhead(x), lhead(tmp)) %:% tmp
  }
}

#' @rdname lfold
#' @export
lunfold_haskell <- function(x, g) {
  # g() must return pure lcons object, not llist object
  tmp <- g(x)
  if (lnull(tmp)) lempty
  else lhead(tmp) %:% lunfold_haskell(ltail(tmp), g)
}

#' @rdname lfold
#' @export
lunfoldl <- function(x, f_pred, f_map, f_gen) {
  if (f_pred(x)) lempty
  else f_map(x) %:% lunfoldl(f_gen(x), f_pred, f_map, f_gen)
}

#' @rdname lfold
#' @export
lunfoldr <- function(x, f_pred, f_map, f_gen) {
  iter <- function(x, acc) {
    if (f_pred(x)) acc
    else iter(f_gen(x), lcons(f_map(x), acc))
  }
  iter(x, lempty)
}


#Get site level climate and N-deposition data with associated uncertainties where applicable.
#clear environment, load paths and custom functions.
#ignore the warnings on the N-deposition extraction.
rm(list = ls())
source('paths.r')
source('NEFI_functions/arid_extract.r')
source('NEFI_functions/extract_ndep.r')
source('NEFI_functions/worldclim2_grab.r')
source('NEFI_functions/extract_npp.r')

#Get site level lat-longitude.
d <- readRDS(ITS_site_dates.path)
location <- readRDS(dp1.10086.00_output.path)
sites <- unique(location$siteID)

#within eah site get mean latitude, longitude and elevation.
lat <- aggregate(decimalLatitude  ~ siteID, data = location, FUN = mean)
lon <- aggregate(decimalLongitude ~ siteID, data = location, FUN = mean)
ele <- aggregate(elevation        ~ siteID, data = location, FUN = mean)

#extract climate and uncertainty from worldclim2
climate <- worldclim2_grab(latitude = lat[,2], longitude = lon[,2], elev = ele[,2])
climate$aridity <- arid_extract(lat[,2],lon[,2])
#extract wet, dry and total nitrogen deposition.
ndep    <- extract_ndep(longitude = lon[,2],latitude = lat[,2])
#extract NPP
NPP     <- extract_npp(latitude = lat[,2], longitude = lon[,2])

#wrap up output and save.
output <- cbind(sites,lat[,2],lon[,2],ele[,2],climate,ndep,NPP)
colnames(output)[1:4] <- c('siteID','latitude','longitude','elevation')
saveRDS(output,site_level_data.path)


library(data.table)
library(sf)
library(ggplot2)
library(RColorBrewer)
library(rgdal)

dir.create('figs', showWarnings=F)

dens <- fread('../derived-data/gridded-distribution-by-species.csv')

pops <- fread('../input-data/demographic-parameters-processed.csv')[parameter == 'population_total']
pops <- rbind(pops, pops[species %in% c('DIP', 'DIQ'), .(species = 'ROY', mean=sum(mean))], fill=T)
setkey(pops, species)

spplist <- fread('../input-data/species-list.csv')

grid <- read_sf('../input-data/southern-hemisphere-5-degree.shp')
world <- read_sf('../input-data/world.shp')

w <- as(world, 'Spatial')
wf <- fortify(w)
g <- as(grid, 'Spatial')
gf <- fortify(g)

## * Gridded distributions

gridsp <- as(grid, 'Spatial')
gridsp <- spChFIDs(gridsp, as.character(gridsp$GRID_ID))
gf <- fortify(gridsp, id='GRID_ID')

worldsp <- as(world, 'Spatial')
wf <- fortify(worldsp)

make_map <- function(griddens) {
        gridsp[['density']] <- NA_real_
        gridsp[['density']] <- griddens[
            match(gridsp$GRID_ID, GRID_ID), pops[sp, mean] * density / 1e6]
        gridsp[is.na(gridsp$density), 'density'] <- 0
        gf$density <- gridsp$density[match(gf$id, as.character(gridsp$GRID_ID))]
        brks <- pretty(gridsp$density)

        g <- ggplot() +
            geom_polygon(data = gf, aes(x = long, y = lat, fill = density, group=group),
                         colour = '#CCCCCC', size = 0.1, na.rm=T) +
            geom_polygon(data = wf, aes(x = long, y = lat, group=group),
                         fill = '#AAAAAA', colour = NA, size = 0.1, na.rm=T) +
            scale_fill_gradientn(name = expression(paste("Density\n(birds / km"^2, ")")),
                                 colours = brewer.pal(9, 'BuPu'), na.value=NA, limits = c(0, max(brks)),
                                 trans = 'sqrt', breaks = brks) +
            theme_void() +
            theme(legend.position=c(0.92, 0.85),
                  legend.margin = margin(5, 2, 2, 2, unit='mm'),
                  legend.background=element_rect(fill = '#00000011'),
                  legend.title.align = 0,
                  legend.text.align = 0,
                  legend.key.width = unit(0.5, 'cm')) +
            coord_map("ortho", orientation = c(-90, 178, 0))
        return(g)
}

spp <- dens[, unique(species_code)]
sp=spp[2]
for (sp in spp) {
    cat(sp, '\n')
    griddens <- dens[species_code == sp]
    g <- make_map(griddens)
    ggsave(sprintf('figs/gridded-distribution-%s.png', sp), width = 7, height = 7)
}


#path='/mnt/c/Users/gus5/Desktop/a01_proj/a14_steroid'

library(limma)
library(affy)

#--------------------------------------------------
fd_out<-'./out/b00_de_01_de'
fd_in<-'./out/b00_de_00_pp'

l_de<-list(c('tt_stero', 'sys_stero'),
	      c('sys_stero', 'ctrl'),
     	  c('tt_stero', 'ctrl'))

#-------------------------------------------------
dir.create(fd_out)

##################################################################
for (v_de in l_de)
	{
	name<-paste(v_de[1], v_de[2], sep='__')

	#load desgin
	f_design<-paste(fd_in, name, sep='/')
	f_design<-paste(f_design, '.txt', sep='')
	design<-scan(f_design, what=character(), sep='\n')
	#the reference level which is the first level of the factor
	design<-model.matrix(~factor(design, levels=c(v_de[2], v_de[1])))

	#load exp
	f_in<-paste(fd_in, name, sep='/')
	f_in<-paste(f_in, '.csv', sep='')
	df<-read.csv(f_in, row.names=1)

	#limma
	fit<-lmFit(df, design)
	fit<-eBayes(fit)
	res<-topTable(fit, number=Inf)

	#save
	f_out<-paste(fd_out, name, sep='/')
	f_out<-paste(f_out, '.csv', sep='')
	write.csv(res, f_out)
	}


library(xgboost)
library(magrittr)
library(dplyr)
library(Matrix)
# read data
finalData <- read.csv(file = "./FinalData.csv", sep = ",", header = TRUE, stringsAsFactors = FALSE)
finalData$target_id <- as.character(finalData$target_id)
# keep away training data with class = NA
classNaData <- finalData[which(is.na(finalData$DE)),]
# clear data - keep only ones with meaningful classes
finalData <- finalData[which(!is.na(finalData$DE)),]
# replace NAs with 0
finalData[is.na(finalData)] <- 0
# convert character columns to factors
finalData[sapply(finalData, is.character)] <- lapply(finalData[sapply(finalData, is.character)],as.factor)
# remove factors with too many levels
finalData <- finalData[, which(lapply(X = finalData, FUN = nlevels) < 50)]
# convert boolean DE column to factor
finalData$DE <- as.factor(finalData$DE)
# class imbalance problem
hist(as.numeric(finalData$DE) - 1, col = 'blue', main = 'Class Imbalance', xlab = 'FALSE = 0 \t TRUE = 1', ylim = c(0,length(finalData$DE)))
# set seed
set.seed(123)
# shuffle data
finalData <- finalData[sample(nrow(finalData)),]
# enconding
label <- ifelse(test = finalData[,'DE'] == TRUE, yes = 1, no = 0)
n = nrow(finalData)
#XGBoost Model Parameters
constant_params <- list(booster = 'gbtree',
                        silent = 0,
                        objective = 'binary:logistic',
                        eval_metric = 'error',
                        gamma = 0,
                        early.stop.round = 50
)
tunable_params_grid <- expand.grid(eta = (1:6)*0.05,
                                   nrounds = (1:6)*150,
                                   max_depth = c(4:9),
                                   subsample = c(0.6:1),
                                   colsample_bytree = c(0.5,0.8,1)
)
colnames(tunable_params_grid) <- c("eta", "nrounds", "max_depth", "subsample", "colsample_bytree")
currParams <- tunable_params_grid[sample(nrow(tunable_params_grid), size = 1), ] #sample random combination and train the trees
numModels <- 20; #increase
time.taken <- data.frame(n = numeric(), time.t = numeric())
# measure time while decreasing training set
for (i in 1:numModels){
  print(paste0("building model", i))
  train.index = sample(n, 0.99*n)
  train.data = as.matrix(sapply(finalData[train.index,-ncol(finalData)], as.numeric))
  train.label = label[train.index]
  test.data = as.matrix(sapply(finalData[-train.index,-ncol(finalData)], as.numeric))
  test.label = label[-train.index]
  trainm = xgb.DMatrix(data=train.data,label=train.label)
  testm = xgb.DMatrix(data=test.data,label=test.label)
  test.label <- as.factor(ifelse(test = test.label == 1, yes = TRUE, no = FALSE))
  start.t <- Sys.time()
  # Train Model
  xgbModel <- xgb.train(params = constant_params,
                        eta = currParams$eta,
                        nrounds = currParams$nrounds,
                        max_depth = currParams$max_depth,
                        subsample = currParams$subsample,
                        colsample_bytree = currParams$colsample_bytree,
                        data = trainm,
                        verbose = 0)
  end.t <- Sys.time()
  time.taken[i,1] <- length(train.index)
  time.taken[i,2] <- end.t - start.t
  # Predict
  xgb.pred <- predict(xgbModel, test.data)
  xgb.pred <- as.data.frame(xgb.pred)
  pred.class <- ifelse(test = xgb.pred > 0.5, yes = TRUE, no = FALSE)
  # Evaluate model
  confusionMatrix(data = as.factor(pred.class), reference = test.label, positive = 'TRUE')
  # accuracy
  acc <- Accuracy(y_pred = pred.class, y_true = test.label)
  pred_obj = prediction(xgb.pred, test.label, label.ordering = c("FALSE", "TRUE"))
  # auc
  areauc <- performance(prediction.obj = pred_obj, measure = "auc")@y.values
  # f1score
  f1 <- F1_Score(y_true = test.label, y_pred = pred.class, positive = 'TRUE')
  n <- n - 150
}
saveRDS(object = time.taken, file = "./test/xgbDecTrainData.rds")


## Calculate timeseries stats, moving across timeseries to detect changepoint in experiment 2
## Launch model

library(doParallel)
library(foreach)
library(iterators)
library(dplyr)
library(zoo)

source("summary_functions.R")

registerDoParallel(cores=4)

calc_stats=function(wd,run,count_dead=TRUE){
  print(run)
  data_frame=read.csv(paste0(wd,run,"/sim_list.csv"))

  FD_frame=data.frame(ID=0,year=0,SPLIT_YEAR = 0,FD_RealSeries=0,FD_CensusSeries=0,FD_T_500=0,FD_T_250=0,FD_T_100=0,FD_T_50=0,FD_T_25=0,FD_T_10=0,FD_R_500=0,FD_R_250=0,FD_R_100=0,FD_R_50=0,FD_R_25=0,FD_R_10=0)
  AB_frame=data.frame(ID=0,year=0,SPLIT_YEAR = 0,AB_RealSeries=0,AB_CensusSeries=0,AB_T_500=0,AB_T_250=0,AB_T_100=0,AB_T_50=0,AB_T_25=0,AB_T_10=0,AB_R_500=0,AB_R_250=0,AB_R_100=0,AB_R_50=0,AB_R_25=0,AB_R_10=0)

  for(idx in 1:dim(data_frame)[1]){
    print(paste0("__",idx))
    print(idx)

    aa=load(paste0(wd,run,"/fire_record_",idx,".Rdata"),env=environment())
    this_tree=read.csv(paste0(wd,run,"/tree_frame_",idx,".csv"))

    if(!count_dead){
      this_tree=subset(this_tree,STATUS==0)
    }

    ## Real count of fires per decade.

    field_size=dim(this_fire)[1] * dim(this_fire)[2]
    fc=apply(this_fire,MARGIN=3,FUN=sum)
    fc=fc>0
    g=rollapply(fc,10,sum)

    ###
    FD_RealSeries=g
    FD_CensusSeries=rollapply(f_tree_tsyear(this_tree,this_fire)$scars>0,10,sum)
    ###

    # Shuffle this_tree so the ordered trees have a random subset within them, or else all the dead ones will be at the bottom
    this_tree$shuffler=sample(dim(this_tree)[1])

    ## Calculate a summary of the number of scars per tree, for filtering
    this_tree=group_by(this_tree,ID)

    scar_count=summarise(this_tree,count=length(YBP),MFI=f_tree_MFIhelper(YBP),shuffler=first(shuffler))
    scar_count=arrange(scar_count,desc(count),shuffler)
    scar_count=as.data.frame(scar_count)
    scar_count=subset(scar_count,is.finite(scar_count$MFI))

    this_tree=as.data.frame(this_tree)

    ## Targeted subsets
    FD_T_500 = rollapply(f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:500,]$ID),this_fire)$scars>0,10,sum)
    FD_T_250 = rollapply(f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:250,]$ID),this_fire)$scars>0,10,sum)
    FD_T_100 = rollapply(f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:100,]$ID),this_fire)$scars>0,10,sum)
    FD_T_50 = rollapply(f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:50,]$ID),this_fire)$scars>0,10,sum)
    FD_T_25 = rollapply(f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:25,]$ID),this_fire)$scars>0,10,sum)
    FD_T_10 = rollapply(f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:10,]$ID),this_fire)$scars>0,10,sum)

    ## Random subsets
    FD_R_500 = rollapply(f_tree_tsyear(this_tree[sample(dim(this_tree)[1],500),],this_fire)$scars>0,10,sum)
    FD_R_250 = rollapply(f_tree_tsyear(this_tree[sample(dim(this_tree)[1],250),],this_fire)$scars>0,10,sum)
    FD_R_100 = rollapply(f_tree_tsyear(this_tree[sample(dim(this_tree)[1],100),],this_fire)$scars>0,10,sum)
    FD_R_50 = rollapply(f_tree_tsyear(this_tree[sample(dim(this_tree)[1],50),],this_fire)$scars>0,10,sum)
    FD_R_25 = rollapply(f_tree_tsyear(this_tree[sample(dim(this_tree)[1],25),],this_fire)$scars>0,10,sum)
    FD_R_10 = rollapply(f_tree_tsyear(this_tree[sample(dim(this_tree)[1],10),],this_fire)$scars>0,10,sum)

    ################### Now area burnt

    field_size=dim(this_fire)[1] * dim(this_fire)[2]
    fc=apply(this_fire,MARGIN=3,FUN=sum)
    g=fc/field_size

    ###
    AB_RealSeries=g
    AB_CensusSeries=f_tree_tsyear(this_tree,this_fire)$perc
    ###

    AB_T_500 = f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:500,]$ID),this_fire)$perc
    AB_T_250 = f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:250,]$ID),this_fire)$perc
    AB_T_100 = f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:100,]$ID),this_fire)$perc
    AB_T_50 = f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:50,]$ID),this_fire)$perc
    AB_T_25 = f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:25,]$ID),this_fire)$perc
    AB_T_10 = f_tree_tsyear(subset(this_tree,this_tree$ID %in% scar_count[1:10,]$ID),this_fire)$perc

    ## Random subsets
    AB_R_500 = f_tree_tsyear(this_tree[sample(dim(this_tree)[1],500),],this_fire)$perc
    AB_R_250 = f_tree_tsyear(this_tree[sample(dim(this_tree)[1],250),],this_fire)$perc
    AB_R_100 = f_tree_tsyear(this_tree[sample(dim(this_tree)[1],100),],this_fire)$perc
    AB_R_50 = f_tree_tsyear(this_tree[sample(dim(this_tree)[1],50),],this_fire)$perc
    AB_R_25 = f_tree_tsyear(this_tree[sample(dim(this_tree)[1],25),],this_fire)$perc
    AB_R_10 = f_tree_tsyear(this_tree[sample(dim(this_tree)[1],10),],this_fire)$perc

    ## bind it

    t_FD=data.frame(ID=rep(idx,length(FD_RealSeries)),year=seq_along(FD_RealSeries),SPLIT_YEAR=rep(data_frame$SPLIT_YEAR[idx],length(FD_RealSeries)),FD_RealSeries,FD_CensusSeries,FD_T_500,FD_T_250,FD_T_100,FD_T_50,FD_T_25,FD_T_10,FD_R_500,FD_R_250,FD_R_100,FD_R_50,FD_R_25,FD_R_10)
    t_AB=data.frame(ID=rep(idx,length(AB_RealSeries)),year=seq_along(AB_RealSeries),SPLIT_YEAR=rep(data_frame$SPLIT_YEAR[idx],length(AB_RealSeries)),AB_RealSeries,AB_CensusSeries,AB_T_500,AB_T_250,AB_T_100,AB_T_50,AB_T_25,AB_T_10,AB_R_500,AB_R_250,AB_R_100,AB_R_50,AB_R_25,AB_R_10)

    FD_frame=rbind(FD_frame,t_FD)
    AB_frame=rbind(AB_frame,t_AB)
  }

  FD_frame=subset(FD_frame,ID>0)
  AB_frame=subset(AB_frame,ID>0)

  write.csv(FD_frame,paste0(wd,run,"/FD_timeseries_",count_dead,".csv"))
  write.csv(AB_frame,paste0(wd,run,"/AB_timeseries_",count_dead,".csv"))
}

# Do the narrow/wide
td_vec=c("e2_range_narrow","e2_range_wide")
foreach(i=iter(td_vec),.packages=c("dplyr","zoo")) %dopar% calc_stats(working_dir,i)

#for(i in td_vec){
#  print(i)
#  calc_stats(working_dir,i)
#}


#Here, we add interactivity to the plot. In the sidebarPanel in the ui.R, we add a sliderInput widget, which allows the user to (a) select a value from the ui interface, which is then (b) fed to the server script. The server script then (c) readjusts the plot with the new input value and (d) feeds the output plot to the ui interface.

library(shiny)	#First load shiny library
load("../pcas.RDATA")	#Load data

#Define a server for the Shiny app
shinyServer(function(input, output) {

	#Create a reactive Shiny plot to send to the ui.r called "pcaplot"
	output$pcaplot <- renderPlot({
		#Render the scatterplot of PCA
		plot(PC2~PC1, data=foo, type="n", xlab="PC1", ylab="PC2")
		text(PC2~PC1, data=foo, labels=foo$metric, cex=input$cexSlider)
  })
})

#TASKS:
#1. The PCA plot (pcaplot) currently is showing all the values, disregarding the different variables (Var: colless, lambdaE, lambdaR, Landscape, Numsp, Repulsion, Spatial). We however would like to show the PCA plot for each variable scenario.
#To do so:
#	a. Complete Task 3 in ui.r to create the selectInput drop-down menu, which we will call 'var'
#	b. subset the foo dataframe for only instances when foo$Var==input$var

#HINTS
#1. output$pcaplot <- renderPlot({
#		#Subset for input$var and assign this subset to new object, "fbar"
#		fbar<-droplevels(foo[which(foo$Var==input$var),])
#
#		#Change "foo" to "fbar" for the plot and text
#		plot(PC2 ~ PC1, data=fbar, type="n", xlab="PC1", ylab="PC2")
#		text(PC2 ~ PC1, data=fbar, labels=fbar$metric, cex=input$cexSlider)
#  })


require(ggplot2)
require(reshape2)
require(foreach)

pdfPlot <- function(p, filename, width=6, height=4, units="in") {
  ggsave(filename, p, width=width, height=height, units=units)
}

# Dense matrix comparison.
numElements <- c(1e2, 1e3, 1e4, 1e5, 2.5e6, 1e6, 5e6, 7.5e6, 1e7, 1e8)
rowSizes <- round(sqrt(numElements))
colSizes <- rowSizes

res <- vector(mode="character", length=length(rowSizes))
for (i in 1:length(rowSizes)) {
  res[i] <- system(paste("scipy_bench -m", rowSizes[i], "-n", colSizes[i],
    "--nu 10 --csv"), intern=TRUE)
}

denseTiming <- as.data.frame(cbind(numElements,
  matrix(as.numeric(unlist(strsplit(res, ","))), ncol=3, byrow=TRUE)))

names(denseTiming) <- c("Elements", "IRLB", "SVD", "Abs.Error")
denseTiming <- denseTiming[,-4]

denseTiming <- melt(denseTiming, id=c("Elements"))
names(denseTiming) <- c("Elements", "Algorithm", "Seconds")
p <- qplot(Elements, Seconds, data=denseTiming, color=Algorithm, geom="line",
  size=I(1))
pdfPlot(p, "DenseMatrixComparison.pdf")

# Dense matrix scaling in the number of singular vectors.
numElements <- c(1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9)
rowSizes <- round(sqrt(numElements))
colSizes <- rowSizes
numVec <- c(1, 5, 10, 15, 20)
nuTiming <- foreach (i=1:length(rowSizes), .combine=rbind) %do% {
  foreach (nu=numVec, .combine=c) %do% {
    as.numeric(system(paste("scipy_bench -m", rowSizes[i], "-n",
      colSizes[i], "--nu", nu, "--csv --irlb-only"), intern=TRUE))
  }
}
nuTiming <- as.data.frame( cbind(numElements, nuTiming) )
names(nuTiming) <- c("Elements", as.character(numVec))
nuTiming <- melt(nuTiming, id="Elements")
names(nuTiming) <- c("Elements", "nu", "Seconds")
p <- qplot(Elements, Seconds, data=nuTiming, color=nu, geom="line", size=I(1))
pdfPlot(p, "DenseMatrixNuScaling.pdf")

# Sparse matrix scaling in the number of singular values with 95%
# sparsity.
numElements <- c(1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9)
rowSizes <- round(sqrt(numElements))
colSizes <- rowSizes
numVec <- c(1, 5, 10, 15, 20)
nuTiming <- foreach (i=1:length(rowSizes), .combine=rbind) %do% {
  foreach (nu=numVec, .combine=c) %do% {
    as.numeric(system(paste("scipy_bench -m", rowSizes[i], "-n",
      colSizes[i], "--nu", nu, "--csv --irlb-only -s 0.99"), intern=TRUE))
  }
}
nuTiming <- as.data.frame( cbind(numElements, nuTiming) )
names(nuTiming) <- c("Elements", as.character(numVec))
nuTiming <- melt(nuTiming, id="Elements")
names(nuTiming) <- c("Elements", "nu", "Seconds")
p <- qplot(Elements, Seconds, data=nuTiming, color=nu, geom="line", size=I(1))
pdfPlot(p, "SparseMatrixNuScaling.pdf")


# To analyze and process the output tosmaxday.rdata
# Run after climatology_OISST_maxday.r

################
# Reshape
# To run on laptop
###############
load('temp/tosmaxday.rdata')

# reorder dimensions
tosmaxday <- aperm(tosmaxday, c(2,1))

# rotate sst monthly temps 1986-2005 so columns 0 -> 360 lon (centered at Greenwich), rows 90 -> -90 lat (like cmip5)
nms <- dimnames(tosmaxday)
lons <- as.numeric(nms[[2]])
newlonord <- c(lons[lons>0], lons[lons<0])
newcolnms <- newlonord
newcolnms[newcolnms<0] <- newcolnms[newcolnms<0] + 360
newlonord <- as.character(newlonord)
newcolnms <- as.character(newcolnms)

lats <- as.numeric(nms[[1]])
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

tosmaxday <- tosmaxday[newlatord, newlonord] # lat x lon (0-360)
dimnames(tosmaxday)[[2]] <- newcolnms

	image(tosmaxday)

save(tosmaxday, file='temp/tosmaxday.rdata')

#############
# Plot
#############
load('temp/tosmaxday.rdata')

image(tosmaxday)

###########################
# Compare warmest day to warmest month
###########################
require(raster)

load('temp/tosmax.rdata')
load('temp/tosmaxday.rdata')

range(tosmaxday - tosmax, na.rm=TRUE)
summary(as.numeric(tosmaxday - tosmax))
sum(as.numeric(tosmaxday - tosmax) < 0, na.rm=TRUE)/sum(!is.na(as.numeric(tosmaxday - tosmax)))

rast <- raster(tosmaxday - tosmax, xmn=0, xmx=360, ymn=-90, ymx=90)
plot(rast)

# show values < 0
rast2 <- raster((tosmaxday - tosmax)<0, xmn=0, xmx=360, ymn=-90, ymx=90)
plot(rast2)