library(tidytext)
library(jcolors)
library(openxlsx)
library(ggplot2)
require(gridExtra)
library(grid)
library(tidyverse)
library(tidytext)
library(ggrepel)

final.CS.tab <- read.xlsx("../Input/coldShock/bulk_tc/babesia_ColdSchock_new_logCPM_logFC_qval_edgeR_V4.xlsx")

sync.vs.bulk.fc <- final.CS.tab %>%
  select(GeneName, Sync4C.2.vs.tc.6_log_fc, Sync4C.4.vs.tc.8_log_fc, Sync4C.6.vs.tc.10_log_fc)

sync.vs.bulk.fc.lng <-sync.vs.bulk.fc %>%
  pivot_longer(-GeneName, names_to = "contrast", values_to = "log_fc")
sync.vs.bulk.fc.lng$contrast <- gsub("_log_fc", "", sync.vs.bulk.fc.lng$contrast)

sync.vs.bulk.qval <- final.CS.tab %>% select(GeneName, Sync4C.2.vs.tc.6_qval,  Sync4C.4.vs.tc.8_qval, Sync4C.6.vs.tc.10_qval)
sync.vs.bulk.qval.lng <- sync.vs.bulk.qval %>% pivot_longer(-GeneName, names_to = "contrast", values_to = "qval")
sync.vs.bulk.qval.lng$contrast <- gsub("_qval", "", sync.vs.bulk.qval.lng$contrast)

sync.vs.bulk.df <- inner_join(sync.vs.bulk.fc.lng, sync.vs.bulk.qval.lng, by = c("GeneName", "contrast"))

sync.vs.bulk.df <- sync.vs.bulk.df %>% mutate(sig = ifelse(abs(log_fc) > 0.58 & qval < 0.05, "yes", "no"))

prod.desc <- read.csv('../Input/coldShock/genes/BDiv_Prod_desc.csv')
prod.desc <- prod.desc %>% transmute(GeneID = Gene.ID, ProductDescriptionBdiv = Product.Description) %>% distinct()
sync.vs.bulk.prod.desc <- inner_join(sync.vs.bulk.df, prod.desc, by = c("GeneName" = "GeneID"))

#write.xlsx(sync.vs.bulk.prod.desc, "../output/ColdShock/cold_vs_hot.xlsx")

toxo.bdiv.orth <- read.xlsx('../Input/coldShock/Orthologs/GT1_BDiv.xlsx')
colnames(toxo.bdiv.orth) <- c('GeneID_Toxo', 'GeneID', 'ProductDescriptionToxo')

######### volcano plot #########

volc.df <- sync.vs.bulk.df
volc.df$contrast <- gsub("Sync4C.2.vs.tc.6", "2hr",
                         gsub("Sync4C.4.vs.tc.8", "4hr", gsub("Sync4C.6.vs.tc.10", "6hr", volc.df$contrast)))
volc.df$geneLable <- ''
show.lab <- c('Bdiv_000320c', 'Bdiv_023990c', 'Bdiv_036750c', 'Bdiv_031010c')
# volc.df <- volc.df %>% group_by(contrast) %>%
#   mutate(GeneLable = ifelse(-log(qval) > 20  & abs(log_fc) > 1.7 , "True", "False"))
volc.df <- volc.df %>% group_by(contrast) %>%
  mutate(GeneLable = ifelse(GeneName %in%  show.lab, "True", "False"))

volc.df$Name <- gsub("Bdiv_", "", volc.df$GeneName)
volc.df$Name <- volc.df$GeneName

# remooving some random genes to make some space and (nicer plot)
# more genes to be removed?
volc.df$Name <- gsub("009180", "",
                     gsub("021910", "",
                          gsub("013880c", "",
                               gsub("006490c", "",
                                    gsub("010240c", "", volc.df$Name)))))

p <- ggplot(volc.df) + geom_point(aes(log_fc, -log(qval),color=sig))+
  geom_text_repel(aes(log_fc, -log(qval)), size = 5, fontface = "bold",
                  label = ifelse(volc.df$GeneLable == "True", as.character(volc.df$Name),""),
                  box.padding = unit(0.45, "lines"),
                  hjust=1,
                  segment.angle = 180,
                  nudge_x = -1,
                  nudge_y = 1,
                  segment.size = 0.4) +
  theme(legend.title=element_blank(),text = element_text(size=20))+
  scale_color_manual(values = c("yes" = "red", "no" = "black"))+
  facet_grid(. ~ contrast,  scales = "fixed",  space='free',
             labeller=label_wrap_gen(multi_line = TRUE)) +
  theme_bw()+
  theme(
    #plot.title = element_text(size=14, face = "bold.italic", color = 'red'),
    #legend.text = element_text(size = 18, face = "bold"),
    axis.text.x = element_text(size = 18, angle = 90, vjust = 0.45, color = "black"),
    axis.text.y = element_text(size = 18, color = "black"),
    axis.title = element_text(size = 20, color = "black", face = "bold"),
    strip.text = element_text(color = "black", size = 18, face = "bold"),
    strip.background = element_rect(fill = "white"))+
  theme(legend.title = element_text(size = 16, face = "bold"),
        legend.text = element_text(size = 14, face = "bold"),
        legend.position = "none") +
  xlab("log2 FC")

p

ggsave(filename="../Output/coldShock/figs/volcano.pdf",
       plot=p,
       width = 10, height = 4,
       units = "in", # other options are "in", "cm", "mm"
       dpi = 300
)

toxo.bdiv.orth <- read.xlsx('~/work/ToxoPlasmaGondiiR/Input/compScBabesia/Orthologs/GT1_BDiv.xlsx')
colnames(toxo.bdiv.orth) <- c('GeneID_Toxo', 'GeneID', 'ProductDescriptionToxo')

sync.vs.bulk.filt <-  sync.vs.bulk.df %>%
  filter(abs(log_fc) > 0.58 & qval < 0.05) %>% select(GeneName, contrast, log_fc)
sync.vs.bulk.filt <- sync.vs.bulk.filt %>% mutate(direction = ifelse(log_fc > 0 , "up", "down"))
sync.vs.bulk.filt$contrast <- gsub("Sync4C.2.vs.tc.6", "2hr",
                                   gsub("Sync4C.4.vs.tc.8", "4hr",
                                        gsub("Sync4C.6.vs.tc.10", "6hr", sync.vs.bulk.filt$contrast)))

sync.vs.bulk.filt.orth <- inner_join(sync.vs.bulk.filt, toxo.bdiv.orth, by = c("GeneName" = "GeneID"))
sync.vs.bulk.filt.orth.stat <- sync.vs.bulk.filt.orth %>%
  group_by(contrast,  direction) %>% summarise(genes = list(GeneID_Toxo), num.degs = n())

#write.xlsx(sync.vs.bulk.filt.orth.stat, "../output/ColdShock/CS_vs_TC_DEGs_orth_stat.xlsx")

## GO trm
in.dir <- '../output/ColdShock/GO/'
all.files <- list.files(in.dir)

all.clust.items <- list()
for(f in all.files){
  nn <- gsub('\\.tsv', '', f)
  GF <- strsplit(nn, split = '_')[[1]][1]
  phase <- strsplit(nn, split = '_')[[1]][2]
  tmp <- read_tsv(paste(in.dir, f, sep = ''))
  tmp$GF <- GF
  tmp$phase <- phase
  all.clust.items <- c(all.clust.items, list(tmp))
}

all.clust.items <- do.call(rbind, all.clust.items)
names(all.clust.items) <- gsub(" ", ".", gsub("phase", "Sample", names(all.clust.items)))

#saveRDS(all.clust.items, '../Input/compScBabesia/RData/GO_Conserved_Markers_TGGT1.RData')
filtered.Go <- all.clust.items %>% arrange(Sample, Benjamini) %>% distinct() %>%
  group_by(Sample) %>% mutate(rank = row_number()) %>%
  dplyr::filter(Benjamini < 0.1 & rank < 40 & Bgd.count > 10) %>%
  arrange(Sample, Benjamini)

names(filtered.Go)

GO <- filtered.Go %>%
  mutate(Result.gene.list = strsplit(as.character(Result.gene.list), ",")) %>%
  unnest(Result.gene.list)
toxo.bdiv.orth <- read.xlsx('~/work/ToxoPlasmaGondiiR/Input/compScBabesia/Orthologs/GT1_BDiv.xlsx')
GO <- inner_join(toxo.bdiv.orth, GO , by = c("GT1" = "Result.gene.list"))
GO.df <- GO %>% group_by(ID, Name, GF, Sample) %>% summarise(Bdiv_ID = list(BDiv), Toxo_ID = list(GT1), total = n())
GO.final <- left_join(GO.df , filtered.Go,  by = c("ID", "Name", "GF", "Sample"))

write.xlsx(GO.final, "../output/ColdShock/filtered_GO_term.xlsx")

############# bar plot ##########
sync.vs.tc.stat  <- sync.vs.bulk.filt %>% mutate(direction = ifelse(log_fc > 0 , "up", "down"))

stats.deg <- sync.vs.tc.stat %>% group_by(contrast, direction) %>%
  summarise(Genes = list(GeneName), total = n()) %>% group_by(contrast) %>%
  mutate(ylab_pos = total - 2)

stats.deg$contrast <- gsub("Sync4C.2.vs.tc.6", "2hr",
                           gsub("Sync4C.4.vs.tc.8", "4hr", gsub("Sync4C.6.vs.tc.10", "6hr", stats.deg$contrast)))

stats.deg$contrast <- factor(stats.deg$contrast, levels = c('2hr', '4hr', '6hr'))

stats.deg$direction <- factor(stats.deg$direction, levels = c('up', 'down'))
stats.deg$label <- stats.deg$total

p <- ggplot(stats.deg, aes(fill=direction, y=total, x=contrast)) +
  geom_bar(stat="identity", position=position_dodge()) +
  geom_text(aes(label=label, group = direction),
            position = position_dodge(width = 0.9), vjust=0,
            color="black", size=7, fontface = 'bold') +
  theme_minimal() + xlab('') +
  theme(
    axis.text = element_text(size=18, face="bold", color = 'black'),
    plot.title = element_text(size=18, face = "bold.italic", color = 'black'),
    axis.title.x = element_text(size=18, face="bold"),
    axis.title.y = element_text(size=18, face="bold")
  ) +
  theme(#legend.position="top",
    legend.position = c(0.13, 0.83),
    legend.title=element_text(size=18, face="bold"),
    legend.text=element_text(size=18, face="bold"))

plot(p)

ggsave(filename="../output/ColdShock/bar_plots_cs.png",
       plot=p,
       width = 8, height = 8,
       units = "in", # other options are "in", "cm", "mm"
       dpi = 300
)

sync.vs.tc  <- sync.vs.bulk.filt %>% mutate(direction = ifelse(log_fc > 0 , "up", "down"))
sync.vs.tc$Category <- paste( sync.vs.tc$direction , sync.vs.tc$contrast, sep = "_")

## up eg
sync.vs.tc.up <- sync.vs.tc %>% filter(direction == "up")
sync.vs.tc.up <- split(sync.vs.tc.up , f = sync.vs.tc.up$Category)

sync.vs.tc.up.list <- list()
for(i in 1:length(sync.vs.tc.up)){
  categ <- names(sync.vs.tc.up)[i]
  genes <- sync.vs.tc.up[[categ]]$GeneName
  sync.vs.tc.up.list <- c(sync.vs.tc.up.list, list(genes))
}
names(sync.vs.tc.up.list) <- names(sync.vs.tc.up)

up.comm.genes  <- Reduce(intersect, sync.vs.tc.up.list)

p.up <- ggVennDiagram(sync.vs.tc.up.list,
                      category.names = c("2 hr"," 4 hr","6 hr"),
                      set_size = 8, label_size = 6,
                      lwd = 0.8, lty = 1, label_alpha = 0.7, edge_size = 1) +
  #scale_fill_gradient(low = "#F4FAFE", high = "#4981BF")
  ggtitle("up-regulated") +
  theme(plot.title = element_text(hjust = 0.5, face = "bold", size = 18)) +
  theme(legend.position = "none")+
  theme(legend.text = element_text(size = 14, face = 'bold'),
        legend.title = element_text(size = 16,  face = "bold"))

p.up

# down reg
sync.vs.tc.down <- sync.vs.tc %>% filter(direction == "down")
sync.vs.tc.down <- split(sync.vs.tc.down , f = sync.vs.tc.down$Category)

sync.vs.tc.down.list <- list()

for(i in 1:length(sync.vs.tc.down)){

  categ <- names(sync.vs.tc.down)[i]
  genes <- sync.vs.tc.down[[categ]]$GeneName

  sync.vs.tc.down.list <- c(sync.vs.tc.down.list, list(genes))

}
names(sync.vs.tc.down.list) <- names(sync.vs.tc.down)

p.down <- ggVennDiagram(sync.vs.tc.down.list,
                        category.names = c("2 hr"," 4 hr","6 hr"),
                        set_size = 8,label_size = 6,
                        lwd = 0.8, lty = 1, label_alpha = 0.7, edge_size = 1) +
  #scale_fill_gradient(low = "#F4FAFE", high = "#4981BF")
  ggtitle("down-regulated") +
  theme(plot.title = element_text(hjust = 0.5, face = "bold", size = 18)) +
  theme(legend.position = "none")+
  theme(legend.text = element_text(size = 14, face = 'bold'),
        legend.title = element_text(size = 16,  face = "bold"))

p.down

p <- grid.arrange(p.up, p.down, ncol = 2)

ggsave(filename="../output/ColdShock/figures/venn_up_down.png",
       plot=p,
       width = 12, height = 12,
       units = "in", # other options are "in", "cm", "mm"
       dpi = 300
)


create.andrews.bakulski.reference <- function(verbose=T) {
    source("http://bioconductor.org/biocLite.R")
    if (!require("FlowSorted.CordBlood.450k"))
        biocLite("FlowSorted.CordBlood.450k")
    if (!require("minfi"))
        biocLite("minfi")
    require("minfi")
    require("FlowSorted.CordBlood.450k")
    data("FlowSorted.CordBlood.450k")

    ## code from minfi::preprocessFunnorm
    ## (could not just use that function because Meth/Unmeth
    ## signals not retained and we need them here to create the cell type
    ## reference)
    reference <- preprocessNoob(FlowSorted.CordBlood.450k)
    reference <- mapToGenome(reference)
    extracted.data <- minfi:::.extractFromRGSet450k(FlowSorted.CordBlood.450k)
    samplesheet <- colData(FlowSorted.CordBlood.450k) ## pData(phenoData(FlowSorted.CordBlood.450k))
    sex <- sign(samplesheet$Sex == "F") + 1
    reference <- minfi:::.normalizeFunnorm450k(object=reference, extractedData=extracted.data,
                                               sex=sex, nPCs=10, verbose=F)
    M <- getMeth(reference)
    U <- getUnmeth(reference)
    cell.types <- c("Bcell", "CD4T", "CD8T", "Gran", "Mono", "NK", "nRBC")
    selected <- samplesheet$CellType %in% cell.types
    meffil.add.cell.type.reference("andrews and bakulski cord blood",
                                   M[,selected], U[,selected],
                                   cell.types=samplesheet$CellType[selected],
                                   chip="450k",
                                   featureset="common",
                                   verbose=verbose)
}


##' Plot figure 4
##'
##' @return plot
##' @importFrom dplyr filter group_by summarise ungroup left_join mutate select
##' @importFrom lubridate year
##' @importFrom ggplot2 ggplot aes geom_jitter geom_smooth xlab ylab
##' @importFrom cowplot theme_cowplot plot_grid
##' @author Sebastian Funk
##' @export
figure4 <- function()
{
    df <- gather_2015_data() %>%
        mutate(incidence=cases/population)

    p1 <- ggplot(df, aes(x=mean_coverage, incidence * 1000)) +
        geom_jitter() +
        geom_smooth(method="lm") +
        xlab("EPI vaccination coverage 2010-15") +
        ylab("Incidence in 2015 (per 1000)") +
        theme_cowplot()

    p2 <- ggplot(df, aes(x=coverage_estimate, incidence * 1000)) +
        geom_jitter() +
        geom_smooth(method="lm") +
        xlab("Estimated vaccination coverage") +
        ylab("Incidence in 2015 (per 1000)") +
        theme_cowplot()

    pg <- plot_grid(p1, p2, labels=c("A", "B"), ncol=2)

    return(pg)
}


library(ggplot2)
library(scales)
library(dplyr)

source("shared/stat_tests.r")

load_promoter_elements <- function(file="promoter_elements/pe.0mm.RData") {
  get(load(file))
}

oob_function<-function(x,range){x}

promoter_element_enrichments <- function(tx_groups, tx_universe=c()) {

  txs.df <- flybase_txs()

  if(length(tx_universe) == 0) {
    tx_universe <- txs.df$fb_tx_id
  } else {
    txs.df <- subset(txs.df, fb_tx_id %in% tx_universe)
  }

  txs.df <- transform(txs.df, tss = ifelse(strand == 1, start, end))
  txs.df <- transform(txs.df, tx_id = paste(chr, tss, strand, sep="_"))[, c("fb_tx_id", "tx_id")]

  pe.df <- merge(txs.df, load_promoter_elements())
  pe.df$fb_tx_id <- NULL
  elements <- names(pe.df)[-1]

  results.df <- names(tx_groups) %>%
    lapply(function(group_name) {
      group_txs <- tx_groups[[group_name]]
      group_ids <- unique(subset(txs.df, fb_tx_id %in% group_txs)$tx_id)

      group.df <- elements %>%
        lapply(function(element) {
          element_ids <- pe.df$tx_id[pe.df[, which(names(pe.df) == element)] == TRUE]

          element_ftest <- fisher_test_2x2(group_ids, element_ids, unique(pe.df$tx_id))
          element_ftest$element <- element
          element_ftest
        }) %>%
        bind_rows()
      group.df$group_name <- group_name
      group.df
    }) %>%
    bind_rows()
  results.df
}

promoter_element_heatmap <- function(plot.df,
                                     title,
                                     element.order=c("TATA", "Inr", "DPE", "PB", "MTE", "DRE", "Motif1", "Motif6", "Motif7"),
                                     manual.scale=c(),
                                     star_pvalue=0.05) {

  plot.df <- transform(plot.df, enrichment = ifelse(enrichment < 1, -1 / enrichment, enrichment),
                       sig_label = ifelse(pvalue < star_pvalue, "*", ""))

  if(length(manual.scale) > 0) {
    e.limit.down <- min(manual.scale)
    e.limit.up   <- max(manual.scale)
  } else {
    e.limit.up <- max(abs(plot.df$enrichment[is.finite(plot.df$enrichment)]))
    e.limit.down <- -1 * e.limit.up
  }

  plot.df <- subset(plot.df, element %in% element.order)
  plot.df$element <- factor(plot.df$element, levels=element.order)

  plot.df$enrichment[plot.df$enrichment>e.limit.up]<-e.limit.up
  plot.df$enrichment[plot.df$enrichment<e.limit.down]<-e.limit.down

   g<-ggplot(plot.df, aes(x=element, y=group_name, fill=enrichment)) +
    geom_tile() +
    geom_text(aes(label=sig_label), color="white") +
    theme_bw() +
    scale_x_discrete(expand=c(0, 0)) +
    scale_y_discrete(expand=c(0, 0)) +
    scale_fill_gradientn(name="Enrichment", space="rgb", na.value="yellow",
                         values=c(e.limit.down, -0.5, 0.5, e.limit.up),
                         colours=c("#000000", "#cccccc", "#cccccc", "#FC8F00"),
                         rescaler=function(x,...) x, oob=oob_function,
                         limits=c(e.limit.down, e.limit.up), guide=guide_colorbar()) +
    labs(x="", y="", title=title) +
    theme(panel.grid.minor=element_blank(),
          panel.grid.major=element_blank())
}


setwd("~/Sites/bbc/news/special/2015/newsspec_11329/source/data")
library(rjson)
library(sqldf)
library(reshape2)

quiz_permutations <- read.csv('user_response_permutations.csv', header=F)
colnames(quiz_permutations) <- 'permutation'
head(quiz_permutations)
nrow(quiz_permutations)

quiz_permutations$R1 <- grepl('^dcd{3,}[cd]{2,}c[cd]$', quiz_permutations$permutation)
quiz_permutations$R2 <- grepl('^[abcd]{2,}a[abcd]{6,}$', quiz_permutations$permutation)
quiz_permutations$R3 <- grepl('^[abcd]{6,}b[abcd]{2}$|^[abcd]{3,}c[abcd]{5,}$', quiz_permutations$permutation)
quiz_permutations$R4 <- grepl('^[abcd][a|b][abcd]{7,}$', quiz_permutations$permutation)
quiz_permutations$R5 <- grepl('^[abcd]{7,}d[abcd]$', quiz_permutations$permutation)
quiz_permutations$R6 <- grepl('^[abcd]{4,}[ab][abcd]{4,}$', quiz_permutations$permutation)
quiz_permutations$R7 <- grepl('^[abc]cd{3,}[cd]{2,}c[cd]$', quiz_permutations$permutation)
quiz_permutations$R8 <- grepl('^[abcd]{5,}[ab][abcd]{3,}$|^[abcd]{6,}a[abcd]{2,}$|^[abcd]{5,}[ab]a[abcd]{2,}$|^[abcd]{8,}b$|^[abcd]{5,}[ab]a[abcd]b$|[abcd]{5,}[ab][abcd]{2,}b', quiz_permutations$permutation)
quiz_permutations$R9 <- grepl('^[abcd]{3,}a[abcd]{4,}a$|^[abcd]{3,}a[abcd]{5,}$|^[abcd]{8,}a$', quiz_permutations$permutation)
# quiz_permutations$R10 <- grepl('^[abcd][ab]a[abcd]a{2,}[abcd]{3,}$|^[abcd]{3,}a[abcd]{3,}a{2,}$', quiz_permutations$permutation)
quiz_permutations$R10 <- grepl('^[abc]a[ac][ab]{3,}[ad][ab][abcd]$', quiz_permutations$permutation)
quiz_permutations$R11 <- grepl('^[abcd]d[abcd]{7,}$', quiz_permutations$permutation)
quiz_permutations$R12 <- grepl('^[abc][abcd][bc]b[cd][abcd]{2,}b[abcd]$', quiz_permutations$permutation)
quiz_permutations$R13 <- grepl('[abcd]{7,}a[abcd]$', quiz_permutations$permutation)

# extract a dataset for test size 100
sampleData <- quiz_permutations[sample(1:nrow(quiz_permutations), 100, replace=FALSE),]
head(sampleData)
colnames(sampleData) <- NULL
rownames(sampleData) <- sampleData[,1]
sampleData <- sampleData[,-1]

sampleJson <- toJSON(as.data.frame(t(sampleData)))
sampleJson
write(paste('define(', sampleJson, ');', sep=''), '../js/spec/data/testFixture.js')

allResponses <- melt(quiz_permutations, id.vars=c('permutation'))

responsesRaised <- allResponses[ allResponses$value == TRUE,]

noResponseRaised <- sqldf('SELECT * FROM quiz_permutations WHERE permutation NOT IN(SELECT DISTINCT permutation FROM responsesRaised)')
nrow(noResponseRaised) # 688 Have no response raised initially

groupedResponses <- sqldf('SELECT permutation, count(*) AS total FROM responsesRaised GROUP BY permutation')

sResponses <- sqldf('SELECT * FROM responsesRaised WHERE permutation IN(SELECT permutation FROM groupedResponses WHERE total = 1)')
nrow(sResponses) # 8304 single responses

multipleResponses <- sqldf('SELECT * FROM responsesRaised WHERE permutation IN(SELECT permutation FROM groupedResponses WHERE total > 1)')
length(unique(multipleResponses$permutation)) # 253152

# TREATMENT OF SINGLE RESPONSE PERMUTATIONS
singleResponseDistribution <- sqldf('SELECT variable, count(*) AS total FROM sResponses GROUP BY variable')
singleResponseDistribution

exportFixtureData <- function (testData, filename) {
    sampleJson <- toJSON(as.data.frame(t(sampleData)))
    print(toJSON(as.data.frame(t(head(sampleData)))))
    write(paste('define(', sampleJson, ');', sep=''), paste('../js/spec/data/', filename, '.js', sep=''))
}

# WRITE OUT TEST DATA FOR SINGLE RESPONSES
sResponses$value <- NULL
sResponses$variable <- gsub('R','response', sResponses$variable)
rownames(sResponses) <- sResponses[,1]
sResponses$i <- 0
sResponses$permutation <- NULL
colnames(sResponses) <- c('outcome', 'i')
singleMatchJson <- toJSON(as.data.frame(t(sResponses[1:100,])))
singleMatchJson
write(paste('define(', singleMatchJson, ');', sep=''), '../js/spec/data/singleMatchFixture.js')

# EXTRACT MULTIPLE OR NONE MATCHES
mResponses <- sqldf('SELECT * FROM quiz_permutations WHERE permutation IN(SELECT DISTINCT permutation FROM multipleResponses)')

# question sentiments
q1 <- c('p', 'p', 'p', 'p')
q2 <- c('x', 'x', 'p', 'y')
q3 <- c('n', 'm', 'm', 'p')
q4 <- c('x', 'm', 'y', 'p')
q5 <- c('n', 'n', 'm', 'p')
q6 <- c('n', 'n', 'p', 'p')
q7 <- c('x', 'y', 'p', 'p')
q8 <- c('x', 'm', 'p', 'y')
q9 <- c('x', 'y', 'p', 'p')

sentiments <- t(data.frame(q1, q2, q3, q4, q5, q6, q7, q8, q9))
rm(q1, q2, q3, q4, q5, q6, q7, q8, q9)
colnames(sentiments) <- c('a', 'b', 'c', 'd')

head(sentiments,10)

mResponses$q1 <- sentiments[1,substr(mResponses$permutation, 1, 1)]
mResponses$q2 <- sentiments[2,substr(mResponses$permutation, 2, 2)]
mResponses$q3 <- sentiments[3,substr(mResponses$permutation, 3, 3)]
mResponses$q4 <- sentiments[4,substr(mResponses$permutation, 4, 4)]
mResponses$q5 <- sentiments[5,substr(mResponses$permutation, 5, 5)]
mResponses$q6 <- sentiments[6,substr(mResponses$permutation, 6, 6)]
mResponses$q7 <- sentiments[7,substr(mResponses$permutation, 7, 7)]
mResponses$q8 <- sentiments[8,substr(mResponses$permutation, 8, 8)]
mResponses$q9 <- sentiments[9,substr(mResponses$permutation, 9, 9)]

head(mResponses,10)

sentimentMatrix <- mResponses[,c('permutation', paste('q', 1:9, sep=''))]
rownames(sentimentMatrix) <- sentimentMatrix[,1]
sentimentMatrix <- sentimentMatrix[,-1]
head(sentimentMatrix)

sampleData <- sentimentMatrix[sample(1:nrow(sentimentMatrix), 100, replace=FALSE),]
colnames(sampleData) <- NULL
sampleData <- as.data.frame(t(sampleData))
head(sampleData)
sampleJson <- toJSON(sampleData)
sampleJson
write(paste('define(', sampleJson, ');', sep=''), '../js/spec/data/sentimentsFixture.js')

sentimentMatrix$permutation <- rownames(sentimentMatrix)

sentimentMatrix$cn <- apply(sentimentMatrix, 1, function (x) length(x[x=='n']))
sentimentMatrix$cx <- apply(sentimentMatrix, 1, function (x) length(x[x=='x']))
sentimentMatrix$cy <- apply(sentimentMatrix, 1, function (x) length(x[x=='y']))
sentimentMatrix$cm <- apply(sentimentMatrix, 1, function (x) length(x[x=='m']))
sentimentMatrix$cp <- apply(sentimentMatrix, 1, function (x) length(x[x=='p']))

head(sentimentMatrix)

head(mResponses)
sentimentMatrix <- sentimentMatrix[,c('permutation', 'cn', 'cm', 'cp', 'cx', 'cy')]
rownames(sentimentMatrix) <- NULL

mResponses <- merge(mResponses, sentimentMatrix, by.x='permutation', by.y='permutation')

nrow(mResponses)

head(mResponses)

# HANDLE NEGATIVE RESPONSES
negativeResponses <- mResponses[mResponses$cn > 0 | mResponses$cx > 0 | mResponses$cy > 0,]

negativeResponses$sentiment <- paste(negativeResponses$q1, negativeResponses$q2, negativeResponses$q3, negativeResponses$q4, negativeResponses$q5, negativeResponses$q6, negativeResponses$q7, negativeResponses$q8, negativeResponses$q9, sep='')

negativeResponses <- negativeResponses[,c('permutation', 'sentiment')]

negativeResponses$response2 <- grepl('^[^nxy]{2,}n[^nxy]{6,}$', negativeResponses$sentiment)
negativeResponses$response3 <- grepl('^[^nxy]{6,}y[^nxy]{2,}$|^[^nxy]{3,}y[^nxy]{5,}$|^[^nxy]{3,}y[^nxy]{2,}y[^nxy]{2,}$', negativeResponses$sentiment)
negativeResponses$response4 <- grepl('^[^nxy]x[^nxy]{7,}$', negativeResponses$sentiment)
negativeResponses$response5 <- grepl('^[^nxy]{7,}y[^nxy]$', negativeResponses$sentiment)
negativeResponses$response6 <- grepl('^[^nxy]{4,}n[^nxy]{4,}$', negativeResponses$sentiment)
negativeResponses$response8 <- grepl('^[^nxy]{5,}n[^nxy]{3,}$|^[^nxy]{6,}x[^nxy]{2,}$|^[^nxy]{5,}nx[^nxy]{2,}$|^[^nxy]{8,}y$|^[^nxy]{5,}nx[^nxy]y$|^[^nxy]{6,}x[^nxy]y$|^[^nxy]{5,}n[^nxy]{2,}y$|^[^nxy]{5,}n[^nxy]{2,}y$', negativeResponses$sentiment)
negativeResponses$response9 <- grepl('^[^nxy]{3,}x[^nxy]{4,}x$|^[^nxy]{3,}x[^nxy]{5,}$|^[^nxy]{8,}x$', negativeResponses$sentiment)
negativeResponses$response11 <- grepl('^[^nxy]y[^nxy]{7,}$', negativeResponses$sentiment)
negativeResponses$response13 <- grepl('^[^nxy]{7,}x[^nxy]$', negativeResponses$sentiment)

nrow(negativeResponses)

head(negativeResponses)

response10 <- negativeResponses[ negativeResponses$response2 == FALSE & negativeResponses$response3 == FALSE & negativeResponses$response4 == FALSE & negativeResponses$response5 == FALSE & negativeResponses$response6 == FALSE & negativeResponses$response8 == FALSE & negativeResponses$response9 == FALSE & negativeResponses$response11 == FALSE & negativeResponses$response13 == FALSE,]
nrow(response10) #252672
head(response10, 30)

# EXPORT RESPONSE 10 FIXTURE DATA

head(negativeResponses)

sentimentResponses <- negativeResponses[,-2]
sentimentResponses <- melt(sentimentResponses, id.vars=c('permutation'))
colnames(sentimentResponses) <- c('permutation', 'outcome', 'value')

sentimentResponses <- sentimentResponses[ sentimentResponses$value == TRUE,]

head(sentimentResponses)

singleResponseSentimentDistribution <- sqldf('select outcome, count(*) as total from sentimentResponses group by outcome')

singleResponseSentimentDistribution

singleSentimentMatches <- sqldf('select * from sentimentResponses where permutation in(select permutation from sentimentResponses group by permutation having count(*) = 1)')
nrow(singleSentimentMatches)

sampleData <- singleSentimentMatches[sample(1:nrow(singleSentimentMatches), 100, replace=FALSE),]
head(sampleData)
rownames(sampleData) <- sampleData[,1]
sampleData <- sampleData[,-1]
# colnames(sampleData) <- NULL
sampleData <- as.data.frame(t(sampleData))
head(sampleData)
sampleJson <- toJSON(sampleData)
sampleJson
write(paste('define(', sampleJson, ');', sep=''), '../js/spec/data/singleMatchBySentimentFixture.js')

multipleSentimentMatches <- sqldf('select * from sentimentResponses where permutation in(select permutation from sentimentResponses group by permutation having count(*) > 1)')

head(multipleSentimentMatches)

head(noResponseRaised)
noResponseRaised$q1 <- sentiments[1,substr(noResponseRaised$permutation, 1, 1)]
noResponseRaised$q2 <- sentiments[2,substr(noResponseRaised$permutation, 2, 2)]
noResponseRaised$q3 <- sentiments[3,substr(noResponseRaised$permutation, 3, 3)]
noResponseRaised$q4 <- sentiments[4,substr(noResponseRaised$permutation, 4, 4)]
noResponseRaised$q5 <- sentiments[5,substr(noResponseRaised$permutation, 5, 5)]
noResponseRaised$q6 <- sentiments[6,substr(noResponseRaised$permutation, 6, 6)]
noResponseRaised$q7 <- sentiments[7,substr(noResponseRaised$permutation, 7, 7)]
noResponseRaised$q8 <- sentiments[8,substr(noResponseRaised$permutation, 8, 8)]
noResponseRaised$q9 <- sentiments[9,substr(noResponseRaised$permutation, 9, 9)]

sqldf('select count(*) from noResponseRaised where q1 = "p" and q2 = "p" and q3 = "p" and q4 = "p" and q5 = "p" and q6 = "p" and q7 = "p" and q8 = "p" and q9 = "p"')

#
# colnames(multipleResponses) <- c('permutation', 'outcome', 'value')
# multipleResponses$outcome <- gsub('R', 'response', multipleResponses$outcome)
#
# head(multipleSentimentMatches)
# head(multipleResponses)
#
# intersectOfMatchAndSentimentMatch <- sqldf('select b.permutation, b.outcome from multipleResponses a, multipleSentimentMatches b where a.permutation = b.permutation and a.outcome = b.outcome')
#
# sampleData <- intersectOfMatchAndSentimentMatch[sample(1:nrow(intersectOfMatchAndSentimentMatch), 150, replace=FALSE),]
# head(sampleData)
# sampleData$i <- 0
# rownames(sampleData) <- sampleData[,1]
# sampleData <- sampleData[,-1]
# sampleData <- as.data.frame(t(sampleData))
# head(sampleData)
# sampleJson <- toJSON(sampleData)
# sampleJson
# write(paste('define(', sampleJson, ');', sep=''), '../js/spec/data/singleMatchByIntersectionFixture.js')
#
#
#
#
#
# positiveSentiments <- mResponses[mResponses$cn == 0,]
# positiveSentiments$R10 <- grepl('^[abc]a[ac][ab]{3,}[ad][ab][abcd]$', positiveSentiments$permutation)
#
#
# nrow(positiveSentiments[ positiveSentiments$R10 == TRUE, ])
#
#
#
# head(positiveSentiments)
#
# nrow(positiveSentiments)
#
#
# #
# # quiz_permutations.matrix[quiz_permutations.matrix==FALSE] <- 0
# # quiz_permutations.matrix[quiz_permutations.matrix==TRUE] <- 1
# # # alternative solution
# # # as.data.frame(lapply(quiz_permutations.numeric, function(x){replace(x, x==0,'false'); replace(x,x==1,'true')}))


suppressPackageStartupMessages(library(optparse, warn.conflicts=F, quietly=T))
suppressPackageStartupMessages(library(GenomicRanges, warn.conflicts=F, quietly=T))
suppressPackageStartupMessages(library(rtracklayer, warn.conflicts=F, quietly=T))

option_list <- list(
		make_option(c("-f", "--file"),
              type="character",
              help="Path to granges file"),
	  	make_option(c("-s", "--file2"),
	          type="character",
			  default= NA,
	          help="Path to the second granges file"),
		make_option(c("-n", "--name"),
			  type="character",
			  help="name of the output data"),
	  	make_option(c("-m", "--normalization"),
			  default = "T",
	  		  type="character",
	  		  help="parameter to indicate if normalize to the total reads, default is true"),
		make_option(c("-t", "--type"),
			  default = "chipnexus",
			  type="character",
			  help="experiment type, chipseq or chipnexus"))

opt <- parse_args(OptionParser(option_list=option_list))

total_reads_normalization <- function(gr, type){
	if(type == "chipnexus"){
		total_reads <- length(gr)
		gr.pos <- gr[strand(gr) == "+"]
		gr.neg <- gr[strand(gr) == "-"]
		gr.pos.cov <- coverage(gr.pos) / total_reads * 1000000
		gr.neg.cov <- coverage(gr.neg) / total_reads * 1000000 *(-1)
		cov.list <- list(pos =gr.pos.cov, neg = gr.neg.cov )
	}
	if(type == "chipseq"){
		total_reads <- length(gr)
		cov <- coverage(gr) / total_reads *1000000
		cov.list <- list(pos = cov)
	}
	cov.list
}

if(opt$type == "chipnexus"){
	message("sample being processed is chipnexus")
	message("reading the granges file")
	gr  <- readRDS(opt$file)
	gr <- resize(gr, 1, "start")

	if(opt$normalization == "T"){
		message("generating the normalized coverage files")
		cov.list <- total_reads_normalization(gr, "chipnexus")
	}else{
		message("generating the non-normalized coverage files")
		gr.pos <- gr[strand(gr) == "+"]
		gr.neg <- gr[strand(gr) == "-"]
		gr.pos.cov <- coverage(gr.pos)
		gr.neg.cov <- coverage(gr.neg) * (-1)
		cov.list <- list(pos =gr.pos.cov, neg = gr.neg.cov )
	}

	if(!is.na(opt$file2)){
		message("reading the second granges file")
		gr2  <- readRDS(opt$file2)
		gr2 <- resize(gr2, 1, "start")

		if(opt$normalization == "T"){
			message("generating the second normalized coverage files")
			cov.list2 <- total_reads_normalization(gr2, "chipnexus")
			cov.list <- list(pos =cov.list$pos + cov.list2$pos, neg = cov.list$neg + cov.list2$neg )
		}else{
			message("generating the second non-normalized coverage files")
			gr.pos2 <- gr[strand(gr2) == "+"]
			gr.neg2 <- gr[strand(gr2) == "-"]
			gr.pos.cov2 <- coverage(gr.pos2)
			gr.neg.cov2 <- coverage(gr.neg2) * (-1)
			cov.list2 <- list(pos =gr.pos.cov2, neg = gr.neg.cov2 )
			cov.list <- list(pos =cov.list$pos + cov.list2$pos, neg = cov.list$neg + cov.list2$neg )
		}

	}
	message("exporting bigwig files")
	export(cov.list$pos, paste0(opt$name, "_positive.bw"))
	export(cov.list$neg, paste0(opt$name, "_negative.bw"))

}

if(opt$type == "chipseq"){
	message("sample being processed is chipseq")
	message("reading the granges file")
	gr <- get(load(opt$file))
	if(opt$normalization == "T"){
		message("generating the normalized coverage files")
		cov.list <- total_reads_normalization(gr, "chipseq")
	}else{
		message("generating the non-normalized coverage files")
		cov.list <- list(pos=coverage(gr))
	}

	if(!is.na(opt$file2)){
		message("reading the second granges")
		gr2 <- get(load(opt$file2))
		if(opt$normalization == "T"){
			message("generating the normalized coverage files")
			cov.list2 <- total_reads_normalization(gr2, "chipseq")
			cov.list <- list(pos =cov.list$pos + cov.list2$pos)
		}else{
			message("generating the non-normalized coverage files")
			cov.list2 <- list(pos=coverage(gr2))
			cov.list <- list(pos =cov.list$pos + cov.list2$pos)
		}
	}
	message("exporting bigwig files")
	export(cov.list$pos, paste0(opt$name, ".bw"))
}


 #SNOPSIS

 #runs population structure analysis using PCA from SNPRelate, a bioconductor R package

 #AUTHOR
 # Isaak Y Tecle (iyt2@cornell.edu)

options(echo = FALSE)

library(randomForest)
library(data.table)
library(genoDataFilter)
library(tibble)
library(dplyr)
library(stringr)
library(phenoAnalysis)
library(ggplot2)

allArgs <- commandArgs()

outputFile  <- grep("output_files", allArgs, value = TRUE)
outputFiles <- scan(outputFile, what = "character")

inputFile  <- grep("input_files", allArgs, value = TRUE)
inputFiles <- scan(inputFile, what = "character")

scoresFile       <- grep("pca_scores", outputFiles, value = TRUE)
screeDataFile       <- grep("pca_scree_data", outputFiles, value = TRUE)
screeFile       <- grep("pca_scree_plot", outputFiles, value = TRUE)
loadingsFile     <- grep("pca_loadings", outputFiles, value = TRUE)
varianceFile     <- grep("pca_variance", outputFiles, value = TRUE)
combinedDataFile <- grep("combined_pca_data_file", outputFiles, value = TRUE)

if (is.null(scoresFile))
{
  stop("Scores output file is missing.")
  q("no", 1, FALSE)
}

if (is.null(loadingsFile))
{
  stop("Laodings file is missing.")
  q("no", 1, FALSE)
}

genoData         <- c()
genoMetaData     <- c()
filteredGenoFile <- c()
phenoData        <- c()

set.seed(235)

pcF <- grepl("genotype", ignore.case=TRUE, inputFiles)
dataType <- ifelse(isTRUE(pcF[1]), 'genotype', 'phenotype')

if (dataType == 'genotype') {
    if (length(inputFiles) > 1 ) {
        allGenoFiles <- inputFiles
        genoData <- combineGenoData(allGenoFiles)

        genoMetaData   <- genoData$trial
        genoData$trial <- NULL

    } else {
        genoDataFile <- grep("genotype_data", inputFiles,  value = TRUE)
        genoData     <- fread(genoDataFile,
                              header = TRUE,
                              na.strings = c("NA", " ", "--", "-", "."))

        if (is.null(genoData)) {

            filteredGenoFile <- grep("filtered_genotype_data_",
                                 genoDataFile,
                                 value = TRUE)

            if (filteredGenoFile) {
                genoData <- fread(filteredGenoFile,  header = TRUE)
            }
        }

        genoData <- unique(genoData, by='V1')
        genoData <- data.frame(genoData)
        genoData <- column_to_rownames(genoData, 'V1')

    }
} else if (dataType == 'phenotype') {

    metaFile <- grep("meta", inputFiles,  value = TRUE)
    phenoFiles <- grep("phenotype_data", inputFiles,  value = TRUE)

    if (length(phenoFiles) > 1 ) {

        phenoData <- combinePhenoData(phenoFiles, metaDataFile = metaFile)
        phenoData <- summarizeTraits(phenoData, groupBy=c('studyDbId', 'germplasmName'))

        if (all(is.na(phenoData$locationName))) {
            phenoData$locationName <- 'location'
        }

        phenoData <- na.omit(phenoData)
        genoMetaData <- phenoData$studyDbId

        phenoData <- phenoData %>% mutate(germplasmName = paste0(germplasmName, '_', studyDbId))
        dropCols = c('replicate', 'blockNumber', 'locationName', 'studyDbId', 'studyYear')
        phenoData <- phenoData %>% select(-dropCols)
        rownames(phenoData) <- NULL
        phenoData <- column_to_rownames(phenoData, var="germplasmName")
    } else {
        phenoDataFile <- grep("phenotype_data", inputFiles,  value = TRUE)

        phenoData <- cleanAveragePhenotypes(inputFiles, metaFile)
        phenoData <- na.omit(phenoData)
    }

    phenoData <- phenoData[, apply(phenoData, 2, var) != 0 ]
    phenoData <- scale(phenoData, center=TRUE, scale=TRUE)
    phenoData <- round(phenoData, 3)
}

if (is.null(genoData) && is.null(phenoData)) {
  stop("There is no data to run PCA.")
  q("no", 1, FALSE)
}

genoDataMissing <- c()
if (dataType == 'genotype') {
   # if (is.null(filteredGenoFile) == TRUE) {
        ##genoDataFilter::filterGenoData
        genoData <- convertToNumeric(genoData)
        genoData <- filterGenoData(genoData, maf=0.01)
        genoData <- roundAlleleDosage(genoData)

        message("No. of geno missing values, ", sum(is.na(genoData)) )
        if (sum(is.na(genoData)) > 0) {
            genoDataMissing <- c('yes')
           # genoData <- na.roughfix(genoData)
        }
}

## nCores <- detectCores()
## message('no cores: ', nCores)
## if (nCores > 1) {
##   nCores <- (nCores %/% 2)
## } else {
##   nCores <- 1
## }

pcaData <- c()
if (!is.null(genoData)) {
    pcaData <- genoData
    genoData <- NULL
} else if(!is.null(phenoData)) {
    pcaData <- phenoData
    phenoData <- NULL
}

message("No. of missing values, ", sum(is.na(pcaData)) )
if (sum(is.na(pcaData)) > 0) {
    pcaData <- na.roughfix(pcaData)
}

pcsCnt <- ifelse(ncol(pcaData) < 10, ncol(pcaData), 10)
pca    <- prcomp(pcaData, retx=TRUE)
pca    <- summary(pca)

scores   <- data.frame(pca$x)
scores   <- scores[, 1:pcsCnt]
scores   <- round(scores, 3)

if (!is.null(genoMetaData)) {
    scores$trial <- genoMetaData
    scores       <- scores %>% select(trial, everything()) %>% data.frame
} else {
  scores$trial <- 1000
  scores <- scores %>% select(trial, everything()) %>% data.frame
}

scores   <- scores[order(row.names(scores)), ]

varianceAllPCs <- data.frame(pca$importance)
varianceSelectPCs <- varianceAllPCs[2, 1:pcsCnt]
varianceSelectPCs <- round(varianceSelectPCs, 4) * 100
varianceSelectPCs <- data.frame(t(varianceSelectPCs))

colnames(varianceSelectPCs) <- 'Variances'

loadings <- data.frame(pca$rotation)
loadings <- loadings[, 1:pcsCnt]
loadings <- round(loadings, 3)

varianceAllPCs <- varianceAllPCs[2, ] %>%
    t() %>%
    round(3) * 100

colnames(varianceAllPCs) <- 'Variances'
varianceAllPCs <- data.frame(varianceAllPCs)

varianceAllPCs <- rownames_to_column(varianceAllPCs, 'PCs')
varianceAllPCs <- data.frame(varianceAllPCs)

screePlot <- ggplot(varianceAllPCs, aes(x = reorder(PCs, -Variances), y = Variances, group = 1)) +
    geom_line(color="red") +
    geom_point() +
    xlab('PCs') +
    ylab('Explained variance (%)') +
    theme(axis.text.x = element_text(angle = 90))

png(screeFile)
screePlot
dev.off()

fwriteOutput <- function (data, dataFile) {
    fwrite(data,
    file      = dataFile,
    sep       = "\t",
    row.names = TRUE,
    quote     = FALSE,
    )

}

fwriteOutput(scores, scoresFile)
fwriteOutput(varianceAllPCs, screeDataFile)
fwriteOutput(loadings, loadingsFile)
fwriteOutput(varianceSelectPCs, varianceFile)

if (!is.null(genoData)) {
    if (length(inputFiles) > 1) {
        fwriteOutput(genoData, combinedDataFile)
    }
}

# ## if (!is.null(genoDataMissing)) {
# ## fwrite(genoData,
# ##        file      = genoDataFile,
# ##        sep       = "\t",
# ##        row.names = TRUE,
# ##        quote     = FALSE,
# ##        )
#
# ## }

q(save = "no", runLast = FALSE)


readOldMAC<-function() {
  CW<-data.frame(year=1974:1979, cw=c(607586,784014,828235,620247,736726,843155)) # total catach weight from WGWIDE 2016, table 8.3.1.1.
  old<-read.csv(file=file.path(root,exchangeDir,'vpa_ca01_MAC_4M.csv'))
  old<-subset(old,year>=1974  & year<1980)
  old[old$age>10,'age']<-10 # to 10+

  old$CN<-old$WCATCH*old$CATCHN
  old<-aggregate(cbind(CN,CATCHN)~year+age+sub_area+species,data=old,sum )
  old$WCATCH<-old$CN/old$CATCHN

  oldSum<-aggregate(CN~year,data=old,sum )

  oldSum<-merge(oldSum,CW)
  oldSum$ratio<-oldSum$cw/oldSum$CN
  oldSum<-subset(oldSum,select=c(year,ratio))
  old<-merge(old,oldSum)
  old$CATCHN<-old$CATCHN*old$ratio
  old$CN<-old$ratio<-NULL
  head(old)
  tapply(old$CATCHN*old$WCATCH,list(old$year),sum)
  old$quarter<-1
  return(old)
}

MAC<-readOldMAC()
MAC$PROP_CAT<-1;
head(MAC)

NEW<-read.csv(file=file.path(root,exchangeDir,'vpa_ca01_MAC_SAM.csv'))
NEW$fleet<-NEW$cat<-NULL
head(NEW)

MAC<-rbind(MAC,NEW)
MAC[MAC$age>10,'age']<-10 # to 10+

MAC$CN<-MAC$WCATCH*MAC$CATCHN
MAC<-aggregate(cbind(CN,CATCHN)~year+quarter+age+sub_area+species,data=MAC,sum )
MAC$WCATCH<-MAC$CN/MAC$CATCHN
MAC$CN<-NULL
MAC$sub_area<-'1'

t(t(tapply(MAC$WCATCH*MAC$CATCHN,list(MAC$year),sum)))
round(tapply(MAC$WCATCH*MAC$CATCHN,list(MAC$year,MAC$age),sum),0)

# mean catch weights
old<-read.csv(file=file.path(root,exchangeDir,'vpa_ca01_MAC_4M.csv'))
xyplot(WCATCH~age|quarter,group=year,data=old,type='b')
xyplot(WCATCH~year|quarter,group=age,data=old,type='b')

# mean stock weights
old<-read.csv(file=file.path(root,exchangeDir,'vpa_bi01_MAC_4M.csv'))

show.settings()
my.col<-c('black','red','blue','orange','darkgreen','brown','yellow')
mt<-trellis.par.get()
mt$superpose.symbol$col<-my.col

#mt$superpose.symbol$pch<-1:7
mt$superpose.symbol$pch<-as.character(1:7)
mt$superpose.line$col<-my.col
trellis.par.set(mt)

xyplot(WSEA~age|paste("Quarter:",quarter),group=year,data=old,type='b',ylab='Mean weight in the sea (kg)')
xyplot(WSEA~year|paste("Quarter:",quarter),group=age,data=old,type='b',ylab='Mean weight in the sea (kg)')
xyplot(WSEA~age,group=paste(quarter,year),data=old,type='b',ylab='Mean weight in the sea (kg)')

old$year<-NULL
old<-unique(old)
trellis.par.set(mt)
xyplot(WSEA~age,group=quarter,data=old,type='b',ylab='Mean weight in the sea (kg)')

old<-subset(old,age<=12)
old[old$age>10,'age']<-10

old<-aggregate(WSEA~quarter+sub_area+species+age+M+M1,data=old,mean)
xyplot(WSEA~age,group=paste(quarter),data=old,type='b',ylab='Mean weight in the sea (kg)')

sam<-read.csv(file=file.path(root,exchangeDir,'vpa_bi01_MAC_SAM.csv'))
sam<-subset(sam,select=c(-WSEA,-M,-M1,-sub_area,-quarter))

bio<-merge(old,sam)

ftable(round(tapply(bio$WSEA,list(bio$year,bio$quarter,bio$age),sum),3))
head(bio)

b<-subset(bio,year==1980,select=c(-year))
a<-data.frame(year=1974:1979,species='MAC')
ab<-merge(a,b)
bio<-rbind(bio,ab)


##script to model only species with 20 or more records
##Edgar project 2012
##developed by Lauren Hodgson...lhodgson86@gmail.com
##
## Expects 1 arg, the path to the occurrences file to be tested.

library(SDMTools);

args=commandArgs(TRUE);

occur_file=args[1];

toccur=read.csv(paste(occur_file,sep=''));
toccur$LATDEC = round(toccur$LATDEC/0.05)*0.05;
toccur$LONGDEC = round(toccur$LONGDEC/0.05)*0.05;

toccur=unique(toccur); #find only unique records

pointcount=nrow(toccur);

if (pointcount >20) {
    #run the model
    q(status=0);
} else {
    #don't run the model
    q(status=1);
}


# Script to generate table of local maxima of CHM in tiff format as provided
# by LASTools
#
# Syntax:
#
#		>> RScript prior_cleaner.R  data_file scale min_h allom_lut/window_size [tau]
#
# Example:
#
#		>> Rscript itcseg_prior.r data.las 0.5 10 allom_lut.csv 90
#
# Method:
#
#       This script takes the CHM in the tiff file and finds local maxima using
#       the apporach found in ITCsegment package. If an allom lookup table is
#       supplied then an allometrically scaling search window is used, otherwise
#       a fixed window size is used as set by the same argument.
#
#       here a maxima is simply a point which has no point higher than it within
#       its search window. The output is a csv file with x,y,z cooridnates of
#       local maxima of the CHM
#
# Inputs:
#
#	data_file:              Name of CHM in TIFF format (with raw height values)
#       scale:                  Cell size of CHM
#       min_h:                  Minimum height of a local maxima to be kept
#       allom_lut/window_size:  If you want an allometrically scaling search
#                               window then put the name of a csv file
#                               containing a,b for the 100 percentiles of
#                               quantile regression for R = exp(a)*H^b
#                               Otherwise, put the fixed window width in terms
#                               of pixel numbers
#       [tau]:                  optional choice of percentile to set boundary
#                               near edge of plot to reject
#
# Output:
#
#	A csv file of the local maxima co-ordinates
#
#	Jonathan Williams
#	jonvw28@gmail.com
#	06/11/2017

# Catch arguments to the script
args <- commandArgs(trailingOnly = FALSE)
idx <- grep('--file=',args)
script.path <- dirname(normalizePath(sub('--file=', "", args[idx])))
args<- args[-(1:(idx+1))]

# Check that these make sense
if (length(args) == 0){
        # Has Input CHM Been Specified
        stop("Input not specified")

} else if(length(args) == 1){
        # Check if CHM scale is set
        warning("CHM scale has not been specified, defaulting to 1, and minimum height not specified, defaulting to 10")
        args <- c(args,1,10)

} else if(length(args)>=2 && is.na(as.numeric(args[2]))){
        # Check CHM scale is valid
        stop("Scale must be a number")

} else if(length(args)>=3 && is.na(as.numeric(args[3]))){
        # Check minimum height is valid
        stop("minimum height must be a number")

} else if(length(args)==4 && is.na(as.numeric(args[4]))){
        # Check if Tau is set
        warning("Tau not set, defaulting to 90")
        args <- c(args,90)
} else if(length(args)==5 && is.na(as.numeric(args[5]))){
        # Check Tau is valid
        stop("tau must be a number")
}

# Check folder is unix friendly
args[1] <- gsub("\\\\","/",args[1])
args[4] <- gsub("\\\\","/",args[4])

# get package dependencies
if(!require(raster)){
        install.packages('raster')
}
library(raster)
library(rgdal)

# Get required scripts
source(paste(script.path,'/tom_itc_max/utils.r',sep=""))
source(paste(script.path,'/tom_itc_max/detect_maxima.r',sep=""))
source(paste(script.path,'/tom_itc_max/gen_ITCsegmax_prior.r',sep=""))

# Find maxima based on lookup table or not
if(length(args)==3){
        maxima <- gen_ITCSegmax_prior(args[1],
                                      scale=as.numeric(args[2]),
                                      min_h=as.numeric(args[3]))
} else if(length(args)==4){
        maxima <- gen_ITCSegmax_prior(args[1],
                                      scale=as.numeric(args[2]),
                                      min_h=as.numeric(args[3]),
                                      window_size = as.numeric(args[4]))
} else {
        maxima <- gen_ITCSegmax_prior(args[1],lut=args[4],
                                      scale=as.numeric(args[2]),
                                      min_h=as.numeric(args[3]),
                                      tau=as.numeric(args[5]))
}
colnames(maxima) <- c('X','Y','Z')
write.table(maxima,file=paste(substr(args[1],1,nchar(args[1])-4),"_prior.csv",sep=""),
            sep=",",col.names = T, row.names = F)


bottom.contact.filter.noise = function( x, good, bcp, debug=FALSE ) {

  # First, a simple high pass filter to remove noisy data (very large extreme fluctuations)
  # Then, truncation of data based upon variance of central region to permit use of more fine-scale methods
  # to determine anomlaous data

  # do not operate upon depth (keep as reference)... operate upon Z and Z.smoothed
  x$Z = x$depth  # x$Z will be returned ...
  nx = nrow(x)

  # 1. check range of the data and recheck using modal filter of the bottom part of the "good" area
  fr = range( which(good) )
  aoi = fr[1]:fr[2]

  Zmin = min( x$depth, na.rm=TRUE )
  tooshallow = which( x$Z < Zmin)
  if (length( tooshallow)>0) {
    good[ tooshallow ] = FALSE
    x$Z[ tooshallow ] = NA
  }

  mm = modes( x$Z[aoi] )
  mm.aoi =  which ( x$Z >= mm$lb2*0.9 & x$Z <= mm$ub2*1.1  ) # fisrt estimate of bottom

  Zmax = max (x$depth[mm.aoi], na.rm=TRUE ) + 40  # sometimes very steep tows ...
  toodeep = which( x$Z > Zmax )
  if (length( toodeep )>0) {
    good[ toodeep ] = FALSE
    x$Z[ toodeep ] = NA
  }

  aoi = min( mm.aoi ) : max( mm.aoi )
  if (length( aoi) < 30 ) {
    y = NA
    class( y) = "try-error"
    return (y)
  }

  # 2. focus upon aoi: identify data that are likely noise and mark them
  #  filter localized (adjacent) deviations
  tm0 = x[aoi, c("ts", "Z")]

  tm = tm0
  tm$Z[ !good[aoi]] = NA
  test = NULL
  test = try( interpolate.xy.robust( tm, method="sequential.linear",
      trim=bcp$noisefilter.trim, probs=bcp$noisefilter.quants ), silent =TRUE  )
  if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
    kk = x$Z[aoi] - test
    # ll =  which( abs(kk) < bcp$eps.depth )
    # i = intersect( ll, which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )  )
    i = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
    j = setdiff(1:nx , i )
    if (length(i) > 0) good[aoi[i]] = FALSE
    # if (length(j) > 0) good[aoi[j]] = TRUE
    x$Z[ !good] = NA
  }

  # filter out based upon local-mean estimates
  tm = tm0
  tm$Z[ !good[aoi] ] = NA
  test = NULL
  test = try( interpolate.xy.robust( tm, method="moving.window",
      target.r2=bcp$noisefilter.target.r2, trim=bcp$noisefilter.trim, mv.win=bcp$noisefilter.var.window ), silent =TRUE  )
  if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
    kk = x$Z[aoi] - test
    # ll =  which( abs(kk) < bcp$eps.depth )
    # i = intersect( ll, which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )  )
    i = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
    j = setdiff(1:nx, i )
    if (length(i) > 0) good[aoi[i]] = FALSE
    # if (length(j) > 0) good[aoi[j]] = TRUE
    x$Z[ !good] = NA
  }

  # filter out based upon local-variance estimates
  tm = tm0
  tm$Z[ !good[aoi] ] = NA
  test = try( interpolate.xy.robust( tm, method="local.variance",
      target.r2=bcp$noisefilter.target.r2, trim=bcp$noisefilter.trim, mv.win=bcp$noisefilter.var.window ) )
  if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
    kk = x$Z[aoi] - test
    # ll =  which( abs(kk) < bcp$eps.depth )
    # i = intersect( ll, which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )  )
    i = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
    j = setdiff(1:nx , i )
    if (length(i) > 0) good[aoi[i]] = FALSE
    # if (length(j) > 0) good[aoi[j]] = TRUE
    x$Z[ !good] = NA
  }

   # filter out based upon local-mean estimates
  tm = tm0
  tm$Z[ !good[aoi] ] = NA
  test = NULL
  test = try( interpolate.xy.robust( tm, method="linear",
      target.r2=bcp$noisefilter.target.r2, trim=bcp$noisefilter.trim, mv.win=bcp$noisefilter.var.window ), silent =TRUE  )
  if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
    kk = x$Z[aoi] - test
    # ll =  which( abs(kk) < bcp$eps.depth )
    # i = intersect( ll, which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )  )
    i = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
    j = setdiff(1:nx, i )
    if (length(i) > 0) good[aoi[i]] = FALSE
    # if (length(j) > 0) good[aoi[j]] = TRUE
    x$Z[ !good] = NA
  }

  # finalize update of aoi
  aoi.finite = which( is.finite(x$Z) )
  aoi.range  = range( aoi.finite )
  aoi = aoi.range[1] : aoi.range[2]

  tm2 = x[aoi, c("ts", "Z")]
  test = NULL
  test = try( interpolate.xy.robust( tm2, method=bcp$noisefilter.smoother,
    target.r2=bcp$noisefilter.target.r2, trim=bcp$noisefilter.trim ), silent =TRUE  )
    if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
      kk = x$depth[aoi] - test
      i = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=TRUE )
      j = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
      # reset "good"
      if (length(i) > 0) good[aoi[i]] = TRUE
      if (length(j) > 0) good[aoi[j]] = FALSE
    }
    rm(tm2); gc()

# 3. finalize id of good data and create a smooth based upon the good data
#   by this point, the Z are the highest probability of good clean data ..
#   operate upon finding a smooth return them to the data for futher processing
  x$Z.smoothed = x$depth  # begin with raw data
  x$Z.smoothed[ aoi.finite ] = x$Z[aoi.finite]
  x$Z.smoothed[!good[aoi]] = NA

# smooth the tails
  buff = 3 ## ~ sec
  leftt = fr[1] : (min(aoi+buff) )  # add a buffer
  rightt = (max(aoi)-buff  ) :  fr[2]   # add a buffer
  tails = c( fr[1]:min(aoi), max(aoi):fr[2] )

  if (length( leftt) > buff ) {
    # force tails to surface .. helps tails to go in right direction when not enough data retained
    x$Z.smoothed[ fr[1] ] = Zmin
    test = NULL
    test = try( interpolate.xy.robust( x[leftt, c("ts", "Z.smoothed")],  method="sequential.linear",
        trim=bcp$noisefilter.trim, probs=bcp$noisefilter.quants ), silent =TRUE  )
    if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 3)  ) ) x$Z.smoothed[leftt] = test

    x$Z.smoothed[ fr[1] ] = Zmin
    test = NULL
    test = try( interpolate.xy.robust( x[leftt, c("ts", "Z.smoothed")],  method="linear",
        trim=bcp$noisefilter.trim, probs=bcp$noisefilter.quants ), silent =TRUE  )
    if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 3)  ) ) x$Z.smoothed[leftt] = test

    x$Z.smoothed[ fr[1] ] = Zmin
    test = NULL
    test = try( interpolate.xy.robust( x[leftt, c("ts", "Z.smoothed")],  method="moving.window",
        trim=bcp$noisefilter.trim, probs=bcp$noisefilter.quants ), silent =TRUE  )
    if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 3)  ) ) x$Z.smoothed[leftt] = test
  }

  if (length( rightt ) > buff ) {
    x$Z.smoothed[ fr[2] ] = Zmin
    test = NULL
    test = try( interpolate.xy.robust( x[rightt, c("ts", "Z.smoothed")],  method="sequential.linear",
        trim=bcp$noisefilter.trim, probs=bcp$noisefilter.quants ), silent =TRUE )
    if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 3)  ) ) x$Z.smoothed[rightt] = test

    x$Z.smoothed[ fr[2] ] = Zmin
    test = NULL
    test = try( interpolate.xy.robust( x[rightt, c("ts", "Z.smoothed")],  method="linear",
        trim=bcp$noisefilter.trim, probs=bcp$noisefilter.quants ), silent =TRUE )
    if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 3)  ) ) x$Z.smoothed[rightt] = test

    x$Z.smoothed[ fr[2] ] = Zmin
    test = NULL
    test = try( interpolate.xy.robust( x[rightt, c("ts", "Z.smoothed")],  method="moving.window",
        trim=bcp$noisefilter.trim, probs=bcp$noisefilter.quants ), silent =TRUE )
    if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 3)  ) ) x$Z.smoothed[rightt] = test

  }

  if (length( tails ) > 0 ) {
    kk = x$depth[tails] - x$Z.smoothed[tails]
    i = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
    if (length(i) > 0 ) {
      good [ tails[i] ]  = FALSE
    }
  }

    # last smooth: with all good data back together ... force tails to be very shallow
  sm = x[, c("ts", "Z")]
  sm$Z[ range(aoi) ] = min( x$depth[aoi], na.rm=TRUE )   # force terminal points to be the most shallow

    # test = NULL
    # test = try( interpolate.xy.robust( sm[aoi,],  method="sequential.linear",
    #     trim=bcp$noisefilter.trim, probs=bcp$noisefilter.quants ), silent =TRUE )
    # if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 3)  ) ) {
    #     kk = x$depth[aoi] - test
    #     j = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
    #     if (length(j) > 0) {
    #       good[aoi[j]] = FALSE
    #       sm$Z[ !good ] = NA
    #     }
    # }

    # test = NULL
    # test = try( interpolate.xy.robust( sm[aoi,],  method="moving.window",
    #     trim=bcp$noisefilter.trim, probs=bcp$noisefilter.quants ), silent =TRUE )
    # if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 3)  ) ) {
    # kk = x$depth[aoi] - test
    #     j = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
    #     if (length(j) > 0) {
    #       good[aoi[j]] = FALSE
    #       sm$Z[ !good ] = NA
    #     }
    # }

    # last smooth ... wrap up
    test = NULL
    test = try( interpolate.xy.robust( sm[aoi,], method=bcp$noisefilter.smoother,
      target.r2=bcp$noisefilter.target.r2, trim=bcp$noisefilter.trim ), silent =TRUE  )
    if ( ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
      test = try( interpolate.xy.robust( sm[aoi,], method=bcp$noisefilter.smoother,
        target.r2=(bcp$noisefilter.target.r2-0.1), trim=bcp$noisefilter.trim ), silent =TRUE  )
    }
    if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
      kk = x$depth[aoi] - test
      i = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=TRUE )
      if (length(i) > 0) good[aoi[i]] = TRUE
      x$Z = x$depth
      x$Z[!good] = NA

      sm$Z[!good] = NA
      test = try( interpolate.xy.robust( cbind( sm[aoi,"ts"], test), method=bcp$noisefilter.smoother, # yes smooth again on the smoothed
         target.r2=(bcp$noisefilter.target.r2), trim=bcp$noisefilter.trim ), silent =TRUE  )
      if ( ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
        test = try( interpolate.xy.robust( sm[aoi,], method=bcp$noisefilter.smoother,
          target.r2=(bcp$noisefilter.target.r2-0.1), trim=bcp$noisefilter.trim ), silent =TRUE  )
      }
      if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
        kk = x$depth[aoi] - test
        i = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=TRUE )
        j = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
        if (length(i) > 0) good[aoi[i]] = TRUE
        if (length(j) > 0) good[aoi[j]] = FALSE
        x$Z = x$depth
        x$Z[!good] = NA
        sm$Z =NA
        sm$Z[aoi] = test
      }
    }
    # last resort: loess
    if ( ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
      # reset sm ... and do a simple loess
      sm = x[, c("ts", "Z")]
      sm$Z[ range(aoi) ] = min( x$depth[aoi], na.rm=TRUE )   # force terminal points to be the most shallow
      test = try( interpolate.xy.robust( cbind( sm[aoi,"ts"], test), method="loess", # yes smooth again on the smoothed
         target.r2=(bcp$noisefilter.target.r2), trim=bcp$noisefilter.trim ), silent =TRUE  )
      if ( ! ( class( test ) %in% "try-error" | ( length( which(is.finite(test))) < 30)  ) ) {
          kk = x$depth[aoi] - test
          i = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=TRUE )
          j = which.quantile ( kk, probs=bcp$noisefilter.quants, inside=FALSE )
          if (length(i) > 0) good[aoi[i]] = TRUE
          if (length(j) > 0) good[aoi[j]] = FALSE
          x$Z = x$depth
          x$Z[!good] = NA
          sm$Z =NA
          sm$Z[aoi] = test
      }
    }

    if(debug) {
      plot( depth~ ts, x, pch=20, col="black", cex= 0.5, ylim=rev(range(x$depth, na.rm=T)) )
      points( Z ~ ts, x, pch=20, col="red", cex=0.8 )
      points ( Z ~ ts, sm, col="green")
      lines ( Z ~ ts, sm[aoi,], col="orange", lwd=3)
      browser()
    }

  return( list( depth.smoothed=sm$Z, good=good, depth.filtered=x$Z ) )
}


library(sf)
# library(parallel)
library(data.table)
# library(dplyr)
# library(igraph)
# source("~/Dropbox/git/postgis/postgis_functions.r")

##### 1. Lookup table for competitors based on the comparison catchments #################################################################################
comparison_catch1 <- fread("~/Dropbox/liverpool/catchments/catchments2/comparison/results/final/huff_probs.csv")[,.(cluster_id, oa11)]
comparison_catch2 <- fread("~/Dropbox/liverpool/catchments/catchments2/comparison/results/final/iso_catch_lookup_oas.csv")
comparison_catch <- unique(rbindlist(list(comparison_catch1, comparison_catch2)))
lookup_comp <- comparison_catch[comparison_catch, on = "oa11", allow.cartesian = T]
lookup_comp_a <- lookup_comp[cluster_id != i.cluster_id, .(cluster_id,i.cluster_id)]
lookup_comp_b <- lookup_comp_a[, .(i.cluster_id, cluster_id)]
setnames(lookup_comp_b, names(lookup_comp_b), names(lookup_comp_b)[2:1])
lookup_comp2 <- unique(rbindlist(list(lookup_comp_a, lookup_comp_b)))
fwrite(lookup_comp2, "~/Dropbox/liverpool/catchments/catchments2/comparison/results/final/competitors_lookup.csv")

##### 2. Lookup table for competitors based on the convenience catchments ################################################################################

convenience_catch <- fread("~/Dropbox/liverpool/catchments/catchments2/convenience/results/final/huff_probs.csv")[,.(cluster_id, oa11)]
convenience_catch <- unique(rbindlist(list(convenience_catch, comparison_catch)))
lookup_conv <- convenience_catch[convenience_catch, on = "oa11", allow.cartesian = T]
lookup_conv_a <- lookup_conv[cluster_id != i.cluster_id, .(cluster_id,i.cluster_id)]
lookup_conv_b <- lookup_conv_a[, .(i.cluster_id, cluster_id)]
setnames(lookup_conv_b, names(lookup_conv_b), names(lookup_conv_b)[2:1])
lookup_conv2 <- unique(rbindlist(list(lookup_conv_a, lookup_conv_b)))
lookup_conv2 <- lookup_conv2[! cluster_id %in% unique(comparison_catch$cluster_id), ]
fwrite(lookup_conv2, "~/Dropbox/liverpool/catchments/catchments2/convenience/results/final/competitors_lookup.csv")

all_competitors <- unique(rbindlist(list(lookup_comp2, lookup_conv2)))

all_competitors_count <- table(all_competitors$cluster_id)
all_competitors_count <- data.table(cluster_id = names(all_competitors_count), competitors = as.integer(all_competitors_count))

boundaries <- st_read("~/Dropbox/liverpool/boundaries/new_boundaries/all_boundaries_fin.gpkg", stringsAsFactors = F)
all(boundaries$id %in% all_competitors_count$cluster_id) # F
sum(!boundaries$id %in% all_competitors_count$cluster_id) # 213

absent <- data.table(cluster_id = boundaries[!boundaries$id %in% all_competitors_count$cluster_id, ]$id, competitors = 0)

all_competitors_count <- rbindlist(list(all_competitors_count, absent))
fwrite(all_competitors_count, "~/Dropbox/liverpool/retail_typology/data/competitors_count.csv")
fwrite(all_competitors, "~/Dropbox/liverpool/retail_typology/data/lookup_competitors.csv")

##### 3. Agreggate probs per LSOA, MSOA ##################################################################################################################

# lsoa <- st_read("~/Dropbox/liverpool/GIS_Data/LSOAs_2011/LSOA_2011_EW_BFC_V2.shp", stringsAsFactors = F)
# msoa <- st_read("~/Dropbox/liverpool/GIS_Data/MSOAs_2011/MSOA_2011_EW_BFC_V2.shp", stringsAsFactors = F)

lookup_scotland <- fread("~/Dropbox/liverpool/GIS_Data/lookup/oa_dz_iz_council_scotland.csv")[,.(OutputArea, DataZone, InterZone)]
setnames(lookup_scotland, names(lookup_scotland), c("oa11", "lsoa11", "msoa11"))
lookup_ew <- fread("~/Dropbox/liverpool/GIS_Data/lookup/lookup.csv")[,.(OA11CD,LSOA11CD,MSOA11CD)]
setnames(lookup_ew, names(lookup_ew), c("oa11", "lsoa11", "msoa11"))

all_lookup <- rbindlist(list(lookup_ew, lookup_scotland))

conv_probs <- fread("~/Dropbox/liverpool/catchments/catchments2/convenience/results/final/huff_probs.csv")[,.(cluster_id,oa11,huff_prob)]
comp_probs <- fread("~/Dropbox/liverpool/catchments/catchments2/comparison/results/final/huff_probs.csv")[,.(cluster_id,oa11,huff_prob)]

all_probs <- rbindlist(list(conv_probs, comp_probs))
all_probs <- all_probs[, max(huff_prob), keyby = c("cluster_id", "oa11")]
all_probs[, retail_class := ifelse(cluster_id %in% comp_probs$cluster_id, "comparison", "convenience")]
setnames(all_probs, "V1", "max_huff_prob")

fwrite(all_probs, "~/Dropbox/liverpool/retail_typology/data/catchments_oa_lookup.csv")

# sanity check
unique_oas <- unique(all_probs$oa11)
# all(unique_oas[substr(unique_oas, 1, 1) == "S"] %in% lookup_scotland$OutputArea) # T
# all(unique_oas[substr(unique_oas, 1, 1) != "S"] %in% lookup_ew$OA11CD) # T
all(unique_oas %in% all_lookup$oa11) # T

all_probs <- all_lookup[all_probs, on = "oa11"]

lsoa_probs <- all_probs[, mean(max_huff_prob), keyby = c("cluster_id", "lsoa11")]
setnames(lsoa_probs, "V1", "mean_huff_prob")
msoa_probs <- all_probs[, mean(max_huff_prob), keyby = c("cluster_id", "msoa11")]
setnames(msoa_probs, "V1", "mean_huff_prob")

fwrite(lsoa_probs, "~/Dropbox/liverpool/retail_typology/data/lsoa_probs.csv")
fwrite(msoa_probs, "~/Dropbox/liverpool/retail_typology/data/msoa_probs.csv")

##### 4. Build graph from lookups ########################################################################################################################
# lookup2 <- unique(rbind(lookup, lookup_comp))
# G <- graph.edgelist(lookup2)
# G2 <- simplify(G)
# graph_list <- decompose(G2)

##### 3. Build graph from lookups ########################################################################################################################

# comp_catch <- st_read("~/Dropbox/liverpool/catchments/catchments2/comparison/results/huff2b.shp", stringsAsFactors = F)
#
# length(unique(comp_catch$cluster_id)) # 869
# conv_catch <- st_read("~/Dropbox/liverpool/catchments/catchments2/convenience/results/huff1.shp", stringsAsFactors = F)
# length(unique(conv_catch$cluster_id)) # 3477
#
# common_clusters <- unique(comp_catch$cluster_id)[unique(comp_catch$cluster_id) %in% unique(conv_catch$cluster_id)]
#
# london_clusters <- c("TC2549", "TC2691")
# "TC2691" %in% unique(comp_catch$cluster_id) # F
# "TC2691" %in% unique(conv_catch$cluster_id) # T
# edinburgh_clusters <- c("TC0131", "TC0136")
# "TC0136" %in% unique(comp_catch$cluster_id) # F
# "TC0136" %in% unique(conv_catch$cluster_id) # T
#
# # Get all the OAs that are associated with a cluster as lookup table
# clusters_oas_lookup <- unique(rbind(unique(as.data.frame(comp_catch)[,c("cluster_id", "oa11")]),
#                                     unique(as.data.frame(conv_catch)[,c("cluster_id", "oa11")]),
#                                     data.frame(cluster_id = "TC2691", oa11 = comp_catch[comp_catch$cluster_id == "TC2549", ]$oa11, stringsAsFactors = F),
#                                     data.frame(cluster_id = "TC0136", oa11 = comp_catch[comp_catch$cluster_id == "TC0131", ]$oa11, stringsAsFactors = F)))
#

# area_df <- data.frame(cluster_id = common_clusters,
#                       comp_area = unlist(mclapply(common_clusters, function(x) sum(st_area(comp_catch[comp_catch$cluster_id == x, ])) / 10^6, mc.cores = 8)),
#                       conv_area = unlist(mclapply(common_clusters, function(x) sum(st_area(conv_catch[conv_catch$cluster_id == x, ])) / 10^6, mc.cores = 8)),
#                       stringsAsFactors = F,
#                       row.names = NULL)

# comp_or_conv <- ifelse(area_df$comp_area > area_df$conv_area, "comparison", "convenience")
# table(comp_or_conv)
# # comparison convenience
# #        611         211
#
# catchment_codes <- rbind.data.frame(as.data.frame(comp_catch)[! comp_catch$cluster_id %in% common_clusters[comp_or_conv == "convenience"], c("cluster_id", "oa11")],
#                                     as.data.frame(conv_catch)[! conv_catch$cluster_id %in% c(common_clusters[comp_or_conv == "comparison"], london_clusters, edinburgh_clusters) , c("cluster_id", "oa11")],
#                                     data.frame(cluster_id = "TC2691", oa11 = comp_catch[comp_catch$cluster_id == "TC2549", ]$oa11, stringsAsFactors = F),
#                                     data.frame(cluster_id = "TC0136", oa11 = comp_catch[comp_catch$cluster_id == "TC0131", ]$oa11, stringsAsFactors = F))

# write.csv(clusters_oas_lookup, "~/Dropbox/liverpool/retail_typology/data/catchments_oa_lookup.csv", row.names = F)

##### Calculate population density ###################################################################################
# pop_dens_eng <- fread("~/My Passport/backup/Census_11/pop/density_2011.csv")
# wales_pop <- fread("~/Dropbox/liverpool/retail_typology/data/wales_population.csv", skip = 1, select = c(2,5))
# scotland_pop <- fread("~/Dropbox/liverpool/retail_typology/data/scotland_population.csv", skip = 1, select = c(1,2))
#
# sum(wales_pop$V2 %in% unique(c(unique(conv_catch$oa11), unique(comp_catch$oa11)))) # 7725


require("RColorBrewer")
require('directlabels')
library(reshape2)
library(knitr)
options(stringsAsFactors = F)
#plot mr result

df<-read.csv("~/../Dropbox/DansPaper/data/mr/mr.csv",header = T,stringsAsFactors = F)
df<-df[,c('geneid','sig_real_ci')]

#---load annotation---
gene_anno_pos<-read.table('~/../Dropbox/annotation/encode/gencode.v27.gene',header = F);gene_anno_pos<-gene_anno_pos[gene_anno_pos$V1 %in% c(paste0('chr',seq(1,22))),];gene_anno_pos$pos<-(gene_anno_pos$V3+gene_anno_pos$V4)/2;gene_anno_pos$chr<-as.numeric(sub('^...','',gene_anno_pos[,1]));gene_anno_pos$geneid<-sapply(gene_anno_pos$V5,function(x) strsplit(x,"[.]")[[1]][1]);gene_anno_pos<-gene_anno_pos[,c('geneid','chr','pos')]
gene_anno_name<-read.table('~/../Dropbox/annotation/encode/v27.anno.gene',header = F);gene_anno_name$geneid<-sapply(gene_anno_name$V2,function(x) strsplit(x,"[.]")[[1]][1]);gene_anno_name$genename<-gene_anno_name$V6;gene_anno_name<-gene_anno_name[,c('geneid','genename')]

gene_anno<-merge(gene_anno_name,gene_anno_pos,by='geneid')

#---merge annotation---
df<-merge(gene_anno,df,by=1,all=T)
df$pos_plot=df$pos

#---generate_pos---
chr_box<-as.data.frame(matrix(data=NA,nrow=22,ncol=3))
chr_df<-gene_anno[gene_anno$chr==1,]
chr_box[1,1]<-max(chr_df$pos)
chr_box[1,2]<-0
chr_box[1,3]<-chr_box[1,1]/2

for (i in 2:22){
  chr_df<-gene_anno[gene_anno$chr==i,]
  chr_box[i,1]<-max(chr_df$pos)
  chr_box[i,2]<-max(chr_df$pos)+chr_box[i-1,2]
  df[which(df$chr==i),'pos_plot']<-df[which(df$chr==i),'pos_plot']+chr_box[i,2]
  chr_box[i,3]<-chr_box[i,2]+chr_box[i,1]/2
}

#---rename cols---
colnames(df)<-c('geneid','genename','chr','pos_old','sig','pos')

#--load twas--
twas<-read.csv('~/../Dropbox/DansPaper/data/apply_gwas/ukbb_xt_Liver.csv')

pvalue.extreme <- function(z) {
  log.pvalue <- log(2) + pnorm(abs(z), lower.tail = FALSE, log.p = TRUE)
  log10.pvalue <- log.pvalue/log(10) ## from natural log to log10
  mantissa <- 10^(log10.pvalue %% 1)
  exponent <- log10.pvalue %/% 1

  logp<-log10.pvalue*-1
  return(logp)
  ##return(sprintf("p value is %1.2f times 10^(%d)",mantissa,exponent))
}
twas$logp<-pvalue.extreme(twas$zscore)

twas<-twas[,c(1,4,5,13)]
colnames(twas)<-c('geneid','beta_twas','p_twas','logp')

#--merge with twas--
df<-merge(df,twas,by='geneid')
df<-df[,c('geneid','genename','chr','pos_old','pos','beta_twas','p_twas','logp','sig')]

#---load know---
know<-read.csv('~/../Dropbox/XTSCAN/glgc/knowgenes.csv',header = T,stringsAsFactors = F)

#--gene-group--
df$group<-NA
df[df$p_twas>=0.05,'group']<-'TWAS non sig'
df[which(df$p_twas<0.05 & df$sig!='sig'),'group']<-'TWAS sig (only)'
df[which(df$p_twas<0.05 & is.na(df$sig)),'group']<-'TWAS sig (only)' #'gold3'
df[which(df$p_twas<0.05 & df$sig=='sig'),'group']<-'MR & TWAS sig'
df$genename_highlight<-ifelse((df$group=='MR & TWAS sig' & df$genename %in% c(know$genename)),df$genename,'ZZZ')
#'UQCC','TAGLN','CSNK1G3','LSM7','POLK','CELSR2','PSRC1','TDRD15'

df<-df[df$p_twas<0.50,]

#reorder legend
df$group<-as.factor(df$group)
df$group <- factor(df$group, levels = c("MR & TWAS sig", "TWAS sig (only)", "TWAS non sig"))

#plot
library(ggrepel)

#order
df<-df[order(df$genename_highlight,decreasing = T),]
df[,'genename_highlight']<-ifelse(df[,'genename_highlight']=='ZZZ',NA,df[,'genename_highlight'])

png('~/../Dropbox/DansPaper/figures/tmp/mr_manha.png',width = 1800,height = 1000,res=250)

set.seed(1)
ggplot(df, aes(x=pos, y=logp, label=genename_highlight)) +
  ylim(0,200) +
  scale_x_continuous(breaks=chr_box$V3, labels = c(as.character(seq(1,15)),' ','17','','19','','21','')) +  #x axis
  scale_y_continuous(breaks=c(1,2,3,5,10,20,30,50,100,200,300,500),trans='log10') +  #y axis
  geom_point(data = df, aes(x = pos, y = logp, color = group, fill=group, shape=group)) +
  scale_fill_manual(values = c("TWAS non sig"='grey', "MR & TWAS sig"='gold', 'TWAS sig (only)'=brewer.pal(12, "Paired")[4])) +
  scale_color_manual(values = c("TWAS non sig"='grey', "MR & TWAS sig"='black', 'TWAS sig (only)'='black')) +
  scale_shape_manual(values = c("TWAS non sig"=16, "MR & TWAS sig"=21, 'TWAS sig (only)'=21)) +

  labs(x = "Chromosome", y = "-Log(p)", title = "") +
  theme_bw() +  #rm background
  theme(panel.grid =element_blank()) +  #rm grids
  theme(legend.position= "right",legend.title = element_blank()) + #set legend

  geom_label_repel( #non overlapped labels
    size=2,
    #col='white',
    fill=rgb(255, 255, 255, 200, maxColorValue=255),
    #nudge_y=200 - df$logp[!is.na(df$genename_highlight)],
    #direction='x', #only work on Y-axis
    #nudge_x=1.5e8, #shift to the right
    segment.alpha = 0.5,  #transparent of segment
    #min.segment.length = 1e9
    #parse=T,
    box.padding=0.5,
    nudge_x=2e8,
    fontface='italic'
  )

dev.off()

#-----------bar plot-------------

png('~/../Dropbox/DansPaper/figures/tmp/mr_bar.png',width = 2000,height = 1000,res=400)
par(mfcol=c(1,4),mar=c(3,4,3,1),mgp=c(2.5,0.75,0.25))

#overall
overall<-c(length(which(df$group=='TWAS non sig')),length(which(df$group=='TWAS sig (only)')),length(which(df$group=='MR & TWAS sig')))

bar<-barplot(overall, border=F,
             #names.arg=c('TWAS non sig','TWAS sig (only)','TWAS & MR sig'),
             las=2,
             col=c('grey', brewer.pal(12, "Paired")[4],'gold'),
             main=paste0("Overall"),cex.main=0.8,
             ylim = c(0,max(overall)*1.2),
             ylab = 'N of genes',
             cex.axis = 0.8)
#label x
text(bar,seq(1,3)+0.5, srt = 30, adj= 1, xpd = TRUE, labels = c('TWAS non sig ','TWAS sig (only) ','TWAS & MR sig '), cex=0.8)
#text
text(bar,overall+100,labels = overall,cex = 0.8)

#known / additional
know_gene<-know[,'geneid']
twas_non_sig_gene<-df[df$group=='TWAS non sig','geneid']
twas_sig_gene<-df[df$group=='TWAS sig (only)','geneid']
mr_sig_gene<-df[df$group=='MR & TWAS sig','geneid']

#twas non sig
twas_non_sig<-c(length(intersect(know_gene,twas_non_sig_gene)),length(twas_non_sig_gene)-length(intersect(know_gene,twas_non_sig_gene)))

bar<-barplot(twas_non_sig , border=F ,
             #names.arg=c('TWAS non sig','TWAS sig (only)','TWAS & MR sig'),
             las=2,
             col='grey',
             main=paste0("TWAS non sig \n ",round(twas_non_sig[1]/(twas_non_sig[1]+twas_non_sig[2])*100,2),'% known genes'),cex.main=0.8,
             ylim = c(0,max(twas_non_sig)*1.2),
             ylab = 'N of genes',
             cex.axis = 0.8)
#label x
text(bar,seq(1,2)+0.5, srt = 30, adj= 1, xpd = TRUE, labels = c('Known ','Others '), cex=0.8)
#text
text(bar,twas_non_sig+max(twas_non_sig)/15,labels = twas_non_sig,cex = 0.8)

#twas sig
twas_sig<-c(length(intersect(know_gene,twas_sig_gene)),length(twas_sig_gene)-length(intersect(know_gene,twas_sig_gene)))

bar<-barplot(twas_sig , border=F ,
             #names.arg=c('TWAS non sig','TWAS sig (only)','TWAS & MR sig'),
             las=2,
             col=brewer.pal(12, "Paired")[4],
             main=paste0("TWAS sig (only) \n ",round(twas_sig[1]/(twas_sig[1]+twas_sig[2])*100,2),'% known genes'),cex.main=0.8,
             ylim = c(0,max(twas_sig)*1.2),
             ylab = 'N of genes',
             cex.axis = 0.8)
#label x
text(bar,seq(1,2)+0.5, srt = 30, adj= 1, xpd = TRUE, labels = c('Known ','Others '), cex=0.8)
#text
text(bar,twas_sig+max(twas_sig)/15,labels = twas_sig,cex = 0.8)

#mr sig
mr_sig<-c(length(intersect(know_gene,mr_sig_gene)),length(mr_sig_gene)-length(intersect(know_gene,mr_sig_gene)))

bar<-barplot(mr_sig , border=F ,
             #names.arg=c('TWAS non sig','TWAS sig (only)','TWAS & MR sig'),
             las=2,
             col='gold',
             main=paste0("TWAS & MR sig \n ",round(mr_sig[1]/(mr_sig[1]+mr_sig[2])*100,2),'% known genes'),cex.main=0.8,
             ylim = c(0,max(mr_sig)*1.2),
             ylab = 'N of genes',
             cex.axis = 0.8)
#label x
text(bar,seq(1,2)+0.5, srt = 30, adj= 1, xpd = TRUE, labels = c('Known ','Others '), cex=0.8)
#text
text(bar,mr_sig+max(mr_sig)/15,labels = mr_sig,cex = 0.8)

dev.off()


# Gamlss estimation of gene noise for each gene for COVID19

library(GEOquery)
library(edgeR)

setwd("/media/yuri/Data/home1/GNI_data/infection/DataSciRep/")

# read Series Matrix File
# samples <- getGEO(file = "GSE157103_series_matrix.txt.gz")
# OR, from the url https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE157103
samples <- getGEO("GSE157103")[[1]]

# format	Series Matrix File
samples_pData <-  pData(phenoData(samples))
samples_pData <-  samples_pData[,c(
'description', 'Sex:ch1', 'age (years):ch1', 'disease state:ch1',
'hospital-free days post 45 day followup (days):ch1', 'hospital-free days post 45 day followup (days):ch1', 'icu:ch1',
'apacheii:ch1', 'charlson score:ch1', 'sofa:ch1',  'dm:ch1', 'ventilator-free days:ch1',
'crp (mg/l):ch1', 'ddimer (mg/l_feu):ch1', 'ferritin (ng/ml):ch1', 'fibrinogen:ch1', 'lactate (mmol/l):ch1',
'procalcitonin (ng/ml):ch1'
 )]

colnames(samples_pData) <- c(
"samples", "Sex", "age", "disease", "HFD45", "stage", "icu",
"apacheii", "charlson", "sofa", "dm", "VFD",
"crp", "ddimer", "ferritin", "fibrinogen", "lactate", "procalcitonin"
)
samples_pData$age[samples_pData$age == ">89"] <- "90"
samples_pData[,c(3,8:18)] <- apply(samples_pData[,c(3,8:18)], 2, as.numeric)

samples_pData$disease[samples_pData$disease == "COVID-19"] <- 1
samples_pData$disease[samples_pData$disease == "non-COVID-19"] <- 0
samples_pData$disease <- factor(samples_pData$disease)

samples_pData$HFD45 <- as.numeric(samples_pData$HFD45)
samples_pData$stage <- "severe"
samples_pData$stage[samples_pData$HFD45 >= 26] <- "mild"
samples_pData$stage[samples_pData$disease == 0] <- "non-covid"

################################################################################
################################################################################
################################################################################
# read and process RNA counts from https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE157103

# read RNA counts from the file
# RNAcounts <- read.table("GSE157103_genes.ec.tsv.gz", header = T, comment.char = "", sep = "\t", row.names="X.symbol")
# OR, read RNA counts from the url
options(timeout = max(60*60, getOption("timeout")))
getGEOSuppFiles("GSE157103")
setwd("GSE157103/")
RNAcounts <- read.table("GSE157103_genes.ec.tsv.gz", header = T, comment.char = "", sep = "\t", row.names="X.symbol")

RNAcounts <- round(RNAcounts)
# sum(colnames(RNAcounts) != samples_pData$description)

# select only samples from COVID19 patients (non-COVID19 patients are also ICU patients, but cause of pathology is not available)
idx <- samples_pData$disease == "1"
samples_pData <- samples_pData[idx,]
RNAcounts <- RNAcounts[,idx]
rm(idx)

# For convinience put RNA counts to DGEList
DGE_RNAcounts <- DGEList(RNAcounts, samples=samples_pData )
DGE_RNAcounts <- calcNormFactors(DGE_RNAcounts)
DGE_RNAcounts$samples$offset <- log(DGE_RNAcounts$samples$lib.size*DGE_RNAcounts$samples$norm.factors)
DGE_RNAcounts$counts <- DGE_RNAcounts$counts[apply(DGE_RNAcounts$counts, 1, function(x) mean(x==0)) <= 0.05, ]

rm(RNAcounts)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
save.image("COVID19_RNAseq.Rdat")
################################################################################

# Prepare log2 CPM
library(edgeR)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("COVID19_RNAseq.Rdat")

idx <- apply(DGE_RNAcounts$counts, 1, function(x) all(x > 0) )
COVID_logCPM <- log2(sweep(DGE_RNAcounts$counts[idx,], 2, 1e-06*DGE_RNAcounts$samples$lib.size, "/"))
COVID_pheno <- DGE_RNAcounts$samples[,c("samples", "Sex", "age", "stage", "HFD45")]

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
save.image("COVID_logCPM.Rdat")


library(feather)
library(tidyverse)
# library(data.table)
library(brms)
# library(bayesplot)
# library(tidybayes)

source("../../models/stan_utility.r")

args <- commandArgs(trailingOnly = TRUE)
load_dir <- args[1]
print(load_dir)
# Call like `Rscript smod.r ../../data/cage/suite_data`
setwd(load_dir)

# setwd("/Users/wbeard/repos/perf/data/interim/")

thin <- function(df, n=4) {
  df[seq(1, nrow(df), n), ]
}

get_pis <- function(mod, all.days) {
  pi1 <- predictive_interval(mod, newdata=all.days, prob = .9)
  pi2 <- predictive_interval(mod, newdata=all.days, prob = .7)
  pi3 <- predictive_interval(mod, newdata=all.days, prob = .5)
  pi4 <- predictive_interval(mod, newdata=all.days, prob = .68)
  pi5 <- predictive_interval(mod, newdata=all.days, prob = .01)
  cbind(pi1, pi2, pi3, pi4, pi5)
}

models

mod.mod <- function(models) {
  print(exists('a', models))
  print(exists('b', models))
  models[['a']] <<- 1
  1
}
mod.mod(models)
models

models <- list()

get.formula <- function(df) {
  get.knots <- function(df) {
    ceiling(max(df$dayi) / 8)
  }

  k <- get.knots(df)
  print(paste0('pulling model with ', k, ' knots'))
  key <- paste0('k', k)
  if (!is_null(models[[key]])){
    return(models[[key]])
  }

  print(k)
  print('going...')
  form_s <- glue("y ~ s(dayi, k={k}, bs='cr')")
  f <- bf(form_s)

  models[[key]] <<- brm(f, df, chains = 0)
  models[[key]]
}

mod <- get.formula(df0)

library(glue)
k = 42
form_s <- glue("y ~ s(dayi, k={k}, bs='cr')")
bf(form_s)

get.model2 <- function(df, k.i = 42) {
  # f <- with(list(k=42), bf(y ~ s(dayi, k=k, bs='cr')))
  f <-bf(y ~ s(dayi, k=k.i, bs='cr'))
  brm(f, df, chains = 0)
}
get.model2(df0)

read.df <- function(pth) {
  df = read_feather(pth) %>% as.data.frame()
  df = df[!df$out,]
   # %>% subset(select = c("dayi"))
  df
}

# f = bf(y ~ s(dayi, k=28, bs='cr'))
# , sigma ~ rstd
f = bf(y ~ s(dayi, k=28, bs='cr'))

fn <- function(df0) {
  k = 28
  f = bf(y ~ s(dayi, k=k, bs='cr'))
  fit_empty <- brm(f, df0, chains = 0)
}
k = 28
f = bf(y ~ s(dayi, k=k, bs='cr'))

# files <- Sys.glob("suite_data/ts*")
files <- Sys.glob("br/ts*")
df0 <- read.df(files[1])

fit_empty <- brm(f, df0, chains = 0)

for (filename in files) {
  print(filename)
  df <- read.df(filename)
  print(max(df$dayi))
  # k <- get.knots(df)
  # all.days <- data.frame(dayi = seq(min(df$dayi), to = max(df$dayi)))
  #
  #
  # {
  #   sink("/dev/null");
  #   model = update(fit_empty, newdata=df, recompile = FALSE, cores = 4);
  #   sink();
  # }
  #
  # check_all_diagnostics(model$fit)
  # pi <- get_pis(model, all.days)
  # draws <- brms::posterior_predict(model, newdata = all.days)
  # draws <- thin(draws)
  #
  # fn2 = paste0('brpi/', basename(filename))
  # fn.draws = paste0('br_draws/', basename(filename))
  # print("=>")
  # print(fn2)
  # write_feather(data.frame(pi), fn2)
  # write_feather(data.frame(draws), fn.draws)

}

# fit1 = update(fit_empty, newdata=df, recompile = FALSE, cores = 4)
# fit2 = update(fit_empty, newdata=df, recompile = FALSE, cores = 4)

# marginal_effects(fit1)

# Sys.sleep(30)


theme_set(theme_bw(18))
setwd("/Users/titlis/cogsci/projects/stanford/projects/overinformativeness/experiments/9_norming_colordescription_typicality/results")
source("rscripts/helpers.r")

d = read.table(file="data/norming.csv",sep=",", header=T, quote="")
head(d)
nrow(d)
summary(d)
totalnrow = nrow(d)
d$Trial = d$slide_number_in_experiment - 1
d$Half = as.factor(ifelse(d$Trial < 19, "first","second"))
length(unique(d$workerid))

# look at turker comments
unique(d$comments)

ggplot(d, aes(rt)) +
  geom_histogram() +
  scale_x_continuous(limits=c(0,10000))

ggplot(d, aes(log(rt))) +
  geom_histogram()

summary(d$Answer.time_in_minutes)
ggplot(d, aes(Answer.time_in_minutes)) +
  geom_histogram()

ggplot(d, aes(gender)) +
  stat_count()

ggplot(d, aes(asses)) +
  stat_count()

ggplot(d, aes(age)) +
  geom_histogram()

ggplot(d, aes(education)) +
  stat_count()

ggplot(d, aes(language)) +
  stat_count()

ggplot(d, aes(enjoyment)) +
  stat_count()

d$Combo = paste(d$item,d$color,d$condition)
sort(table(d$Combo)) # how many of each? is it roughly evenly distributed?

agr = d %>%
  group_by(item,color,condition) %>%
  summarise(meanresponse = mean(response), ci.low=ci.low(response),ci.high=ci.high(response))
agr = as.data.frame(agr)
agr$YMin = agr$meanresponse - agr$ci.low
agr$YMax = agr$meanresponse + agr$ci.high

ggplot(agr, aes(x=color,y=meanresponse,color=condition)) +
  geom_point() +
  geom_errorbar(aes(ymin=YMin,ymax=YMax),width=.25) +
  facet_wrap(~item,scales="free_x")
ggsave("graphs/typicalities.pdf",height=10)

# figure out which cases have overlapping error bars in modified and unmodified condition -- wow, these turn out to be exactly the four cases with the biggest difference that i was plotting anyway (green chair, pink golfball, red stapler, pink weddingcake)
overlap = agr %>%
  group_by(item,color) %>%
  summarise(NonOverlappingMeans = (YMin[1] >= YMax[2] | YMax[1] <= YMin[2]))
overlap = as.data.frame(overlap)
overlap[overlap$NonOverlappingMeans,]

mutated = agr %>%
  mutate(Item=item,Color=color,Modification=condition,Typicality=meanresponse,CI.low=YMin,CI.high=YMax)

write.table(mutated[,c("Item","Color","Modification","Typicality","CI.low","CI.high")],file="data/typicalities.txt",sep="\t",row.names=F,col.names=T,quote=F)

# compare the "how typical is this color for an X" wording to the current "how typical is this for an X" wording
typicalities = read.table("/Users/titlis/cogsci/projects/stanford/projects/overinformativeness/experiments/8_norming_colorSize_typicality/results/data/typicalities.txt",header=T)
head(typicalities)
head(mutated)
#row.names(typicalities) = paste(typicalities$Item,typicalities$Color)
typicalities$Modification = "puretypicality"

m = merge(mutated,typicalities,all=T) %>%
  select(Item,Color,Modification,Typicality,CI.low,CI.high)
summary(m)

ggplot(m, aes(x=Color,y=Typicality,color=Modification)) +
  geom_point() +
  geom_errorbar(aes(ymin=CI.low,ymax=CI.high),width=.25) +
  facet_wrap(~Item,scales="free_x")
ggsave("graphs/typicalities_full.pdf",height=10)

library(scales)
m$rescaledTypicality = rescale(m$Typicality,to=c(.5,1))
m$Utterance = paste(m$Color,m$Item,sep="_")
m[m$Modification != "modified",]$Utterance = as.character(m[m$Modification != "modified",]$Item)
head(m)
m$Object = paste(m$Color,m$Item,sep="_")

# write the three different typicality measures to file so they can be used by model
write.table(m[m$Modification == "modified",c("Item","Color","rescaledTypicality")],file="data/typicalities_modified.txt",sep="\t",row.names=F,col.names=T,quote=F)

write.table(m[m$Modification == "unmodified",c("Item","Color","rescaledTypicality")],file="data/typicalities_unmodified.txt",sep="\t",row.names=F,col.names=T,quote=F)

write.table(m[m$Modification == "puretypicality",c("Item","Color","rescaledTypicality")],file="data/typicalities_pure.txt",sep="\t",row.names=F,col.names=T,quote=F)

# get final values for model,

write.csv(m[m$Modification != "puretypicality",c("Object","rescaledTypicality","Utterance")],file="data/typicalities.csv",row.names=F,quote=F)
write.csv(m[m$Modification != "puretypicality",c("Object","Typicality","Utterance")],file="data/typicalities_raw.csv",row.names=F,quote=F)
write.csv(m[m$Modification != "puretypicality",c("Object","Typicality","Utterance","Modification","CI.low","CI.high")],file="data/typicalities_raw_withci.csv",row.names=F,quote=F)

# figure out which cases have the greatest typicality difference between modified and unmodified versions
diffs = m %>%
  filter(Modification != "puretypicality") %>%
  group_by(Item, Color) %>%
  summarise(Diff=Typicality[1]-Typicality[2],TypicalityModified=Typicality[1],TypicalityUnmodified=Typicality[2])
diffs = as.data.frame(diffs)
row.names(diffs) = paste(diffs$Color,diffs$Item)
# cases where modified version much more typical than unmodified version:
head(diffs[order(diffs[,c("Diff")],decreasing=T),])
maxdiffitems = as.character(diffs[order(diffs[,c("Diff")],decreasing=T),]$Item)[1:4]
write.csv(diffs[order(diffs[,c("Diff")],decreasing=T),],file="data/maxdiffitems.csv",row.names=F,quote=F)
m[m$Item %in% maxdiffitems,]
# cases where unmodified version more typical than modified version:
tail(diffs[order(diffs[,c("Diff")],decreasing=T),])

# plot empirical overmodification rates for max typicality diff cases
emp = read.csv("/Users/titlis/cogsci/projects/stanford/projects/overinformativeness/experiments/7_overinf_basiclevel_biggersample/results/data/data_bda_modifiers.csv",col.names=c("gameid","trial","condition","size","color","othercolor","item","utterance"))
head(emp)

emp$TypicalityDiff = diffs[paste(emp$color,emp$item),]$Diff
emp$sufficientdimension = ifelse(substr(emp$condition,1,5) == "color","color","size")
emp$condition = gsub("(color|size)","",as.character(emp$condition))
emp$numdistractors = substr(emp$condition,1,1)
emp$numsame = substr(emp$condition,2,2)
emp$proportionsame = as.numeric(as.character(emp$numsame))/as.numeric(as.character(emp$numdistractors))
head(emp)
emp$redutterance = "color"
emp[emp$utterance == "size",]$redutterance = "size"
emp[grep("_",as.character(emp$utterance)),]$redutterance = "size_color"
emp$uttcolor = ifelse(emp$redutterance == "color", 1, 0)
emp$uttsize = ifelse(emp$redutterance == "size", 1, 0)
emp$uttsizecolor = ifelse(emp$redutterance == "size_color", 1, 0)
table(emp$uttcolor,emp$uttsize,emp$uttsizecolor)

agr = emp %>%
  filter(item %in% maxdiffitems) %>%
  group_by(item,color,sufficientdimension,TypicalityDiff) %>%
  summarise(probcolor=mean(uttcolor),ccilow=ci.low(uttcolor),ccihigh=ci.high(uttcolor),probsize=mean(uttsize),scilow=ci.low(uttsize),scihigh=ci.high(uttsize),probsc=mean(uttsizecolor),sccilow=ci.low(uttsizecolor),sccihigh=ci.high(uttsizecolor))
agr = as.data.frame(agr)
head(agr)
low = agr %>%
  select(item, color, TypicalityDiff, sufficientdimension, ccilow, scilow, sccilow) %>%
  gather(utterance,cilow,-item,-color,-TypicalityDiff, -sufficientdimension)
high = agr %>%
  select(item, color, TypicalityDiff, sufficientdimension, ccihigh, scihigh, sccihigh) %>%
  gather(utterance,cihigh,-item,-color,-TypicalityDiff, -sufficientdimension)
sp = agr %>%
  select(item, color, TypicalityDiff, sufficientdimension, probcolor, probsize, probsc) %>%
  gather(utterance,probability,-item,-color,-TypicalityDiff, -sufficientdimension)
sp$combo = paste(sp$color,sp$item)
sp$utterance = gsub("prob","",as.character(sp$utterance))
sp$ymin = sp$probability-low$cilow
sp$ymax = sp$probability+high$cihigh
head(sp)

ggplot(sp,aes(x=TypicalityDiff,y=probability,color=item,group=item)) +
  geom_point() +
  #geom_smooth(method="lm") +
  geom_line() +
  #geom_errorbar(aes(ymin=ymin,ymax=ymax)) +
  geom_text(aes(label=combo)) +
  facet_grid(sufficientdimension~utterance)
ggsave("graphs/maxtypicalitydiffcases.pdf",height=6,width=11)


#t_pulse是单次射出所需的时间
#t_pulse，随着电压频率fv的上升而改变；随着流量而改变；

#以流量为划分

#设定工作目录
setwd("D:/data")
library(xlsx)

#读取数据
eq15<-read.xlsx("t_pulse.xls", sheetName = "eject_q15", header = TRUE)
#eq27<-read.xlsx("t_pulse.xls", sheetName = "eject_q27", header = TRUE)
#eq54<-read.xlsx("t_pulse.xls", sheetName = "eject_q54", header = TRUE)
#eq180<-read.xlsx("t_pulse.xls", sheetName = "eject_q180", header = TRUE)

#保存数据
#pdf("t_pulse_eject_q15.pdf")

#设定空间位置
par(fig=c(0,1,0,1), new = F)

##################################画图--占空比k为1.5nl/min#######################
plot(eq15$fv, eq15$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Eject time t_eject (ms)", main = "Eject time in Q = 1.5nl/min", cex.lab = 1.1, cex.main = 1.2, xlim = c(0, 1050), ylim = c(0.1, 82))

#model1 = loess(eq15$X0.2 ~ eq15$fv, span = 0.8 , degree = 2)
lines(eq15$fv, eq15$X0.2,  col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

#model2 = loess(eq15$X0.3 ~ eq15$fv, span = 0.8, degree = 2)
lines(eq15$fv, eq15$X0.3, col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

#model3 = loess(eq15$X0.4 ~ eq15$fv, span = 0.8, degree = 2)
lines(eq15$fv, eq15$X0.4, col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

#model4 = loess(eq15$X0.5 ~ eq15$fv, span = 0.8, degree =2)
lines(eq15$fv, eq15$X0.5, col="#27408B", pch=24, lwd=2.5, type="b", lty=2)

#区域划线

legend("topleft", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.1, inset = .03, bty = "n")

###############画小图########
#par(fig = c(0.3,0.98,0.15,0.98), new  = TRUE)

#plot(eq15$fv, eq15$X0.2, xaxs = "i", col = 0, xlab = "0 ~ 250 Hz", ylab = "t_pulse (ms)", main = "", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 250), ylim = c(0, 1.05))

#model1 = loess(eq15$X0.2 ~ eq15$fv, span = 0.8 , degree = 2)
#lines(eq15$fv, eq15$X0.2,  col="#458B74", lwd=2.5, type="o", lty=2)

#model2 = loess(eq15$X0.3 ~ eq15$fv, span = 0.8, degree = 2)
#lines(eq15$fv, eq15$X0.3, col="#FF00FF", lwd=2.5, type="o", lty=2)

#model3 = loess(eq15$X0.4 ~ eq15$fv, span = 0.8, degree = 2)
#lines(eq15$fv, eq15$X0.4, col="#EE0000", lwd=2.5, type="o", lty=2)

#model4 = loess(eq15$X0.5 ~ eq15$fv, span = 0.8, degree =2)
#lines(eq15$fv, eq15$X0.5, col="#27408B", lwd=2.5, type="o", lty=2)

#legend("topleft", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, bty = "n", inset = .03)

#画小小图
par(fig = c(0.22,0.95,0.18,0.95), new  = TRUE)

plot(eq15$fv, eq15$X0.2, xaxs = "i", col = 0, xlab = "0 ~ 250 Hz", ylab = "t_eject (ms)", main = "", cex.lab = 1.1, cex.main = 1.2, xlim = c(0, 250), ylim = c(0, 82))

#text(120, 40, "射出时间在[0.3ms, 0.8ms]内", font = 2, col = "blue", cex = 1.3)
#text(250, 1.8, "180nl/min时突然增大", font = 2, col = "blue", cex = 1.3)

#model1 = loess(eq15$X0.2 ~ eq15$fv, span = 1.6 , degree = 2)
lines(eq15$fv, eq15$X0.2, col="#458B74", lwd=2, type="l", lty = 3)

#model2 = loess(eq15$X0.3 ~ eq15$fv, span = 1.6, degree = 2)
lines(eq15$fv,  eq15$X0.3, col="#FF00FF", lwd=2, type="l", lty = 3 )

#model3 = loess(eq15$X0.4 ~ eq15$fv, span = 1.6, degree = 2)
lines(eq15$fv, eq15$X0.4, col="#EE0000", lwd=2, type="l", lty = 3)

#model4 = loess(eq15$X0.5 ~ eq15$fv, span = 1.6, degree =2)
lines(eq15$fv, eq15$X0.5, col="#27408B", lwd=2, type="l", lty = 3)

############局部图##########
#画小小图
par(fig = c(0.35,0.9,0.35,0.9), new  = TRUE)

plot(eq15$fv, eq15$X0.2, xaxs = "i", col = 0, xlab = "0 ~ 75 Hz", ylab = "t_eject (ms)", main = "", cex.lab = 1.1, cex.main = 1.2, xlim = c(0, 75), ylim = c(0, 80))

#text(120, 40, "射出时间在[0.3ms, 0.8ms]内", font = 2, col = "blue", cex = 1.3)
#text(250, 1.8, "180nl/min时突然增大", font = 2, col = "blue", cex = 1.3)

#model1 = loess(eq15$X0.2 ~ eq15$fv, span = 1.6 , degree = 2)
lines(eq15$fv, eq15$X0.2, col="#458B74", lwd=2, type="l")

#model2 = loess(eq15$X0.3 ~ eq15$fv, span = 1.6, degree = 2)
lines(eq15$fv,  eq15$X0.3, col="#FF00FF", lwd=2, type="l")

#model3 = loess(eq15$X0.4 ~ eq15$fv, span = 1.6, degree = 2)
lines(eq15$fv, eq15$X0.4, col="#EE0000", lwd=2, type="l")

#model4 = loess(eq15$X0.5 ~ eq15$fv, span = 1.6, degree =2)
lines(eq15$fv, eq15$X0.5, col="#27408B", lwd=2, type="l")

abline(h=1, lty = 3, col = "red", lwd = 2)
#abline(h=0.3, lty = 3, col = "red", lwd = 2)
abline(h=20, lty = 3, col = "blue", lwd = 2)
abline(v=50, lty = 3, col = "green3", lwd = 2)

#legend("topleft", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, bty = "n", inset = .03)

#dev.off()


#' Regression matrix with default holiday regressors for IC
#'
#' A matrix object with the default holiday regression matrix used for the default model of
#' IC in the factional airline model fit to the weekly initial unemployment claims data
#'
#' @format A 940 x 13 matrix with regressors in each column. The first 10 columns are regular holidays:
#' \describe{
#'   \item{ny}{New Years Day Holiday}
#'   \item{mlk}{MLK Holiday}
#'   \item{president}{Presidents Day Holiday}
#'   \item{easter}{Easter Holiday}
#'   \item{memorial}{Memorial Day Holiday}
#'   \item{july4}{July 4th Holiday}
#'   \item{labor}{Labor Day Holiday}
#'   \item{columbus}{Columbus Day Holiday}
#'   \item{veteran}{Veteran's Day Holiday}
#'   \item{thanksgiving}{Thanksgiving Holiday}
#' }
#' The next 3 columns are special holidays:
#' \describe{
#'   \item{july4_wed}{July 4th falls on a Wednesday}
#'   \item{xmas_w53}{Christams falls in the 53rd week}
#'   \item{xmas_fri}{Christmas falls on a Friday}
#' }
#'
"ic_holiday_matrix"


C05AUJ Example Program Results

Root is :       0.56714
Interval searched is :  [ 0.50000, 0.90000]


library(data.table)
library(fst)
library(magrittr)
library(dtplyr)
library(ggplot2)
library(digest)

data_path <- "."

stress_macro_tbl <- data.table(hpi = c(100, 90, 85, 80), `Unemp Rate` = c(0.05, 0.07, 0.065, 0.06), `Cash Rate` = c(1.5, 2.5, 2.5, 2.5))
fst::write.fst(stress_macro_tbl,"macro_tbl/HPI-drop-20.fst")

stress_macro_tbl <- data.table(hpi = c(100, 95, 90, 90), `Unemp Rate` = c(0.05, 0.06, 0.06, 0.06), `Cash Rate` = c(1.5, 2.5, 2.5, 2.5))
fst::write.fst(stress_macro_tbl,"macro_tbl/HPI-drop-10.fst")

stress_macro_tbl <- data.table(hpi = c(100, 80, 70, 65), `Unemp Rate` = c(0.05, 0.08, 0.10, 0.09), `Cash Rate` = c(1.5, 2.75, 2.5, 2.5))
fst::write.fst(stress_macro_tbl,"macro_tbl/HPI-drop-35.fst")

stress_macro_tbl <- data.table(hpi = c(100, 105, 110, 115), `Unemp Rate` = c(0.05, 0.05, 0.05, 0.05), `Cash Rate` = c(1.5, 1.5,1.5,1.5))
fst::write.fst(stress_macro_tbl,"macro_tbl/HPI-grow-5.fst")

if(F) {
  stress_macro_tbl <- data.table(hpi = c(100, 70, 60, 50), `Unemp Rate` = c(0.05, 0.07, 0.065, 0.06), `Cash Rate` = c(1.5, 2.5, 2.5, 2.5))
  fst::write.fst(stress_macro_tbl,"macro_tbl/HPI-drop-50.fst")
}

if(F) {
  indata <- fst::read.fst("indata/normal.fst")
  nswindata <- indata[state == "NSW"]
  fst::write.fst(nswindata,"indata/NSW_only.fst")
}