#' ---
#' title: "Prior probabilities in the interpretation of 'some': analysis of binomial_nullutterance prior wonky world model predictions"
#' author: "Judith Degen"
#' date: "January 12, 2014"
#' ---

library(ggplot2)
theme_set(theme_bw(18))
setwd("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/wonky_world/results/")
source("rscripts/helpers.r")

#' get model predictions
load("data/mp-binomial_nullutterance_3coinweights.RData")
d = read.table("data/parsed_binomial_nullutterance_3coinweights_results.tsv", quote="", sep="\t", header=T)
table(d$Item)
nrow(d)
head(d)
summary(d)
d[d$Item == "ate the seeds birds" & d$QUD=="how-many" & d$Alternatives=="0_basic" & d$SpeakerOptimality == 1,]
d[d$Item == "stuck to the wall baseballs" & d$QUD=="how-many" & d$Alternatives=="0_basic" & d$SpeakerOptimality == 2 & d$WonkyWorldPrior == .5,]
mp = ddply(d, .(Item, CoinWeight, SpeakerOptimality, WonkyWorldPrior,NullUtteranceCost), summarise, PosteriorProbability=sum(PosteriorProbability))
head(mp)

# get prior expectations
priorexpectations = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/expectations.txt",sep="\t", header=T, quote="")
row.names(priorexpectations) = paste(priorexpectations$effect,priorexpectations$object)
mp$PriorExpectation = priorexpectations[as.character(mp$Item),]$expectation

# get smoothed prior probabilities
priorprobs = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/smoothed_15marbles_priors_withnames.txt",sep="\t", header=T, quote="")
head(priorprobs)
row.names(priorprobs) = paste(priorprobs$effect,priorprobs$object)
mpriorprobs = melt(priorprobs, id.vars=c("effect", "object"))
head(mpriorprobs)
row.names(mpriorprobs) = paste(mpriorprobs$effect,mpriorprobs$object,mpriorprobs$variable)
mp$AllPriorProbability = priorprobs[paste(as.character(mp$Item)),]$X15
head(mp)
summary(mp)

mp$CoinWeight = as.numeric(as.character(mp$CoinWeight))
ggplot(mp, aes(x=PriorExpectation,y=PosteriorProbability,color=as.factor(WonkyWorldPrior),shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  facet_grid(NullUtteranceCost~CoinWeight)

cw = subset(mp, !is.na(CoinWeight) & SpeakerOptimality == 2 & WonkyWorldPrior == .5)
p=ggplot(cw, aes(x=CoinWeight,y=PosteriorProbability)) +
  geom_point() +
  geom_line() +
  #scale_y_continuous(limits = c(0,.5)) +
  facet_grid(PriorExpectation~NullUtteranceCost)
#p
ggsave("graphs/posterior_3coinweights_bypriorexp.pdf",height=35,width=6)

p=ggplot(cw, aes(x=CoinWeight,y=PosteriorProbability)) +
  geom_point() +
  geom_line() +
  #scale_y_continuous(limits = c(0,.5)) +
  facet_grid(AllPriorProbability~NullUtteranceCost)
#p
ggsave("graphs/posterior_3coinweights_byallprob.pdf",height=35,width=6)

# CONTINUE HERE
#plot empirical against predicted distributions for "some"
msome = droplevels(subset(mp, Quantifier == "some"))
some =  ddply(msome, .(Item, SpeakerOptimality, PriorExpectation, Proportion, WonkyWorldPrior, NullUtteranceCost, PosteriorProbability_empirical), summarise, PosteriorProbability_predicted=sum(PosteriorProbability), PriorProbability_smoothed=sum(PriorProbability))
nrow(some)
head(some)
msome = melt(some, measure.vars=c("PosteriorProbability_empirical","PosteriorProbability_predicted","PriorProbability_smoothed"))
msome$ptype = as.factor(ifelse(msome$variable == "PosteriorProbability_empirical", "posterior (empirical)",ifelse(msome$variable == "PosteriorProbability_predicted","posterior (model)", "prior")))
head(msome)
nrow(msome)
summary(msome)

toplot = droplevels(subset(msome, SpeakerOptimality == 2 &  NullUtteranceCost == 5))#"0_basic1_lownum2_extra4_twowords5_threewords"))
nrow(toplot)
toplot$Probability = as.factor(ifelse(toplot$ptype == "prior","prior","posterior"))
toplot$Prop = factor(toplot$Proportion, levels=c("1-50","51-99","100"))
ggplot(toplot, aes(x=Prop, y=value,color=ptype, group=ptype, size=Probability)) +
  geom_point() +
  geom_line() +
  scale_size_discrete(range=c(1,2)) +
  scale_color_manual(values=c("red","blue","black")) +
  facet_wrap(WonkyWorldPrior~Item)
ggsave("graphs/model-empirical-binomial_nullutterance-howmany-2-basic-cost5.pdf",width=35,height=30)

#plot empirical against predicted expectations for "some"
load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/13_sinking-marbles-priordv-15/results/data/r.RData")
summary(r)
r$Item = as.factor(paste(r$effect, r$object))
agr = aggregate(ProportionResponse ~ Item + quantifier, data=r, FUN=mean)
#agr$CILow = aggregate(ProportionResponse ~ Item + quantifier,data=r, FUN=ci.low)$ProportionResponse
#agr$CIHigh = aggregate(ProportionResponse ~ Item + quantifier,data=r,FUN=ci.high)$ProportionResponse
#agr$YMin = agr$ProportionResponse - agr$CILow
#agr$YMax = agr$ProportionResponse + agr$CIHigh
agr$Quantifier = as.factor(tolower(agr$quantifier))
row.names(agr) = paste(agr$Item, agr$Quantifier)
mp$PosteriorExpectation_empirical = agr[paste(mp$Item,mp$Quantifier),]$ProportionResponse
mp$PriorExpectation_smoothed = mp$PriorExpectation/15

pexpectations = ddply(mp, .(Quantifier, Item, SpeakerOptimality,PriorExpectation_smoothed, WonkyWorldPrior, NullUtteranceCost, PosteriorExpectation_empirical), summarise, PosteriorExpectation_predicted=sum(CoinWeight*PosteriorProbability)/15)
head(pexpectations)
#some = pexpectations
some = droplevels(subset(pexpectations, Quantifier == "some"))

cors = ddply(some, .(SpeakerOptimality, WonkyWorldPrior, NullUtteranceCost), summarise, r=cor(PosteriorExpectation_predicted, PosteriorExpectation_empirical))
cors = cors[order(cors[,c("r")],decreasing=T),]
head(cors)

ggplot(some, aes(x=PosteriorExpectation_predicted, y=PosteriorExpectation_empirical,color=as.factor(SpeakerOptimality)))+#, shape=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
#  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(NullUtteranceCost~WonkyWorldPrior)
ggsave("graphs/model-empirical-binomial_nullutterance-expectations.pdf",width=30,height=10)

ggplot(some, aes(x=PriorExpectation_smoothed, y=PosteriorExpectation_predicted,color=as.factor(WonkyWorldPrior)))+#, shape=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth(method="lm") +
  #geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  #  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(NullUtteranceCost~SpeakerOptimality)
ggsave("graphs/model-binomial_nullutterance-expectations.pdf",width=15,height=10)

#plot empirical against predicted allCoinWeight-prbabilities for "some"
allCoinWeight = droplevels(subset(mp, CoinWeight == 15 & Quantifier == "some"))
cors = ddply(allCoinWeight, .(SpeakerOptimality, WonkyWorldPrior), summarise, r=cor(PosteriorProbability, PosteriorProbability_empirical))
cors = cors[order(cors[,c("r")],decreasing=T),]
head(cors)
# .53 correlation

ggplot(allCoinWeight, aes(x=PosteriorProbability, y=PosteriorProbability_empirical,color=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth() +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  #  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(SpeakerOptimality~NullUtteranceCost)
ggsave("graphs/model-empirical-binomial_nullutterance-allCoinWeightprobs.pdf",width=20,height=20)

#maybe COGSCI plot basis? plot  predicted allCoinWeight-prbabilities for "some" as a function of prior allCoinWeight-probabilities

ggplot(allCoinWeight, aes(x=PriorProbability, y=PosteriorProbability,color=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth() +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  #  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(NullUtteranceCost~SpeakerOptimality)
ggsave("graphs/model-binomial_nullutterance-allCoinWeightprobs.pdf",width=15,height=10)

# get empirical wonkiness posteriors
load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/11_sinking-marbles-normal/results/data/r.RData")
head(r)
nrow(r)
r$Item = as.factor(paste(r$effect,r$object))

t = as.data.frame(prop.table(table(r$Item, r$quantifier, r$response), mar=c(1,2)))
head(t)
colnames(t) = c("Item","Quantifier","NormalMarbles","Proportion")
t[t$Var1=="ate the seeds birds",]
t$Quantifier = tolower(t$Quantifier)
tail(t)
t$Wonky = as.factor(ifelse(t$NormalMarbles == "yes","false","true"))
row.names(t) = paste(t$Item, t$Quantifier, t$Wonky)

wr$PosteriorProbability_empirical = t[paste(wr$Item, wr$Quantifier, wr$Wonky),]$Proportion
head(wr)
wonky = droplevels(subset(wr, Wonky == "true"))

head(wonky)
toplot = droplevels(subset(wonky,  SpeakerOptimality == 2))

ggplot(toplot, aes(x=PriorExpectation, y=PosteriorProbability, color=Quantifier)) +
  geom_point() +
  geom_smooth() +
  facet_grid(WonkyWorldPrior~NullUtteranceCost)
ggsave(file="graphs/wonkinessplot.pdf",width=6)

cors = ddply(wonky, .(SpeakerOptimality, Quantifier, WonkyWorldPrior,NullUtteranceCost), summarise, r=cor(PosteriorProbability, PosteriorProbability_empirical))
cors = cors[order(cors[,c("r")],decreasing=T),]
head(cors,15)

wonky_all = subset(wonky, Quantifier == "all")
wonky_none = subset(wonky, Quantifier == "none")
wonky_some = subset(wonky, Quantifier == "some")

ggplot(wonky_all, aes(x=PosteriorProbability, y=PosteriorProbability_empirical, color=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(NullUtteranceCost~SpeakerOptimality)
ggsave("graphs/model-empirical-binomial_nullutterance-wonkiness_all.pdf", width=15,height=10)

ggplot(wonky_none, aes(x=PosteriorProbability, y=PosteriorProbability_empirical, color=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(NullUtteranceCost~SpeakerOptimality)
ggsave("graphs/model-empirical-binomial_nullutterance-wonkiness_none.pdf", width=15,height=10)

ggplot(wonky_some, aes(x=PosteriorProbability, y=PosteriorProbability_empirical, color=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(NullUtteranceCost~SpeakerOptimality)
ggsave("graphs/model-empirical-binomial_nullutterance-wonkiness_some.pdf", width=15,height=10)

ggplot(wonky_all, aes(x=PriorExpectation, y=PosteriorProbability, color=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth() +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(NullUtteranceCost~SpeakerOptimality)
ggsave("graphs/model-binomial_nullutterance-all-wonkiness.pdf", width=15,height=10)

ggplot(wonky_none, aes(x=PriorExpectation, y=PosteriorProbability, color=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth() +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(NullUtteranceCost~SpeakerOptimality)
ggsave("graphs/model-binomial_nullutterance-none-wonkiness.pdf", width=15,height=10)

ggplot(wonky_some, aes(x=PriorExpectation, y=PosteriorProbability, color=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth() +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(NullUtteranceCost~SpeakerOptimality)
ggsave("graphs/model-binomial_nullutterance-some-wonkiness.pdf", width=15,height=10)

save(mp, file="data/mp-binomial_nullutterance.RData")
save(wr, file="data/wr-binomial_nullutterance.RData")

########

wonky[wonky$Quantifier == "all" & wonky$PriorExpectation < 4 & wonky$Alternatives == "0_basic" & wonky$QUD == "how-many" & wonky$SpeakerOptimality == 2,]

# get model predictions for all-CoinWeight with basic alts, spopt==2, and qud==how-many
mp_some_allCoinWeight = subset(mp, Alternatives=="0_basic" & SpeakerOptimality == 2 & QUD == "how-many" & CoinWeight == 15)
head(mp_some_allCoinWeight)
nrow(mp_some_allCoinWeight)

# plot expectations for best basic model:
toplot = droplevels(subset(mp, QUD == "how-many" & Alternatives == "0_basic" & Quantifier == "some" & WonkyWorldPrior == .5))
nrow(toplot)

pexpectations = ddply(toplot, .(Item, SpeakerOptimality,PriorExpectation_smoothed, PosteriorExpectation_empirical), summarise, PosteriorExpectation_predicted=sum(CoinWeight*PosteriorProbability)/15)
head(pexpectations)
some = pexpectations#droplevels(subset(pexpectations, Quantifier == "some"))

cors = ddply(some, .(SpeakerOptimality), summarise, r=cor(PosteriorExpectation_predicted, PosteriorExpectation_empirical))
cors = cors[order(cors[,c("r")],decreasing=T),]
head(cors)

toplot = droplevels(subset(some, SpeakerOptimality == 1))
nrow(toplot)
head(toplot)

ggplot(toplot, aes(x=PriorExpectation_smoothed, y=PosteriorExpectation_predicted)) +
  geom_point(color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth(color="#00B0F6") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1), name="Prior expectation") +
  scale_y_continuous(limits=c(0,1), name="Model predicted posterior expectation")
#  geom_text(data=cors, aes(label=r)) +
#scale_size_discrete(range=c(1,2)) +
#scale_color_manual(values=c("red","blue","black"))
ggsave("graphs/model-expectations.pdf",width=5.5,height=4.5)#,width=30,height=10)
ggsave("~/cogsci/conferences_talks/_2015/2_cogsci_pasadena/wonky_marbles/paper/pics/model-expectations-binomial_nullutterance.pdf",width=5.5,height=4.5)
save(toplot, file="data/toplot-expectations.RData")

toplot_w = toplot
load("../../complex_prior/smoothed_unbinned15/results/data/toplot-expectations.RData")
toplot_r = toplot
head(toplot_w)
summary(toplot_r)
toplot_r$RSA = "regular"
toplot_w$RSA = "wonky"

# plot both rRSA and binomial_nullutterance wRSA expectation predictions in same plot
toplot = merge(toplot_r,toplot_w, all=T)
head(toplot)
nrow(toplot)
ggplot(toplot, aes(x=PriorExpectation_smoothed, y=PosteriorExpectation_predicted, shape=RSA)) +
  geom_point(color="#00B0F6") + #values=c("#F8766D", "#A3A500", "#00BF7D", "#E76BF3", "#00B0F6")
  geom_smooth(color="#00B0F6") +
  #  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1), name="Prior expectation") +
  scale_y_continuous(limits=c(0,1), name="Model predicted posterior expectation")
#  geom_text(data=cors, aes(label=r)) +
#scale_size_discrete(range=c(1,2)) +
#scale_color_manual(values=c("red","blue","black"))
#ggsave("graphs/model-expectations.pdf",width=5.5,height=4.5)#,width=30,height=10)
ggsave("~/cogsci/conferences_talks/_2015/2_cogsci_pasadena/wonky_marbles/paper/pics/model-expectations-binomial_nullutterance-regular.pdf",width=6.5,height=4.5)


#!/usr/bin/env Rscript

######################################################################################################################################
############## COMMAND LINE TO CALCULATE AND PLOT EVOLUTION OF SPECIES POPULATION  function:main.glm    ##############################
######################################################################################################################################

#### Based on Romain Lorrillière R script
#### Modified by Alan Amosse and Benjamin Yguel for integrating within Galaxy-E

#suppressMessages(library(lme4))
suppressMessages(library(ggplot2))
suppressMessages(library(speedglm))
suppressMessages(library(arm))
#suppressMessages(library(reshape))
suppressMessages(library(data.table))
suppressMessages(library(reshape2))

###########
#delcaration des arguments et variables/ declaring some variables and load arguments

args = commandArgs(trailingOnly=TRUE)
options(encoding = "UTF-8")
source(args[6],encoding="UTF-8")### chargement des fonctions / load the functions

if ( (length(args)<8) || (length(args)>9)) {
    stop("At least 5 arguments must be supplied :\n- An input dataset filtered (.tabular). May come from the filter rare species tool.\n- A species detail table (.tabular)\n- An id to fix output repository name.\n- A list of species to exclude, can be empty.\n- TRUE/FALSE to perform the glm with confidence intervals calculations.\n\n", call.=FALSE) #si pas d'arguments -> affiche erreur et quitte / if no args -> error and exit1
} else {
    Datafilteredfortrendanalysis<-args[1] ###### Nom du fichier avec extension ".typedefichier", peut provenir de la fonction "FiltreEspeceRare" / file name without the file type ".filetype", may result from the function "FiltreEspeceRare"
    tabSpecies<-args[2] ###### Nom du fichier avec extension ".typedefichier", fichier mis à disposition dans Galaxy-E avec specialisation à l'habitat des especes et si espece considérée comme indicatrice / file name without the file type ".filetype", file available in Galaxy-E containing habitat specialization for each species and whether or not they are considered as indicator
    id<-args[3]  ##### nom du dossier de sortie des resultats / name of the output folder
    spExclude <- strsplit(args [4],",")[[1]] ##### liste d'espece qu on veut exclure de l analyse  / list of species that will be excluded
    AssessIC <-args [5] ##########  TRUE ou FALSE réalise glm "standard" avec calcul d'intervalle de confiance ou speedglm sans IC bien plus rapide / TRUE or FALSE perform a "standard" glm with confidance interval or speedglm without CI much more fast
}

## creation d'un dossier pour y mettre les resultats / create folder for the output of the analyses

dir.create(paste("Output/",id,sep=""),recursive=TRUE,showWarnings=FALSE)
#cat(paste("Create Output/",id,"\n",sep=""))
dir.create(paste("Output/",id,"/Incertain/",sep=""),recursive=TRUE,showWarnings=FALSE)
#cat(paste("Create Output/",id,"Incertain/\n",sep=""))

#Import des données / Import data
tabCLEAN <- fread(Datafilteredfortrendanalysis,sep="\t",dec=".",header=TRUE,encoding="UTF-8") #### charge le fichier de données d abondance / load abundance of species
tabsp <- fread(tabSpecies,sep="\t",dec=".",header=TRUE,encoding="UTF-8")   #### charge le fichier de donnees sur nom latin, vernaculaire et abbreviation, espece indicatrice ou non / load the file with information on species specialization and if species are indicators

vars_tabCLEAN<-c("carre","annee","espece","abond")
err_msg_tabCLEAN<-"The input dataset filtered doesn't have the right format. It need to have the following 4 variables :\n- carre\n- annee\n- espece\n- abond\n"

vars_tabsp<-c("espece","nom","nomscientific","indicateur","specialisation")
err_msg_tabsp<-"\nThe species dataset filtered doesn't have the right format. It need to have the following 4 variables :\n- espece\n- nom\n- nomscientific\n- indicateur\n- specialisation\n"

check_file(tabCLEAN,err_msg_tabCLEAN,vars_tabCLEAN,4)
check_file(tabsp,err_msg_tabsp,vars_tabsp,5)

firstYear <- min(tabCLEAN$annee) #### Recupère 1ere annee des donnees / retrieve the first year of the dataset
lastYear <- max(tabCLEAN$annee)  #### Récupère la dernière annee des donnees / retrieve the last year of the dataset
annees <- firstYear:lastYear  ##### !!!! une autre variable s'appelle annee donc peut être à modif en "periode" ? ### argument de la fonction mais  DECLARER DANS LA FONCTION AUSSI donc un des 2 à supprimer
spsFiltre=unique(tabCLEAN$espece) #### Recupère la liste des especes du tabCLEAN qui ont été sélectionnée et qui ont passé le filtre / retrieve species name that were selected and then filtered before
#cat("\n\nspsFiltre\n")
tabsp=subset (tabsp, (espece %in% spsFiltre)) #### liste des espèces exclu par le filtre ou manuellement / List of species excluded manually or by the filter from the analyses
#cat("\n\ntabsp\n")
sp=as.character(tabsp$espece)  ##### liste des espece en code ou abbreviation gardées pour les analyses ### arg de la fonction  DECLARE AUSSI APRES DS FONCTION  / list of the code or abbreviation of the species kept for the analyses
#cat("\n\nsp\n")
if(length(spExclude)!=0) {
    tabCLEAN <- subset(tabCLEAN,!(espece %in% spExclude))
    tabsp <- subset(tabsp, !(espece %in% spExclude))

    cat("\n\nEspèces exclues de l'analyse :\n")
    cat(spExclude)
    cat("\n")
}
if(length(tabCLEAN$espece)==0){
    stop("There is no species left for the analyse.", call.=FALSE) #si pas plus d'espèce après filtre / if no more species after filter
}
#cat("\n\ntabsp\n")

##################
###  Do your analysis

main.glm(donneesAll=tabCLEAN,tabsp=tabsp,id=id,assessIC=AssessIC)


############################################################
# Sources_plot
#
# y - vector of years
# p - vector of annual production amounts

Sources_plot <- function(countryID='US',countrylist=c('US'),
                         datasource='BP_2012',units='mtoe',
                         conprod='consumption',percent='',
                         style='points',
                         firstyear=1965,lastyear=2011,txt=list()) {

  # TODO:  1 tonne of oil ~= 42 gigajoules
  # TODO:  1 mtoe ~= 0.042 exajoules
  divisor = 1
  if (units == 'joule') {
    divisor = 1/0.042
  }

  # Set up symbols, colors and sizes
  pch_coal = 18    # solid diamond
  pch_oil = 1      # empty circle
  pch_gas = 17     # solid triangle
  pch_nuclear = 8  # asterisk
  pch_hydro = 16   # solid circle

  color_coal = 'grey20'
  color_oil = 'grey60'
  color_gas = 'lightblue2'
  color_nuclear = 'orange1'
  color_hydro = 'royalblue1'

  color_coal_text = 'black'
  color_oil_text = 'grey50'
  color_gas_text = 'lightblue3'
  color_nuclear_text = 'orange2'
  color_hydro_text = 'royalblue3'
  color_missing_text = 'gray80'

  color_labels_text = 'black'

  color_guide_lines = 'gray90'
  color_guide_lines_lower = 'gray90'

  cex_coal = 1.5
  cex_oil = 1.2
  cex_gas = 1.2
  cex_nuclear = 1.2
  cex_hydro = 1

  lwd_coal = 1
  lwd_oil = 1.4
  lwd_gas = 1
  lwd_nuclear = 1
  lwd_hydro = 1

  # Line width must be just enough to cause histogram bars to overlap.
  # This will depend upon the width of the graphic.
  lwd = 11

  # Set up arrays of zeroes and NA's
  y = c(firstyear:lastyear)
  y_p = y + 0.5
  y_p1 = y + 1.0
  y_m = y - 0.5
  zeroes = y * 0.0
  missing = y * NA
  n_years = lastyear - firstyear + 1

  # Create data frames for each energy source:
  # 1) read in the CSV file, applying the appropriate row names
  # 2) leave out the columns for 'country', 'change' and 'share of total'
  # 3) transpose to get countries as columns, years as rows (converts to matrix)
  # 4) convert back into data frame

 filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_coal','_',conprod,'_mtoe.csv',sep='',collapse='')
  c1 = read.csv(file=filename,skip=6,na.strings=c('na'))
  c4 = c1 / divisor

  filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_oil','_',conprod,'_mtoe.csv',sep='',collapse='')
  o1 = read.csv(file=filename,skip=6,na.strings=c('na'))
  o4 = o1 / divisor

  filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_gas','_',conprod,'_mtoe.csv',sep='',collapse='')
  g1 = read.csv(file=filename,skip=6,na.strings=c('na'))
  g4 = g1 / divisor

  # NOTE:  BP ASSUMES that production = consumption for nuclear and only reports consumption
  if (units == 'joule') {
    # NOTE: 1 Watt-hour = 3600 Joules
    # NOTE: 1 Teratt-hour = 0.0036 Exajoules
    divisor = 1 / 0.0036
    filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_nuclear','_consumption_twh.csv',sep='',collapse='')
  } else {
    filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_nuclear','_consumption_mtoe.csv',sep='',collapse='')
  }
  n1 = read.csv(file=filename,skip=6,na.strings=c('na'))
  n4 = n1 / divisor

  # NOTE:  BP ASSUMES that production = consumption for hydro and only reports consumption
  if (units == 'joule') {
    # NOTE: 1 Watt-hour = 3600 Joules
    # NOTE: 1 Teratt-hour = 0.0036 Exajoules
    divisor = 1 / 0.0036
    filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_hydro','_consumption_twh.csv',sep='',collapse='')
  } else {
    filename = paste('/var/www/mazamascience.com/html/OilExport/',datasource,'_hydro','_consumption_mtoe.csv',sep='',collapse='')
  }
  h1 = read.csv(file=filename,skip=6,na.strings=c('na'))
  h4 = h1 / divisor

  # Set each energy source to zeroes
  coal = zeroes
  oil = zeroes
  gas = zeroes
  nuclear = zeroes
  hydro = zeroes

  # For every country in the list:
  #   If the country is found, add its values.

  for (cID in countrylist) {

    if (!is.null(c4[[cID]])) {
      coal = coal + c4[[cID]]
    }

    if (!is.null(o4[[cID]])) {
      oil = oil + o4[[cID]]
    }

    if (!is.null(g4[[cID]])) {
      gas = gas + g4[[cID]]
    }

    if (!is.null(n4[[cID]])) {
      nuclear = nuclear + n4[[cID]]
    }

    if (!is.null(h4[[cID]])) {
      hydro = hydro + h4[[cID]]
    }

  } # End of "for (cID in countrylist)" loop

  total = coal + oil + gas + nuclear + hydro

  # Heuristic check for 'all data missing'
  # If some of the data are missing and the rest are zero max() will return zero.
  # If all of the data are missing max() will return -Inf.
  all_data_missing = FALSE
  all_coal_missing = FALSE
  all_oil_missing = FALSE
  all_gas_missing = FALSE
  all_nuclear_missing = FALSE
  all_hydro_missing = FALSE
  if (max(coal,na.rm=TRUE) < 0.1 || max(coal,na.rm=TRUE) == -Inf) {
    all_coal_missing = TRUE
    color_coal_text = color_missing_text
  }
  if (max(oil,na.rm=TRUE) < 0.1 || max(oil,na.rm=TRUE) == -Inf) {
    all_oil_missing = TRUE
    color_oil_text = color_missing_text
  }
  if (max(gas,na.rm=TRUE) < 0.1 || max(gas,na.rm=TRUE) == -Inf) {
    all_gas_missing = TRUE
    color_gas_text = color_missing_text
  }
  if (max(nuclear,na.rm=TRUE) < 0.1 || max(nuclear,na.rm=TRUE) == -Inf) {
    all_nuclear_missing = TRUE
    color_nuclear_text = color_missing_text
  }
  if (max(hydro,na.rm=TRUE) < 0.1 || max(hydro,na.rm=TRUE) == -Inf) {
    all_hydro_missing = TRUE
    color_hydro_text = color_missing_text
  }
  if (max(total,na.rm=TRUE) < 0.1 || max(total,na.rm=TRUE) == -Inf) {
    all_data_missing = TRUE
  }

  # Make text grey if a fuel has all missing values
#  color_label_hydro = ifelse(all_hydro_missing,color_missing_text,color_labels_text)
#  color_label_gas = ifelse(all_gas_missing,color_missing_text,color_labels_text)
#  color_label_oil = ifelse(all_oil_missing,color_missing_text,color_labels_text)
#  color_label_coal = ifelse(all_coal_missing,color_missing_text,color_labels_text)
#  color_label_nuclear = ifelse(all_nuclear_missing,color_missing_text,color_labels_text)

  # Calculate percentages
  coal_pct = 100 * coal / total
  oil_pct = 100 * oil / total
  gas_pct = 100 * gas / total
  nuclear_pct = 100 * nuclear / total
  hydro_pct = 100 * hydro / total

  # Determine appropriate limits for the y-axis
  ylo = 0
  if (percent == 'pct') {
    yhi = max(c(coal_pct,oil_pct,gas_pct,nuclear_pct,hydro_pct),na.rm=TRUE)
  } else {
    yhi = max(c(coal,oil,gas,nuclear,hydro),na.rm=TRUE)
  }
  if (all_data_missing) {
    yhi = 1
  }

  ########### LOWER PLOT ###########################################

  if (style == 'points') {

    if (percent == 'pct') {

      plot(coal_pct ~ y_p,axes=FALSE,pch=pch_coal,col=color_coal_text,cex=cex_coal,lwd=lwd_coal,
                          xlim=c(1954,2012), ylim=c(ylo,yhi),
                          main='', xlab='', ylab='')
      axis(1)
      axis(4,las=0)

      # Add year guides (thin gray lines that mark the decades)
      guide_years = c(1970,1980,1990,2000,2010)
      guide_indices = c(6,16,26,36,46)
      guides = 100 + 0 * zeroes[guide_indices]
      points(guides ~ guide_years, type='h', lwd=2, col=color_guide_lines_lower)

      # The symbols for 'nuclear' and 'oil' don't look good on top of other symbols.  Plot them first.
      points(nuclear_pct ~ y_p,pch=pch_nuclear,cex=cex_nuclear,col=color_nuclear_text,lwd=lwd_nuclear)
      points(oil_pct ~ y_p,pch=pch_oil,cex=cex_oil,col=color_oil_text,lwd=lwd_oil)
      points(coal_pct ~ y_p,pch=pch_coal,cex=cex_coal,col=color_coal_text,lwd=lwd_coal)
      points(gas_pct ~ y_p,pch=pch_gas,cex=cex_gas,col=color_gas_text,lwd=lwd_gas)
      points(hydro_pct ~ y_p,pch=pch_hydro,cex=cex_hydro,col=color_hydro_text,lwd=lwd_hydro)

    } else {

      plot(coal ~ y_p,axes=FALSE,pch=pch_coal,col=color_coal_text,cex=cex_coal,lwd=lwd_coal,
                      xlim=c(1954,2012), ylim=c(ylo,yhi),
                      main='', xlab='', ylab='')
      axis(1)
      axis(4,las=0)

      # Add year guides (thin gray lines that mark the decades)
      guide_years = c(1970,1980,1990,2000,2010)
      guide_indices = c(6,16,26,36,46)
      guides = yhi + 0 * zeroes[guide_indices]
      points(guides ~ guide_years, type='h', lwd=2, col=color_guide_lines_lower)

      # The symbol for 'nuclear' is unsightly so put it on the bottom
      points(nuclear ~ y_p,pch=pch_nuclear,cex=cex_nuclear,col=color_nuclear_text,lwd=lwd_nuclear)
      points(oil ~ y_p,pch=pch_oil,cex=cex_oil,col=color_oil_text,lwd=lwd_oil)
      points(coal ~ y_p,pch=pch_coal,cex=cex_coal,col=color_coal_text,lwd=lwd_coal)
      points(gas ~ y_p,pch=pch_gas,cex=cex_gas,col=color_gas_text,lwd=lwd_gas)
      points(hydro ~ y_p,pch=pch_hydro,cex=cex_hydro,col=color_hydro_text,lwd=lwd_hydro)

    }

    leg_x = 1954
    leg_y = yhi * 1.1
    leg_xjust = 0
    leg_yjust = 1
    text = c(txt$hydro,txt$gas,txt$oil,txt$coal,txt$nuclear)
    cols = c(color_hydro_text,color_gas_text,color_oil_text,color_coal_text,color_nuclear_text)
    pchs = c(pch_hydro,pch_gas,pch_oil,pch_coal,pch_nuclear)
    pt.cexs = c(cex_hydro,cex_gas,cex_oil,cex_coal,cex_nuclear)

    #text.cols = c(color_label_hydro,color_label_gas,color_label_oil,color_label_coal,color_label_nuclear)
    text.cols = c(color_hydro_text,color_gas_text,color_oil_text,color_coal_text,color_nuclear_text)

    # Add a legend
    if (!all_data_missing) {
      legend(x=leg_x, y=leg_y, xjust=leg_xjust, yjust=leg_yjust, bty='n', bg="white",
             legend=text,col=cols,pch=pchs,pt.cex=pt.cexs,cex=1.2,text.col=text.cols)
    }

    # Now add all the labels for the bottom plot.

    # Add the title and attribution
    title(main=txt$main1,line=2,cex.main=2.0,xpd=NA)
    title(sub=txt$subtitle,line=2.5,family='Times',col=color_labels_text,xpd=NA)

    # Add the axis labels
    mtext(text=txt$year,side=1,line=0.8,cex=1.0,adj=0,xpd=TRUE)
    if (percent == 'pct') {
      mtext(text=txt$percent,side=4,line=3.0,cex=1.2,las=0,xpd=NA)
    } else {
      mtext(text=txt$units,side=4,line=3.0,cex=1.2,las=0,xpd=NA)
    }

    # Special cases
    if (all_data_missing) {
      mtext(text=txt$msg_nodata,side=3,line=0.5,cex=1.2,font=1,xpd=NA)
    }
  ########### UPPER PLOT ###########################################

  } else { # style = 'stacked'

    # Default plotting parameters
    par(las=1, lend='butt')

    # NOTE:  Missing values make stacked plots impossible.  Use 'A' as a mask.
    A = nuclear + coal + oil + gas + hydro
    B = nuclear + coal + oil + gas  + 0*A
    C = nuclear + coal + oil + 0*A
    D = nuclear + coal  + 0*A
    E = nuclear + 0*A

    ylo = 0
    yhi = max(A,na.rm=TRUE)

    A_pct = 100 * A / A
    B_pct = 100 * B / A
    C_pct = 100 * C / A
    D_pct = 100 * D / A
    E_pct = 100 * E / A

    if (percent == 'pct') {

      yhi = 100
      plot(A_pct ~ y_p,type='h',axes=FALSE,lwd=lwd,col=color_hydro,
                       xlim=c(1954,2012), ylim=c(ylo,yhi),
                       main='', xlab='', ylab='')
      axis(1)
      axis(4,las=0)

      points(B_pct ~ y_p, type='h',lwd=lwd,col=color_gas)
      points(C_pct ~ y_p, type='h',lwd=lwd,col=color_oil)
      points(D_pct ~ y_p, type='h',lwd=lwd,col=color_coal)
      points(E_pct ~ y_p, type='h',lwd=lwd,col=color_nuclear)

      # Add year guides (thin gray lines that mark the decades)
      guide_years = c(1970,1980,1990,2000,2010)
      guide_indices = c(6,16,26,36,46)
      guides = A_pct[guide_indices]
      points(guides ~ guide_years, type='h', lwd=2, col=color_guide_lines)

    } else {

      plot(A ~ y_p,type='h',axes=FALSE,lwd=lwd,col=color_hydro,
                   xlim=c(1954,2012), ylim=c(ylo,yhi),
                   main='', xlab='', ylab='')
      axis(1)
      axis(4,las=0)

      points(B ~ y_p, type='h',lwd=lwd,col=color_gas)
      points(C ~ y_p, type='h',lwd=lwd,col=color_oil)
      points(D ~ y_p, type='h',lwd=lwd,col=color_coal)
      points(E ~ y_p, type='h',lwd=lwd,col=color_nuclear)

      # Add year guides (thin gray lines that mark the decades)
      guide_years = c(1970,1980,1990,2000,2010)
      guide_indices = c(6,16,26,36,46)
      guides = A[guide_indices]
      points(guides ~ guide_years, type='h', lwd=2, col=color_guide_lines)

    }

    # Now add all the labels for the top plot.

    if (!all_data_missing) {
      if (percent == 'pct') {
        title_text = txt$percent_title
      } else {
        # Create and add the % change label in the top plot
        pct_chg = 100 * (total[n_years] - total[n_years-1]) / abs(total[n_years-1])

        if (is.na(pct_chg)) {
          pct_chg_string = '--'
        } else {
          pct_chg_string = as.character(abs(pct_chg))
          if (pct_chg >= 100) {
            pct_chg_string = strtrim(pct_chg_string,5)
          } else if (pct_chg >= 10) {
            pct_chg_string = strtrim(pct_chg_string,4)
          } else {
            pct_chg_string = strtrim(pct_chg_string,3)
          }
        }

        if (total[n_years] > total[n_years-1] ) {
          if (conprod == 'production') {
            string1 = txt$energy_produced_increased
          } else {
            string1 = txt$energy_consumed_increased
          }
        } else {
          if (conprod == 'production') {
            string1 = txt$energy_produced_decreased
          } else {
            string1 = txt$energy_consumed_decreased
          }
        }
        title_text = paste(lastyear,':',string1,pct_chg_string,'%')
      }
      title(main=title_text,line=1,cex.main=1.2,xpd=NA)
    }

    # Add the axis labels
    if (percent == 'pct') {
      mtext(text=txt$percent,side=4,line=2.5,cex=1.2,las=0,xpd=NA)
    } else {
      if (units == 'mtoe') {
        # Use something smaller than "million tonnes oil equiv." to declutter the chart.
        mtext(text='\'mtoe\'',side=4,line=2.5,cex=1.2,las=0,xpd=NA)
      } else {
        mtext(text=txt$units,side=4,line=2.5,cex=1.2,las=0,xpd=NA)
      }
    }

  }

}


# Load packages
if (!require("pacman")) install.packages("pacman")
pacman::p_load(
  data.table, janitor, magrittr, fixest, raster,
  broom, tidyverse, tidylog, stars, viridis, scales
)
options("tidylog.display" = NULL)

# load mask and data
water_mask = read_stars("data/raw/grace/LAND_MASK.CRI.nc")
water = read_stars("data/raw/grace/GRCTellus.JPL.200204_202108.GLO.RL06M.MSCNv02CRI.nc") %>%
  slice(time, 1)

# mask the data
water[water_mask == 0] = NA

# plot the single layer above
ggplot() +
  geom_stars(data = water) +
  scale_fill_gradient2(
    name = "Whatever the\ndata are",
    low = "#b2182b", mid = "#ffffef", high = "#2166ac",
    midpoint = 0, space = "Lab", na.value = "#ffffff",
    guide = guide_colourbar(
      ticks.linewidth = 2,
      ticks.colour = "#333333",
      frame.colour = "#333333",
      frame.linewidth = 2
    ),
    aesthetics = "fill",
    trans = "pseudo_log",
    breaks = c(-400, 0, 400),
    limits = c(-400, 400)
  ) +
  theme_minimal() +
  theme(
    axis.title = element_blank(),
    panel.grid = element_blank(),
    axis.text = element_blank(),
    text = element_text(family = "Lato"),
    legend.title = element_text(size = 30),
    legend.text = element_text(size = 30),
    legend.key.width = unit(1, "cm"),
    legend.key.height = unit(1.5, "cm")
  )

ggsave("output/water_test.png", width = 20, height = 10)


#! /usr/bin/env Rscript

library(VariantAnnotation)

args <- commandArgs(TRUE)
parseArgs <- function(x) strsplit(sub("^--", "", x), "=")
argsL <- as.list(as.character(as.data.frame(do.call("rbind", parseArgs(args)))$V2))
names(argsL) <- as.data.frame(do.call("rbind", parseArgs(args)))$V1
args <- argsL;rm(argsL)

if(is.null(args$vcf)) {stop("no input VCF file")} else {vcf = args$vcf}
if(is.null(args$chunk_size)) {chunk_size = 10000} else {chunk_size = as.numeric(args$chunk_size)}
if(is.null(args$output_vcf)) {output_vcf=gsub(".vcf.gz","_addVCFfeatures.vcf",vcf)} else {output_vcf=args$output_vcf}

#initiate the first chunk
vcf_con <- open(VcfFile(vcf,  yieldSize=chunk_size))
vcf_chunk = readVcf(vcf_con, "hg19")

#and continue
while(dim(vcf_chunk)[1] != 0) {
  # get DP
  DP_matrix = geno(vcf_chunk,"DP")

  # compute median DP
  median_DP = apply(DP_matrix, 1, function(x){ median(x) })

  #annotate the header of the chunk
  info(header(vcf_chunk))["medianDP",]=list("1","Float","Median DP over all samples")

  #annotate the chunk with computed values
  info(vcf_chunk)[,"medianDP"] = median_DP

  #write out the annotated VCF
  con = file(output_vcf, open = "a")
  writeVcf(vcf_chunk, con)
  vcf_chunk = readVcf(vcf_con, "hg19")
  close(con)
}


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(patchwork))

source("viz_themes.R")
source("plotting_functions.R")
source("data_functions.R")

output_figure_base <- file.path("figures", "supplementary", "supfigure9")
extensions <- c(".png", ".pdf")

results_dir <- file.path("..", "3.clustering-pca", "results")

metric_all_df <- load_clustering_metrics(results_dir)

print(dim(metric_all_df))
head(metric_all_df)

panel_a_gg <- (
    ggplot(metric_all_df, aes(x = cluster, y = metric_value, color = assay, group = assay))
    + geom_point()
    + geom_line()
    + facet_wrap("~metric", scales = "free_y")
    + scale_color_manual("Assay", values = assay_colors)
    + figure_theme
    + ylab("Metric")
    + xlab("Cluster (k)\nK-means clustering")
    + labs(tag = "a")
)

panel_a_gg

metric_dose_df <- load_clustering_metrics(results_dir, file_suffix="")

metric_dose_df$dose <- dplyr::recode_factor(paste(metric_dose_df$dose), !!!recode_dose_factor_controls)

print(dim(metric_dose_df))
head(metric_dose_df)

panel_b_gg <- (
    ggplot(metric_dose_df, aes(x = cluster, y = metric_value, color = assay, group = assay))
    + geom_point(size = 0.5)
    + geom_line(lwd = 0.3)
    + facet_grid("metric~dose", scales = "free_y")
    + scale_color_manual("Assay", values = assay_colors)
    + figure_theme
    + ylab("Metric")
    + xlab("Cluster (k)\nK-means clustering")
    + labs(tag = "b")
    + theme(
        strip.text.y = element_text(size = 4)
    )
)

panel_b_gg

# Load BIC scores
metric_bic_df <- load_clustering_metrics(results_dir, clustering = "gmm")

metric_bic_df$dose <- dplyr::recode_factor(paste(metric_bic_df$dose), !!!recode_dose_factor_controls)

print(dim(metric_bic_df))
head(metric_bic_df)

panel_c_gg <- (
    ggplot(metric_bic_df, aes(x = cluster, y = metric_value, color = assay, group = assay))
    + geom_point(size = 0.5)
    + geom_line(lwd = 0.3)
    + facet_grid("metric~dose", scales = "free_y")
    + scale_color_manual("Assay", values = assay_colors)
    + figure_theme
    + ylab("Metric")
    + xlab("Cluster (k)\nGaussian mixture model")
    + labs(tag = "c")
    + theme(
        strip.text.y = element_text(size = 6)
    )
)

panel_c_gg

sup_fig9_gg <- (
    panel_a_gg / panel_b_gg / panel_c_gg
) + plot_layout(heights = c(1, 0.75, 0.4))

sup_fig9_gg

for (extension in extensions) {
    output_file <- paste0(output_figure_base, extension)
    ggplot2::ggsave(output_file, sup_fig9_gg, height = 7.5, width = 7, dpi = 500)
}


source("src/0a_setup.r")
source("src/1_functions.r")

system.time(indata[, risk_grade_to := apply_transition(risk_grade, transition_table)])
indata[order(risk_grade),.N,risk_grade]
indata[order(risk_grade),.N,risk_grade_to]

set.seed(1)
indata[order(risk_grade),.N, risk_grade]
indata[,mean(value)]

indata[,sum(curr_bal)]
system.time(indata2 <- indata %>%
              simulate_one_period(1, stress_macro_tbl) %>% {.$indata} %>%
              simulate_one_period(2, stress_macro_tbl) %>% {.$indata} %>%
              simulate_one_period(3, stress_macro_tbl) %>% {.$indata}
)
indata2[,sum(curr_bal)]
indata2[order(risk_grade),.N, risk_grade]
indata2[,.N]
indata2[,.N,default]
indata2[,mean(value)]

indata[,.N,default]
indata[,.N]
indata2 <- default_transition(indata)
indata2[,.N,default]
indata2[,.N]


## this code is analysing MWM data, works if the platform is on the SW quadrant

##get mouse data
testing=T
datapath="Y:/AOCF-User Projects/1412_Rosenmund_VGlut1-KI"

if (testing){
  library(xtable)
  options(xtable.comment = FALSE)
  library(rmarkdown)
  source("Rfiles/FUNCTIONs.R")

  userprojectfolder=datapath
  IF <- read.csv(paste(userprojectfolder,"8_computerisable_files/initial_form.csv", sep="/"), sep=";",colClasses=c(NA, NA, "NULL"))
  Initiation_form = as.data.frame(t(IF[-1]))
  names(Initiation_form)= IF[,1]
  Initiation_form$projectlagesoid

  source("Rfiles/get_mouse_data.R")

}

data= read.csv("C:/Users/AG_Winter/Desktop/20150706_MWM/concenatedfile_onlysum.csv", sep=";")

##
#get group data in the data file
grouping =as.character(data$animalID)

for (i in c(1: length(grouping))){
  grouping [i]= as.character(animalsproj$strain [animalsproj$animal.ID== grouping [i]])
}
data$group= factor(grouping)

###data analysis:

###latency to the platform
data$latency= data$Zone..Target.Visit.latency..s.
data$Zone..Target.Duration..s. == 0
data$latency[data$latency == 0 & data$Zone..Target.Duration..s. == 0]= NA
#add one second between mouse on water and click start
data$latency =data$latency+1

###latency to the quadrant
data$latencyQ= data$Zone..SW.Visit.latency..s.
#get NA when never reached
data$latencyQ[data$latencyQ == 0 & data$Zone..SW.Duration..s.==0]= NA
# get latency to target zone if smaller#
for (i in c(1: nrow(data))){
  data$latencyQ[i]= min (data$latencyQ[i],data$latency[i], na.rm=TRUE)
}

###proportion time spent in the target quadrant
data$SWQtime = data$Zone..SW.Duration..s.+data$Zone..Target.Duration..s.
data$propright = 100*data$SWQtime/(data$SWQtime+data$Zone..SE.Duration..s.+data$Zone..NW.Duration..s.+data$Zone..NE.Duration..s.)

###Start plotting

#subset training data
dataori=data
data = dataori[grepl("training",dataori$Short.description),]

boxpl_OF(data,aes(x=Short.description ,y= latency, fill=group),"latency to enter platform [s]",paste0("latency to platform"))
boxpl_OF(data,aes(x=Short.description ,y= latencyQ, fill=group),"latency to enter quadrant [s]",paste0("latency to quadrant"))
boxpl_OF(data,aes(x=Short.description ,y= propright, fill=group),"proportion of time in SW quadrant",paste0("time on right quadrant"))

data = dataori[grepl("test",dataori$Short.description),]

boxpl_OF(data,aes(x=Short.description ,y= latency, fill=group),"latency to enter platform [s]",paste0("latency to platform"))
boxpl_OF(data,aes(x=Short.description ,y= latencyQ, fill=group),"latency to enter quadrant [s]",paste0("latency to quadrant"))
boxpl_OF(data,aes(x=Short.description ,y= propright, fill=group),"proportion of time in SW quadrant",paste0("time on right quadrant"))


#library(testthat)

################################################################################
context("Test Ship Information Calculations")
################################################################################

#Test calcTier
test_that("calcTier works",
          {
            #create test benchmark
            testTierDF<- data.frame(
              engineType=rep(c("SSD","MSD","MSD-ED","LNG","GT","ST","GT-ED"),4),
              keelLaidYear=rep(c(1999,2005,2014,2017),each=7),
              shipCategory=rep(3,28),
              tier=c(rep("Tier 0",7),
                     rep("Tier 1",3),rep("Tier 0",4),
                     rep("Tier 2",3),rep("Tier 0",4),
                     rep("Tier 3",3),rep("Tier 0",4)
              )
            )

            #run calculation
            testTierDF$newTier<-calcTier(engineType = testTierDF$engineType,
                                         keelLaidYear = testTierDF$keelLaidYear,
                                         shipCategory = testTierDF$shipCategory)

            #compare output against benchmark
            expect_equal(testTierDF$newTier,as.factor(testTierDF$tier))
          }
)

#calcTestIMO====================================================================
test_that("calcTestIMO works",
          {
            #Create benchmark
            testIMODF<-data.frame(IMO = c(6605022,7417159,9999999,0,3254,NA),
                                  IMOFlag=c("Correct","Correct","Incorrect","Incorrect","Incorrect","Incorrect")
            )
            #run calculation
            testIMODF$NewIMOFlag<-calcTestIMO(IMO = testIMODF$IMO)

            #compare output against benchmark
            expect_equal(testIMODF$NewIMOFlag,as.factor(testIMODF$IMOFlag))
          }
)

#calcShipCategory===============================================================

test_that("calcShipCategory works",
          {
            # Create Benchmark
            testShipCategory<-c(rep(3,4),
                                rep(2,4),
                                rep(1,4)
            )

            #Run Calculation
            testShipCategory_out<-calcShipCategory(mainEngineBore = c(320,500,420,400,
                                                                      280,250,270,300,
                                                                      165,142,190,152
            ),
            mainEngineStroke = c(440,2000,1764,460,
                                 390,320,380,300,
                                 137,128,165,128
            )
            )

            #compare output against benchmark
            expect_equal(testShipCategory_out,
                         testShipCategory
            )
          }
)

#calcEngineType================================================================

test_that("calcEngineType works for Main Engines",
          {
            #create benchmark
            testEngineType<- c("MSD","SSD","SSD","MSD-ED","SSD","MSD-ED","ST","ST","ST","GT","GT","GT")

            #Run Calculation
            testEngineType_out<-calcEngineType(propulsionType = rep(c("Oil Engine(s), Direct Drive",
                                                                      "Oil Engine(s), Electric Drive",
                                                                      "Steam Recip(s), Direct Drive",
                                                                      "Gas Turbine(s), Geared Drive"
            ),
            each=3
            ),
            mainEngineStrokeType = rep(c(4,2,NA),4),
            mainEngineRPM = c(NA,NA,350,NA,NA,600,450,NA,500,NA,NA,NA)
            )

            #compare output against benchmark
            expect_equal(testEngineType_out,
                         testEngineType
            )
          }
)

test_that("calcEngineType works for Aux Engines",
          {
            #create benchmark
            testEngineType<- rep("MSD",12)

            #Run Calculation
            testEngineType_out<-calcEngineType(propulsionType = rep(c("Oil Engine(s), Direct Drive",
                                                                      "Oil Engine(s), Electric Drive",
                                                                      "Steam Recip(s), Direct Drive",
                                                                      "Gas Turbine(s), Geared Drive"
                                                                      ),
                                                                    each=3
                                                                    ),
                                               main_aux_boiler = "aux"
                                               )

            #compare output against benchmark
            expect_equal(testEngineType_out,
                         testEngineType
            )
          }
)

test_that("calcEngineType works for Boiler Engines",
          {
            #create benchmark
            testEngineType<- rep("Boiler",12)

            #Run Calculation
            testEngineType_out<-calcEngineType(propulsionType = rep(c("Oil Engine(s), Direct Drive",
                                                                      "Oil Engine(s), Electric Drive",
                                                                      "Steam Recip(s), Direct Drive",
                                                                      "Gas Turbine(s), Geared Drive"
                                                                      ),
                                                                    each=3
                                                                    ),
                                               main_aux_boiler = "boiler"
                                               )

            #compare output against benchmark
            expect_equal(testEngineType_out,
                         testEngineType
            )
          }
)

test_that("calcEngineType works for mix of Main, Aux, and Boiler Engines",
          {
            #create benchmark
            testEngineType<- c("MSD","SSD","SSD","MSD-ED","SSD","MSD-ED",rep("MSD",3),rep("Boiler",3))

            #Run Calculation
            testEngineType_out<-calcEngineType(propulsionType = rep(c("Oil Engine(s), Direct Drive",
                                                                      "Oil Engine(s), Electric Drive",
                                                                      "Steam Recip(s), Direct Drive",
                                                                      "Gas Turbine(s), Geared Drive"
                                                                      ),
                                                                    each=3
                                                                    ),
                                               mainEngineStrokeType = rep(c(4,2,NA),4),
                                               mainEngineRPM = c(NA,NA,350,NA,NA,600,450,NA,500,NA,NA,NA),
                                               main_aux = c(rep("main",6),rep("aux",3),rep("boiler",3))
                                               )

            #compare output against benchmark
            expect_equal(testEngineType_out,
                         testEngineType
            )
          }
)


args = commandArgs(trailingOnly=TRUE)
if (length(args) < 2) {
  stop("Usage: postprocessing.r <base.path>", call.=FALSE)
}

base.path <- args[1]

# Parts of the function is taken from Seurat's Read10x parsing function
ReadAlevin <- function( base.path = NULL ){
    if (! dir.exists(base.path )){
      stop("Directory provided does not exist")
    }

    barcode.loc <- paste0( base.path, "alevin/quants_mat_rows.txt" )
    gene.loc <- paste0( base.path, "alevin/quants_mat_cols.txt" )
    matrix.loc <- paste0( base.path, "alevin/quants_mat.csv" )
    if (!file.exists( barcode.loc )){
      stop("Barcode file missing")
    }
    if (! file.exists(gene.loc) ){
      stop("Gene name file missing")
    }
    if (! file.exists(matrix.loc )){
      stop("Expression matrix file missing")
    }
    matrix <- as.matrix(read.csv( matrix.loc, header=FALSE))
    matrix <- t(matrix[,1:ncol(matrix)-1])

    cell.names <- readLines( barcode.loc )
    gene.names <- readLines( gene.loc )

    colnames(matrix) <- cell.names
    rownames(matrix) <- gene.names
    matrix[is.na(matrix)] <- 0
    return(matrix)
}

require("seurat")

alv.data <- ReadAlevin(base.path)
dat <- CreateSeuratObject(raw.data = alv.data, min.cells = 3, min.genes = 200, project = "10X_rnaseq")
dat <- NormalizeData(object = dat, normalization.method = "LogNormalize", scale.factor = 10000)
dat <- FindVariableGenes(object = dat, mean.function = ExpMean, dispersion.function = LogVMR, x.low.cutoff = 0.0125, x.high.cutoff = 3, y.cutoff = 0.5)
dat <- ScaleData(object = dat)
dat <- RunPCA(object = dat, pc.genes = dat@var.genes, do.print = TRUE, pcs.print = 1:5, genes.print = 5)
dat <- FindClusters(object = dat, reduction.type = "pca", dims.use = 1:10, resolution = 0.6, print.output = 0, save.SNN = TRUE)
dat <- RunTSNE(object = dat, dims.use = 1:10, do.fast = TRUE)
TSNEPlot(object = dat)


# 1. Get states with more then 75% urban population and the rape var over 20.
# 2. Get states where urban population is over 75% or rape is over 20
# Import dataset
u <- USArrests

# urbanandrape <- urban[any(urban[,4] > 20)]
ex1 <- u[which(u[,3] > 75 & any(u[,3] > 20)), ]

ex2 <- u[which(u[,4] > 75 | u[,4] > 20), ]


args=commandArgs(T)
cutOff<-as.numeric(args[1])

library(Matrix)
library(parallel)
corces2016Data<-readRDS("../input/corces2016-snap-full.rds")
labels<-read.table("../input/corces2016_barcode_metadata.tsv",header = TRUE,sep = "\t",check.names = FALSE)

labels<-labels[labels$barcode %in% rownames(corces2016Data),]

func<-function(label){
    barcode<-labels[labels$label == label,]$barcode
    cell_data<-corces2016Data[rownames(corces2016Data) %in% barcode,]
    nonZeroColumnList_cell<-diff(cell_data@p)/nrow(cell_data)
    candidateRange<-which(nonZeroColumnList_cell>=cutOff)
    for(i in candidateRange){
        cell_data[,i] = 1
    }
    return(cell_data)
}

cl.cores <- detectCores()
cl <- makeCluster(cl.cores-1,type = "FORK")
results <- parLapply(cl, levels(labels$label),  func)
enhanced_corces2016Data<-do.call('rbind',results)
stopCluster(cl)
saveRDS(enhanced_corces2016Data,file = paste0('../output/corces2016-snap-full_enh',cutOff,'.rds'))
print(paste0(cutOff,' is finished'))


# RUN:
# export RSTUDIO_WHICH_R=/mnt/ssd0_sys/R-patched/bin/R rstudio &

# to x = f(t)
# https://www.datanovia.com/en/lessons/select-data-frame-columns-in-r/
# BUG: https://github.com/tidyverse/readr/issues/919
#
# R shared library (/usr/local/lib/R/lib/libR.so) not found. If this is a
# custom build of R, was it built with the --enable-R-shlib option?

# ./configure --enable-R-shlib
#
# wget https://download1.rstudio.org/rstudio-xenial-1.1.463-amd64.deb
# wget wget http://download1.rstudio.org/rstudio-1.0.153-amd64.deb
# R version 3.2.3 (2015-12-10) -- "Wooden Christmas-Tree"
# sudo apt-get install xorg-dev
# wget https://cran.r-project.org/src/base-prerelease/R-patched_2018-12-04_r75765.tar.gz
# rstudio: /usr/lib/x86_64-linux-gnu/libstdc++.so.6: version `GLIBCXX_3.4.20' not found (required by rstudio)
#install.packages("readr")
#install.packages("haven")
#install.packages("tidyverse")  # looooong time

# our data
library(tidyverse)
library(forecast)

#install.packages("forecast")

fn <- '/tmp/ttttttt.csv'
df <- read.table(fn, header = TRUE, sep = ",")

#my_data <- as_tibble(df)

t_to_x_df <- df %>% select("T", "Y")

acf(t_to_x_df, lag.max=20)
pacf(t_to_x_df, lag.max=8)  # нужно знать длину

# https://stackoverflow.com/questions/43622486/time-series-forecasting-in-r-univariate-time-series
pricearima <- ts(t_to_x_df)#, frequency = 12)
#adenoTS = ts(adeno)
arima_fit = auto.arima(pricearima[,1])
#fitlnstock<-auto.arima(pricearima)

forecastedvalues_ln=forecast(arima_fit,h=26)
plot(forecastedvalues_ln)

air <- window(ts(t_to_x_df))#, start=1990)
fc <- holt(air[,1], h=5)
air <- air[,1]

fc <- holt(air, h=15)
fc2 <- holt(air, damped=TRUE, phi = 0.9, h=15)
autoplot(air) +
  autolayer(fc, series="Holt's method", PI=FALSE) +
  autolayer(fc2, series="Damped Holt's method", PI=FALSE) +
  ggtitle("Forecasts from Holt's method") + xlab("Year") +
  ylab("Air passengers in Australia (millions)") +
  guides(colour=guide_legend(title="Forecast"))


#!/usr/bin/env Rscript

# this is a helper function to create a library charactrization file
require(intervals)
ppmCal<-function(run,ppm)
{
  return((run*ppm)/1000000)
}
IntervalMerge<-function(cameraObject,MSMSdata,libraryInfo,ppm,listOfMS2Mapped=list(),listOfUnMapped=list(),whichmz=NA,requiredHeader=NA){

  if(whichmz=="c")
  {

listofPrecursorsmz<-libraryInfo[,requiredHeader["mzCol"]]

CameramzColumnIndex<-which(colnames(cameraObject@groupInfo)=="mz")

MassRun1<-Intervals_full(cbind(listofPrecursorsmz,listofPrecursorsmz))

MassRun2<-Intervals_full(cbind(cameraObject@groupInfo[,CameramzColumnIndex]-
                                 ppmCal(cameraObject@groupInfo[,CameramzColumnIndex],ppm),
                               cameraObject@groupInfo[,CameramzColumnIndex]+
                                 ppmCal(cameraObject@groupInfo[,CameramzColumnIndex],ppm)))

imatch <- interval_overlap(MassRun1,MassRun2)
returnData<-c()
for (i in 1:length(imatch)) {
  for(j in imatch[[i]])
  {
    startRT<-cameraObject@groupInfo[c(j),"rtmin"]
    endRT<-cameraObject@groupInfo[c(j),"rtmax"]
    startMZ<-cameraObject@groupInfo[c(j),"mzmin"]
    endMZ<-cameraObject@groupInfo[c(j),"mzmax"]
    centermz<-cameraObject@groupInfo[c(j),"mz"]
    centerrt<-cameraObject@groupInfo[c(j),"rt"]
    intensity<-cameraObject@groupInfo[c(j),"into"]
    fileName<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){attr(x,"fileName")}),collapse = ";")

    ID<-libraryInfo[i,requiredHeader["compundID"]]
    Name<-libraryInfo[i,requiredHeader["compoundName"]]
    nmass<-libraryInfo[i,requiredHeader["mzCol"]]

    parentmzs<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){x@precursorMz}),collapse=";")
    parentrts<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){x@rt}),collapse=";")
    parentInts<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){x@precursorIntensity}),collapse=";")
    MS2s<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){paste(paste(x@mz,x@intensity,sep="_"),collapse=":")}),collapse=";")

    TMP<-data.frame(startRT=startRT,endRT=endRT,
                    startMZ=startMZ,endMZ=endMZ,
                    centermz=centermz,
                    centerrt=centerrt,
                    intensity=intensity,
                    fileName=fileName,
                    ID=ID,
                    Name=Name,
                    nmass=nmass,
                    parentmzs=parentmzs,
                    parentrts=parentrts,
                    parentInts=parentInts,
                    MS2s=MS2s,stringsAsFactors = F)

    if(is.null(returnData))
    {
      returnData<-(TMP)

    }else
      {

      returnData<-rbind.data.frame(returnData,TMP,stringsAsFactors = F)

    }
	}
	}
  return(returnData)
  }

  if(whichmz=="f")
  {

listofPrecursorsmz<-libraryInfo[,requiredHeader["mzCol"]]

CameramzColumnIndexmin<-which(colnames(cameraObject@groupInfo)=="mzmin")
CameramzColumnIndexmax<-which(colnames(cameraObject@groupInfo)=="mzmax")

MassRun1<-Intervals_full(cbind(listofPrecursorsmz,listofPrecursorsmz))

MassRun2<-Intervals_full(cbind(cameraObject@groupInfo[,CameramzColumnIndexmin]-
                                 ppmCal(cameraObject@groupInfo[,CameramzColumnIndexmin],ppm),
                               cameraObject@groupInfo[,CameramzColumnIndexmax]+
                                 ppmCal(cameraObject@groupInfo[,CameramzColumnIndexmax],ppm)))

imatch <- interval_overlap(MassRun1,MassRun2)
returnData<-c()
for (i in 1:length(imatch)) {
  for(j in imatch[[i]])
  {
    startRT<-cameraObject@groupInfo[c(j),"rtmin"]
    endRT<-cameraObject@groupInfo[c(j),"rtmax"]
    startMZ<-cameraObject@groupInfo[c(j),"mzmin"]
    endMZ<-cameraObject@groupInfo[c(j),"mzmax"]
    centermz<-cameraObject@groupInfo[c(j),"mz"]
    centerrt<-cameraObject@groupInfo[c(j),"rt"]
    intensity<-cameraObject@groupInfo[c(j),"into"]
    fileName<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){attr(x,"fileName")}),collapse = ";")

    ID<-libraryInfo[i,requiredHeader["compundID"]]
    Name<-libraryInfo[i,requiredHeader["compoundName"]]
    nmass<-libraryInfo[i,requiredHeader["mzCol"]]

    parentmzs<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){x@precursorMz}),collapse=";")
    parentrts<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){x@rt}),collapse=";")
    parentInts<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){x@precursorIntensity}),collapse=";")
    MS2s<-paste(sapply(MSMSdata$mapped[[as.character(j)]],function(x){paste(paste(x@mz,x@intensity,sep="_"),collapse=":")}),collapse=";")

    TMP<-data.frame(startRT=startRT,endRT=endRT,
                    startMZ=startMZ,endMZ=endMZ,
                    centermz=centermz,
                    centerrt=centerrt,
                    intensity=intensity,
                    fileName=fileName,
                    ID=ID,
                    Name=Name,
                    nmass=nmass,
                    parentmzs=parentmzs,
                    parentrts=parentrts,
                    parentInts=parentInts,
                    MS2s=MS2s,stringsAsFactors = F)

    if(is.null(returnData))
    {
      returnData<-(TMP)

    }else
      {

      returnData<-rbind.data.frame(returnData,TMP,stringsAsFactors = F)

    }
	}
	}
  return(returnData)
  }
}

require(CAMERA)
require(stringr)

createLibrary<-function(MSMSdata=NA,
                           cameraObject=NA,
						   libraryInfo=NA,requiredHeader=NA,whichmz="f",
                           includeUnmapped=T,includeMapped=T,
                           preprocess=NA,savePath="",minPeaks=0,maxSpectra=NA,
			   maxPrecursorMass = NA, minPrecursorMass = NA,ppm)
{

data<-IntervalMerge(cameraObject=cameraObject,
MSMSdata=MSMSdata,libraryInfo=libraryInfo,ppm=ppm,listOfMS2Mapped=list(),listOfUnMapped=list(),whichmz=whichmz,requiredHeader=requiredHeader)

MSlibrary<-data
MSlibrary<-MSlibrary[MSlibrary[,"MS2s"]!="",]
newLib<-c()
for(k in 1:nrow(MSlibrary))
{
  hitTMP<-MSlibrary[k,]
  parentmzs<-strsplit(x = hitTMP[,"parentmzs"],split = ";",fixed = T)[[1]]
  parentrts<-strsplit(x = hitTMP[,"parentrts"],split = ";",fixed = T)[[1]]
  parentInts<-strsplit(x = hitTMP[,"parentInts"],split = ";",fixed = T)[[1]]
  parentMS2s<-strsplit(x = hitTMP[,"MS2s"],split = ";",fixed = T)[[1]]
  fileNames<-strsplit(x = hitTMP[,"fileName"],split = ";",fixed = T)[[1]]
  for(p in 1:length(parentmzs))
  {
    MS2sTMPLib<-parentMS2s[[p]]
    TempLib<-data.frame(MSlibrary[k,!colnames(MSlibrary)%in%c("parentmzs","parentrts","fileName","parentInts","MS2s")])

       temp<-t(sapply(X=(strsplit(x = strsplit(x = MS2sTMPLib,split = ":",fixed = T)[[1]],split = "_",fixed = T)),FUN = function(x){c(mz=as.numeric(x[1]),
                                                                                int=as.numeric(x[2]))}))
       temp<-data.frame(temp)
	   temp<-temp[temp$int!=0,]
       mzs<-  paste(temp$mz,collapse = ";")
       ints<-paste(temp$int,collapse = ";")

       TempLib$MS2mz<-parentmzs[[p]]
       TempLib$MS2rt<-parentrts[[p]]
       TempLib$MS2intensity<-parentInts[[p]]

       TempLib$MS2fileName<-fileNames[[p]]

       TempLib$MS2mzs<-mzs
       TempLib$MS2intensities<-ints
       TempLib$featureGroup<-k
	   if(length(temp$mz)>=minPeaks)
       newLib<-rbind(newLib,TempLib)

  }
}

write.csv(x=newLib,file=savePath)

}


##Layer=vector
##Stat_file=Output file html
##Fecha_inicio=string
##Fecha_final=string
##VariableClimatica=selection  pp;temp;etp;esco
library(rgee)
use_python("C:/Users/logis/AppData/Local/Microsoft/WindowsApps/python3")
library(htmlwidgets)
library(cptcity)

ee_Initialize()

data <- Layer
roi <- sf_as_ee(data)
inicio= Fecha_inicio
final = Fecha_final

if(VariableClimatica==0){
dem <- ee$ImageCollection("IDAHO_EPSCOR/TERRACLIMATE")$select("pr")$filterDate(inicio,final)$mean()$clip(roi)
} else if(VariableClimatica==1){
dem <- ee$ImageCollection("IDAHO_EPSCOR/TERRACLIMATE")$select("tmmx")$filterDate(inicio,final)$mean()$clip(roi)
}else if (VariableClimatica==2){
dem <- ee$ImageCollection("IDAHO_EPSCOR/TERRACLIMATE")$select("pet")$filterDate(inicio,final)$mean()$clip(roi)
} else{
dem <- ee$ImageCollection("IDAHO_EPSCOR/TERRACLIMATE")$select("ro")$filterDate(inicio,final)$mean()$clip(roi)

}

Map$centerObject(roi)
a <- Map$addLayer(dem)
a <- Map$addLayer(dem)
a + Map$addLegend(
  list(
    min = 10,
    max = 25,
    palette=cpt(pal = "grass_bcyr")),
  name = "tmmax",
  position ="bottomright",
  bins = 4)
saveWidget(a,Stat_file)


library(shiny)
library(gmhelper)

shinyServer(function(input, output, session){
  files <- dir("./pages", recursive=TRUE, pattern="[.]r$")
  files <- paste0("./pages/", files)
  for (file in files)
    source(file=file, local=TRUE)

  localstate <- reactiveValues()
  init_dice()

  names_npc(input)
  names_dungeon(input)
  names_adventure(input)
  names_tavern(input)
  names_town(input)
  names_society(input)

  loot_pockets(input)
  loot_potions(input)

  misc_crits(input)

  dice_roller_basic(input)
  dice_roller_advanced(input)
  dice_roller_scatter(input)

  cards_tarot_draw(input)
  cards_playing_draw(input)
  cards_domt_draw(input)
})


library(clinfun)
source(file.path(PROJECT_DIR, "R/functions/gg_color_hue.r"))

fn.si = file.path(PROJECT_DIR, "generated_data", "YF", "YF_cd38_ge_sig_score.txt")
info = fread(fn.si) %>%
  dplyr::filter(Response %in% c("low","middle","high")) %>%
  mutate(Response = factor(Response, levels=c("low","middle","high")),
         label = ifelse(Trial==1, "Yellow Fever", paste0("Yellow Fever, Trial ", Trial)))

df.text = data.frame()

for (trial in 1:2) {
  tinfo = info %>% dplyr::filter(Trial == trial)

  w.pv = jonckheere.test(tinfo$CD38_score, as.numeric(tinfo$Response), alternative="inc")$p.value

  df.text = rbind(df.text,
                  data.frame(Trial=trial, #label.auc=sprintf("AUC = %.2f\np = %.2g", r$auc, r.p),
                             label.w.pv=sprintf("p = %.2g",w.pv)))
}

df.text$x = 0.25
df.text$y = 0.1

df.text = df.text %>%
  mutate(label = ifelse(Trial==1, "Yellow Fever", paste0("Yellow Fever, Trial ", Trial)))

clr = gg_color_hue(4) %>% rev()

for (t in 1:2) {
  df.text.2 = df.text %>%
    dplyr::filter(Trial==t)

  ggplot(info %>% dplyr::filter(Trial==t), aes(x=Response, y=CD38_score, group=Response)) +
    geom_boxplot(aes(fill=label), alpha=0.5, outlier.colour = NA) +
    geom_dotplot(binaxis = "y", stackdir = "center", aes(fill=Response)) +
    facet_wrap(~label, nrow=1) +
    scale_fill_manual(values=c("black", "white", "grey35", clr[4]), name="Response",
                      breaks=c(0,1,2), labels=c("low","middle","high")) +
    geom_text(data = df.text.2, aes(label=label.w.pv), x=1.5, y=Inf,vjust=1.1, hjust=0.5, size=4, inherit.aes = F) +
    xlab("Response") + ylab("Baseline signature score") +
    coord_cartesian(xlim=c(0.8, 3.2)) +
    theme_bw() + theme(legend.position="none") +
    theme(panel.border = element_blank(), strip.background = element_blank(),
          strip.text.x = element_text(size=12),
          panel.spacing = unit(0,"mm"), panel.grid.major.x = element_blank(),
          axis.ticks = element_blank())

  fn.fig = file.path(PROJECT_DIR, "figure_generation", sprintf("YF_Trial%d_CD38.10gene.sig_with_mid_Jonckheere", t))
  ggsave(paste0(fn.fig, ".png"), w=2.5,h=4)
  ggsave(paste0(fn.fig, ".pdf"), w=2.5,h=4)

}


#' Compute a unique numeric id for each unique row in a data frame.
#'
#' Properties:
#' \itemize{
#'   \item `order(id)` is equivalent to `do.call(order, df)`
#'   \item rows containing the same data have the same value
#'   \item if `drop = FALSE` then room for all possibilities
#' }
#'
#' @param .variables list of variables
#' @param drop drop unused factor levels?
#' @return a numeric vector with attribute n, giving total number of
#'   possibilities
#' @keywords internal
#' @export
id <- function(.variables, drop = FALSE) {
  warn("`id()` is deprecated")

  # Drop all zero length inputs
  lengths <- vapply(.variables, length, integer(1))
  .variables <- .variables[lengths != 0]

  if (length(.variables) == 0) {
    n <- nrow(.variables) %||% 0L
    return(structure(seq_len(n), n = n))
  }

  # Special case for single variable
  if (length(.variables) == 1) {
    return(id_var(.variables[[1]], drop = drop))
  }

  # Calculate individual ids
  ids <- rev(lapply(.variables, id_var, drop = drop))
  p <- length(ids)

  # Calculate dimensions
  ndistinct <- vapply(ids, attr, "n", FUN.VALUE = numeric(1), USE.NAMES = FALSE)
  n <- prod(ndistinct)
  if (n > 2 ^ 31) {
    # Too big for integers, have to use strings, which will be much slower :(

    char_id <- do.call("paste", c(ids, sep = "\r"))
    res <- match(char_id, unique(char_id))
  } else {
    combs <- c(1, cumprod(ndistinct[-p]))

    mat <- do.call("cbind", ids)
    res <- c((mat - 1L) %*% combs + 1L)
  }
  attr(res, "n") <- n

  if (drop) {
    id_var(res, drop = TRUE)
  } else {
    structure(as.integer(res), n = attr(res, "n"))
  }
}

id_var <- function(x, drop = FALSE) {
  if (length(x) == 0) return(structure(integer(), n = 0L))
  if (!is.null(attr(x, "n")) && !drop) return(x)

  if (is.factor(x) && !drop) {
    id <- as.integer(addNA(x, ifany = TRUE))
    n <- length(levels(x))
  } else {
    levels <- sort(unique(x), na.last = TRUE)
    id <- match(x, levels)
    n <- max(id)
  }
  structure(id, n = n)
}


# see https://github.com/ices-tools-prod/icesSAG

#icesSAG can be installed from CRAN using the install.packages command
#  install.packages("icesSAG")

library(icesSAG)
# ?icesSAG

stocks <- getListStocks(2018)
subset(stocks,SpeciesName=='Scomber scombrus')
#write.csv(stocks,file=file.path(data.path,'a.csv'))

# read list of stocks to be processed
my.stocks<-read.csv(file=file.path(data.path,'ICEStockList.in'),stringsAsFactors=FALSE)
head(my.stocks)

y<-2017
b<-NULL
for (i in (1:dim(my.stocks)[[1]])) {
  stock<-my.stocks[i,'StockKeyLabel']
  cat(my.stocks[i,1],'\n')
  a<-getSAG(stock=stock, y)
  if (length(a)>0) {
    a<-subset(a,select=c(-high_recruitment,-low_recruitment,-StockPublishNote,-Fage,-fishstock,-units,-stockSizeDescription,-stockSizeUnits,-fishingPressureDescription ,-fishingPressureUnits))
    a$SMS<-my.stocks[i,'SMS']
    a$Species.n<-my.stocks[i,'nr']
    b<-rbind(a,b)
  }
}

unique(b$SMS)
head(b)

#head(Read.summary.table())

#Species Species.n Year     Rec    SSB    TSB    SOP SOP.hat  Yield Yield.hat   mean.F Eaten
a<-data.frame(Species=sp.names[b$Species.n],Species.n=b$Species.n,Year=b$Year,SSB=b$SSB,mean.F=b$F,Rec=b$recruitment,Yield=ifelse(!is.na(b$catches),b$catches,b$landings))
a$SOP.hat<-a$Yield
a$SOP<-a$Yield

head(a)

write.table(a,row.names = FALSE, col.names = TRUE,file=file.path(root,'ICESsingle','summary_table_raw.out'))


adjImm_threshold <- 0.93 ## threshold for contact-adjusted immunity

scenarios <- scenarios_adjImm %>%
    mutate(country=factor(country),
           scenario=factor(scenario)) %>%
    arrange(country) %>%
    gather(model, value, ends_with("_immunity")) %>%
    mutate(model=recode_factor(model,
                               adjusted_immunity="age-specific",
                               mean_immunity="homogeneous"))

countries <-
  grep("\\(", invert=TRUE, unique(as.character(scenarios$country)), value=TRUE)

change_order <- c("decrease", "increase", "none")

age_levels <- c("0-4", "5-9", "10-14", "15-19", "20+")
target_levels <- tibble(age = factor(age_levels, age_levels),
                        target = c(0.85, 0.9, 0.95, 0.95, 0.95),
                        scenario = "current",
                        change = factor("none", change_order))

change_levels <-
  change_levels <- list(increase_infant = c(0.05, 0, 0, 0, 0),
                        catchup_kids = c(0, 0.05, 0, 0, 0),
                        catchup_kids_less_teenagers = c(0, 0.05, -0.05, 0, 0),
                        catchup_kids_less_adolescents = c(0, 0.05, 0, -0.05, 0))

levels <- list()
for (changed in names(change_levels))
{
  subtract_levels <- change_levels[[changed]]
  subtract_levels[subtract_levels > 0] <- 0
  add_levels <- change_levels[[changed]]
  add_levels[add_levels < 0] <- 0
  changed_target_levels <- target_levels$target + subtract_levels
  levels[[changed]] <-
    rbind(tibble(age = target_levels$age,
                 target = -subtract_levels,
                 scenario = changed,
                 change = factor("decrease", change_order)),
          tibble(age = target_levels$age,
                 target = add_levels,
                 scenario = changed,
                 change = factor("increase", change_order)))
  levels[[changed]] <-
    rbind(target_levels %>% mutate(scenario = changed,
                                   target = changed_target_levels),
          levels[[changed]])
}

all_levels <- rbind(target_levels, bind_rows(levels)) %>%
  mutate(scenario = factor(scenario,
                           levels = c("current", names(change_levels))))

age_specific_scenarios <- scenarios %>%
  filter(model == "age-specific",
         scenario %in% unique(all_levels$scenario),
         settings=="all") %>%
  mutate(scenario = factor(scenario, levels(all_levels$scenario)),
         country = factor(country, levels=countries))

p_imm <- ggplot(all_levels %>%
                mutate(scenario =
                         factor(scenario,
                                labels = letters[1:length(unique(scenario))])),
                aes(x = age, y = target, fill = change)) +
  geom_bar(stat = "identity", color = "black", position="stack") +
  scale_y_continuous("immunity", label=scales::percent_format(accuracy=1),
                     limits = c(0, 1)) +
  facet_grid( ~ scenario) +
  coord_cartesian(ylim = c(0.8, 1)) +
  theme(strip.background = element_blank(),
        plot.margin = unit(c(0, 0, 0, 1.94), "cm"),
        axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "none") +
  scale_x_discrete("") +
  scale_fill_manual(values = c("white", "lightblue", "black"))

eI_breaks <- c(0.9, 0.95)
eI_limits <- eI_breaks[c(1, length(eI_breaks))] * c(0.99, 1.01)
p_eI <- ggplot(age_specific_scenarios) +
  facet_grid( ~ scenario) +
  geom_boxplot(aes(x = factor(country, rev(levels(country))), y = value)) +
  geom_hline(yintercept=adjImm_threshold, linetype="dashed") +
  xlab("") +
  scale_y_continuous("Contact-adjusted immunity",
                     breaks = eI_breaks,
                     labels = scales::percent_format(accuracy=1),
                     limits = eI_limits) +
  ## geom_vline(xintercept=length(regions)+0.5, linetype="dashed") +
  theme(strip.text.x = element_blank(),
        strip.text.y = element_blank(),
        strip.background = element_blank(),
        plot.margin = unit(c(0, 0, 0, 0), "cm")) +
  coord_flip()

p <- plot_grid(p_imm, p_eI, nrow = 2, rel_heights=c(0.7, length(countries) / 10))
ggsave("figure_3.pdf", p, width = 15, height = length(countries) / 2)

## in the text: countries with >10% of outbreaks under current levels
current_elim_prob <- age_specific_scenarios %>%
    filter(scenario=="current") %>%
    group_by(country) %>%
    summarise(prob=mean(value < 0.93)) %>%
    filter(prob > 0.1) %>%
    mutate(prob=formattable::percent(prob, digits=0))

increase_infant_elim_prob <- age_specific_scenarios %>%
    filter(scenario=="increase_infant") %>%
    group_by(country) %>%
    summarise(prob=mean(value < 0.93)) %>%
    filter(prob > 0.1) %>%
    mutate(prob=formattable::percent(prob, digits=0))

catchup_kids_elim_prob <- age_specific_scenarios %>%
    filter(scenario=="catchup_kids") %>%
    group_by(country) %>%
    summarise(prob=mean(value < 0.93)) %>%
    filter(prob > 0.1) %>%
    mutate(prob=formattable::percent(prob, digits=1))


#' @title Compute keyword-country search score
#'
#' @aliases
#' compute_score
#' compute_score.numeric
#' compute_score.list
#'
#' @description
#' The function computes search scores for object keywords. Search volumes for
#' control and object batches are mapped to the same base. Next, search volumes
#' for object batches are divided by the sum of search volumes for the
#' respective control batch. `compute_voi` computes volume of
#' internationalization (VOI) as global search scores.
#'
#' @details
#' The search score computation proceeds in four steps. First, the function
#' aggregates all search volumes to monthly data. Then, it applies some optional
#' time series adjustments: seasonally adjusted [`forecast::seasadj`] and
#' trend only [`stats::stl`]. Next, it follows the procedure outlined by
#' Castelnuovo and Tran (2017, pp. A1-A2) to map control and object data. After
#' the mapping, object search volumes are divided by the sum of control search
#' volumes in the respective control batch. We use the sum of search volumes for
#' a set of control keywords, rather than the search volumes for a single
#' control keyword, to smooth-out variation in the underlying control data. When
#' synonyms were specified through `add_synonym`, search scores for
#' synonyms are added to the main keyword.
#'
#' *Castelnuovo, E. & Tran, T. D. 2017. Google It Up! A Google Trends-based
#' Uncertainty index for the United States and Australia. Economics Letters,
#' 161: 149-153.*
#'
#'
#' @param control Control batch for which the data is downloaded. Object
#' of type `numeric`. Defaults to 1.
#' @param object Object batch for which the data is downloaded. Object
#' of type `numeric` or object of type `list` containing single
#' objects of type `numeric`.
#' @param locations List of countries or regions for which the data is
#' downloaded. Refers to lists generated in `start_db`. Defaults to
#' `countries`.
#'
#' @seealso
#' * [example_score()]
#' * [add_synonym()]
#' * [stats::stl()]
#' * [forecast::seasadj()]
#'
#' @return Message that data has been computed successfully. Data is written to
#' table *data_score*.
#'
#' @examples
#' \dontrun{
#' compute_score(
#'   object = 1,
#'   control = 1,
#'   locations = countries
#' )
#' compute_voi(
#'   object = 1,
#'   control = 1
#' )
#' compute_score(
#'   object = as.list(1:5),
#'   control = 1,
#'   locations = countries
#' )
#' }
#'
#' @export
#' @rdname compute_score
#' @importFrom DBI dbWriteTable
#' @importFrom dplyr anti_join
#' @importFrom dplyr case_when
#' @importFrom dplyr coalesce
#' @importFrom dplyr collect
#' @importFrom dplyr contains
#' @importFrom dplyr count
#' @importFrom dplyr filter
#' @importFrom dplyr inner_join
#' @importFrom dplyr left_join
#' @importFrom dplyr mutate
#' @importFrom dplyr select
#' @importFrom dplyr summarise
#' @importFrom glue glue
#' @importFrom lubridate as_date
#' @importFrom purrr walk
#' @importFrom rlang .data
#' @importFrom rlang env_parent
#' @importFrom stringr str_replace
#' @importFrom tidyr nest
#' @importFrom tidyr pivot_longer
#' @importFrom tidyr pivot_wider
#' @importFrom tidyr unnest

compute_score <- function(object, control = 1, locations = countries) UseMethod("compute_score", object)

#' @rdname compute_score
#' @method compute_score numeric
#' @export

compute_score.numeric <- function(object, control = 1, locations = countries) {
  control <- unlist(control)
  .check_length(control, 1)
  .check_input(locations, "character")
  if (length(object) > 1) {
    compute_score(control = control, object = as.list(object), locations = locations)
  } else {
    walk(list(control, object), .check_batch)
    ts_control <- TRUE
    ts_object <- TRUE
    walk(locations, ~ {
      if (.test_empty(
        table = "data_score",
        batch_c = control,
        batch_o = object,
        location = .x
      )) {
        qry_object <- filter(
          .tbl_object,
          .data$batch_c == control & .data$batch_o == object & .data$location == .x
        )
        qry_object <- collect(qry_object)
        if (nrow(qry_object) != 0) {
          qry_control <- filter(.tbl_control, .data$batch == control & .data$location == .x)
          qry_control <- collect(qry_control)

          qry_control <- mutate(qry_control, date = as_date(.data$date))
          qry_object <- mutate(qry_object, date = as_date(.data$date))

          # adapt time series frequency
          qry_control <- .reset_date(qry_control)
          qry_object <- .reset_date(qry_object)

          if (
            min(
              nrow(count(qry_control, .data$date)),
              nrow(count(qry_object, .data$date))
            ) >= 24
          ) {
            # adjust to time series and impute negative values
            qry_control <- nest(qry_control, data = c(.data$date, .data$hits))
            qry_control <- mutate(qry_control, data = map(.data$data, .adjust_ts))
            qry_control <- unnest(qry_control, .data$data)
            qry_control <- mutate(qry_control,
              hits_trd = case_when(
                .data$hits_trd < 0 & .data$hits_sad < 0 ~ 0.1,
                .data$hits_trd < 0 ~ (.data$hits_obs + .data$hits_sad) / 2,
                TRUE ~ .data$hits_trd
              ),
              hits_sad = case_when(
                .data$hits_sad < 0 & .data$hits_trd < 0 ~ 0.1,
                .data$hits_sad < 0 ~ (.data$hits_obs + .data$hits_trd) / 2,
                TRUE ~ .data$hits_sad
              )
            )
            qry_object <- nest(qry_object, data = c(.data$date, .data$hits))
            qry_object <- mutate(qry_object, data = map(.data$data, .adjust_ts))
            qry_object <- unnest(qry_object, .data$data)
            qry_object <- mutate(qry_object,
              hits_trd = case_when(
                .data$hits_trd < 0 & .data$hits_sad < 0 ~ 0.1,
                .data$hits_trd < 0 ~ (.data$hits_obs + .data$hits_sad) / 2,
                TRUE ~ .data$hits_trd
              ),
              hits_sad = case_when(
                .data$hits_sad < 0 & .data$hits_trd < 0 ~ 0.1,
                .data$hits_sad < 0 ~ (.data$hits_obs + .data$hits_trd) / 2,
                TRUE ~ .data$hits_sad
              )
            )
          } else {
            if (nrow(count(qry_control, .data$date)) < 24) assign("ts_control", FALSE, envir = env_parent())
            if (nrow(count(qry_object, .data$date)) < 24) assign("ts_object", FALSE, envir = env_parent())
          }
          qry_control <- pivot_longer(
            qry_control,
            cols = contains("hits"),
            names_to = "key",
            values_to = "value"
          )
          qry_object <- pivot_longer(
            qry_object,
            cols = contains("hits"),
            names_to = "key",
            values_to = "value"
          )

          # set to benchmark
          data_control <- inner_join(
            qry_object,
            qry_control,
            by = c(
              "location",
              "keyword",
              "date",
              "key"
            ),
            suffix = c("_o", "_c")
          )
          data_control <- mutate(
            data_control,
            value_o = case_when(
              .data$value_o == 0 ~ 1,
              TRUE ~ .data$value_o
            ),
            value_c = case_when(
              .data$value_c == 0 ~ 1,
              TRUE ~ .data$value_c
            )
          )
          data_control <- mutate(data_control,
            benchmark = coalesce(.data$value_o / .data$value_c, 0)
          )
          data_control <- select(data_control, .data$location, .data$date, .data$key, .data$benchmark)
          data_control <- inner_join(
            data_control,
            qry_control,
            by = c("location", "date", "key")
          )
          data_control <- mutate(data_control, value = .data$value * .data$benchmark)
          data_control <- select(
            data_control,
            .data$location,
            .data$date,
            .data$key,
            .data$keyword,
            .data$value
          )

          data_object <- anti_join(qry_object, data_control, by = c("keyword"))

          # compute score
          data_control <- group_by(data_control, .data$location, .data$date, .data$key)
          data_control <- summarise(data_control, value_c = sum(.data$value), .groups = "drop")
          data_object <- left_join(
            data_object,
            data_control,
            by = c("location", "date", "key")
          )
          data_object <- mutate(data_object,
            score = coalesce(.data$value / .data$value_c, 0),
            key = str_replace(.data$key, "hits$", "score_obs"),
            key = str_replace(.data$key, "hits_", "score_")
          )
          data_object <- select(data_object, .data$location, .data$date, .data$keyword, .data$key, .data$score)
          out <- pivot_wider(
            data_object,
            names_from = .data$key,
            values_from = .data$score,
            values_fill = 0
          )
          out <- mutate(
            out,
            batch_c = control,
            batch_o = object,
            synonym = case_when(
              .data$keyword %in% .keyword_synonyms$synonym ~ TRUE,
              TRUE ~ FALSE
            )
          )
          dbWriteTable(
            conn = globaltrends_db,
            name = "data_score",
            value = out,
            append = TRUE
          )
        }
      }
      message(glue("Successfully computed search score | control: {control} | object: {object} | location: {.x} [{current}/{total}]", current = which(locations == .x), total = length(locations)))
    })
    .aggregate_synonym(object = object)
    if (!ts_control | !ts_object) {
      text <- case_when(
        all(!c(ts_control, ts_object)) ~ "control and object",
        first(!c(ts_control, ts_object)) ~ "control",
        last(!c(ts_control, ts_object)) ~ "object"
      )
      warning(glue("You provided {text} data for less than 24 months.\nNo time series adjustments possible."))
    }
  }
}

#' @rdname compute_score
#' @method compute_score list
#' @export

compute_score.list <- function(object, control = 1, locations = countries) {
  walk(object, compute_score, control = control, locations = locations)
}

#' @rdname compute_score
#' @export

compute_voi <- function(object, control = 1) {
  compute_score(control = control, object = object, locations = "world")
}

#' @title Reset date
#'
#' @rdname hlprs
#' @keywords internal
#' @noRd
#'
#' @importFrom dplyr group_by
#' @importFrom dplyr mutate
#' @importFrom dplyr select
#' @importFrom dplyr summarise
#' @importFrom lubridate month
#' @importFrom lubridate year
#' @importFrom lubridate ymd
#' @importFrom rlang .data

.reset_date <- function(data) {
  out <- mutate(data, day = 1, month = month(.data$date), year = year(.data$date))
  out <- group_by(out, .data$location, .data$keyword, .data$year, .data$month, .data$day)
  out <- summarise(out, hits = mean(.data$hits), .groups = "drop")
  out <- mutate(out, date = ymd(glue("{.data$year}-{.data$month}-{.data$day}")))
  out <- select(out, .data$location, .data$keyword, .data$date, .data$hits)
  return(out)
}

#' @title Adjust time series
#'
#' @rdname hlprs
#' @keywords internal
#' @noRd
#'
#' @importFrom lubridate month
#' @importFrom lubridate year
#' @importFrom tibble tibble

.adjust_ts <- function(data) {
  myts <- stats::ts(data$hits, start = c(year(min(data$date)), month(min(data$date))), end = c(year(max(data$date)), month(max(data$date))), frequency = 12)
  fit <- stats::stl(myts, s.window = "period")
  trend <- fit$time.series[, "trend"]
  seasad <- forecast::seasadj(fit)
  out <- tibble(date = data$date, hits_obs = data$hits, hits_trd = as.double(trend), hits_sad = as.double(seasad))
  return(out)
}

#' Aggregate synonyms
#'
#' @rdname hlprs
#' @keywords internal
#' @noRd
#'
#' @export
#' @importFrom DBI dbExecute
#' @importFrom DBI dbWriteTable
#' @importFrom dplyr anti_join
#' @importFrom dplyr bind_rows
#' @importFrom dplyr collect
#' @importFrom dplyr filter
#' @importFrom dplyr inner_join
#' @importFrom dplyr mutate
#' @importFrom dplyr left_join
#' @importFrom dplyr select
#' @importFrom rlang .data
#' @importFrom purrr walk

.aggregate_synonym <- function(object) {
  lst_synonym <- filter(.keywords_object, .data$batch == object)
  lst_synonym1 <- inner_join(lst_synonym, .keyword_synonyms, by = "keyword")
  lst_synonym2 <- inner_join(lst_synonym, .keyword_synonyms, by = c("keyword" = "synonym"))
  lst_synonym <- unique(c(lst_synonym1$synonym, lst_synonym2$keyword))

  if (length(lst_synonym) > 0) {
    message("Checking for synonyms...")
    data_synonym <- filter(.tbl_score, .data$keyword %in% lst_synonym & .data$synonym == 1)
    data_synonym <- collect(data_synonym)

    if (nrow(data_synonym) > 0) {
      message("Aggregating scores for synonyms...")
      lst_main <- unique(.keyword_synonyms$keyword[.keyword_synonyms$synonym %in% lst_synonym])
      data_main <- filter(.tbl_score, .data$keyword %in% lst_main)
      data_main <- collect(data_main)

      walk(lst_synonym, ~ {
        keyword_main <- .keyword_synonyms$keyword[.keyword_synonyms$synonym == .x][[1]]
        sub_main <- filter(data_main, .data$keyword == keyword_main)

        sub_synonym <- filter(data_synonym, .data$keyword == .x)
        sub_main <- left_join(
          sub_main,
          sub_synonym,
          by = c("location", "date", "batch_c"),
          suffix = c("", "_s")
        )

        sub_main <- mutate(
          sub_main,
          score_obs = .data$score_obs + coalesce(.data$score_obs_s, 0),
          score_sad = .data$score_sad + coalesce(.data$score_sad_s, 0),
          score_trd = .data$score_trd + coalesce(.data$score_trd_s, 0)
        )
        sub_main <- select(
          sub_main,
          .data$location,
          .data$keyword,
          .data$date,
          .data$score_obs,
          .data$score_sad,
          .data$score_trd,
          .data$batch_c,
          .data$batch_o,
          .data$synonym
        )

        data_synonym_agg <- inner_join(
          sub_synonym,
          select(
            sub_main,
            .data$location,
            .data$date,
            .data$batch_c
          ),
          by = c("location", "date", "batch_c")
        )
        data_synonym_agg <- mutate(data_synonym_agg, synonym = 2)
        data_synonym_nagg <- anti_join(
          sub_synonym,
          select(
            sub_main,
            location,
            date,
            batch_c
          ),
          by = c("location", "date", "batch_c")
        )

        data <- bind_rows(sub_main, data_synonym_agg, data_synonym_nagg)
        dbExecute(conn = globaltrends_db, statement = "DELETE FROM data_score WHERE keyword=?", params = list(keyword_main))
        dbExecute(conn = globaltrends_db, statement = "DELETE FROM data_score WHERE keyword=?", params = list(.x))
        dbWriteTable(conn = globaltrends_db, name = "data_score", value = data, append = TRUE)
      })
    }
  }
}


\name{hc_polygon-dispatch}
\alias{hc_polygon}
\title{
Method dispatch page for hc_polygon
}
\description{
Method dispatch page for \code{hc_polygon}.
}
\section{Dispatch}{
\code{hc_polygon} can be dispatched on following classes:

\itemize{
\item \code{\link{hc_polygon,HilbertCurve-method}}, \code{\link{HilbertCurve-class}} class method
\item \code{\link{hc_polygon,GenomicHilbertCurve-method}}, \code{\link{GenomicHilbertCurve-class}} class method
}
}
\examples{
# no example
NULL

}


infile  = {{i.infile | quote}}
outfile = {{o.outfile | quote}}
mutypes = {{args.mutypes | R}}
binary  = {{args.binary | R}}
na      = {{args.na | R}}
samfn   = {{args.samfn}}

# read the maf file
maf  = read.table(
	if(endsWith(infile, '.gz')) gzfile(infile) else infile,
	header      = T,
	row.names   = NULL,
	check.names = F,
	sep         = "\t",
	quote       = ''
)

# select mutations with the give mutation types
if (!is.null(mutypes)) {
	maf = maf[which(maf$Variant_Classification %in% mutypes), , drop = F]
}

# get all samples
samples = unique(maf[, "Tumor_Sample_Barcode", drop = T])
# get all genes
genes   = unique(maf[, "Hugo_Symbol", drop = T])

# result matrix
ret = matrix(na, ncol = length(samples), nrow = length(genes))
rownames(ret) = genes
colnames(ret) = unique(samfn(samples))

for (gene in genes) {
	gsamples = maf[which(maf$Hugo_Symbol == gene), "Tumor_Sample_Barcode", drop = T]
	gsamples = samfn(gsamples)
	if (binary) {
		value2fill = matrix(1, nrow = length(gsamples))
		rownames(value2fill) = gsamples
	} else {
		value2fill = as.matrix(table(gsamples))
	}
	ret[gene, rownames(value2fill)] = value2fill
}
write.table(ret, outfile, row.names = T, col.names = T, sep = "\t", quote = F)


#' Makes matrix of functional distances.
#'
#' @param com A list, returned by evolve_com.
#'
#' @return Matrix of functional distances.
#' @export
#'
#' @examples
#' make.tr.dist(com)

make.tr.dist <- function(com)
{
  tr <- data.frame(com$niche)
  rownames(tr) <- as.character(1:(length(com$n)))
  dist.tr <- as.matrix(daisy(tr, metric = "euclidean"))

  return(dist.tr)
}


#!/usr/bin/env Rscript

##### BEGIN FUNCTION BLOCK ######
make_image<-function(d,outfile,input_width,text_adjust) {
  # decide output type
  filex = substr(outfile,nchar(outfile)-2,nchar(outfile))
  if(filex=="pdf") {
    pdf(outfile,bg="#FFFFFF")
  } else if (filex=="png") {
    png(outfile,bg="#FFFFFF")
  } else {
      stop("Unsupported type for output file.\n",call.=FALSE)
  }

  pcol = '#777777'
  fcol = '#7FC97F'
  ucol = '#FDC086'

  recwid = input_width
  axcex = text_adjust
  longest = 4000

  full = length(d[d[,1]=="full",1])
  partial = length(d[d[,1]=="partial",1])
  unannot = length(d[d[,1]=="unannotated",1])

  par(oma=c(0.5,0.5,0.5,0.5))
  par(mar=c(4,5,2,1))
  mat=rbind(c(1,2,3),c(4,4,4))
  layout(mat,c(1.5,5,1.1),c(6,6))

  tot = full+partial+unannot
  plot(1,type="n",xlim=c(-50,500),ylim=c(0,tot*1.1),xaxt='n',ylab="Number of Reads",bty="n",xlab="",yaxt='n',yaxs='i',cex.lab=axcex)
  axis(2,lwd=recwid,cex.axis=axcex)
  rect(0,0,500,partial,col=pcol,lwd=recwid)
  rect(0,partial,500,full+partial,col=fcol,lwd=recwid)
  rect(0,full+partial,500,full+partial+unannot,col=ucol,lwd=recwid)
  mtext("All",side=1,at=-100,adj=0,line=1,cex=axcex*0.67)

  # Do by length
  #find biggest
  biggest = 0
  for(i in seq(0,longest-500,500)) {
    currsize = length(d[d[,2]>i & d[,2]<=i+500,1])
    if(currsize > biggest) { biggest = currsize }
  }
  currsize = length(d[d[,2]>longest,1])
  if(currsize > biggest) { biggest = currsize }

  par(mar=c(4,2,2,1))
  plot(1,type="n",xlim=c(0,longest),ylim=c(0,biggest*1.1),ylab="",bty="n",xlab="Reference Transcript Length (bp)",xaxt='n',yaxt='n',yaxs='i',cex.lab=axcex)
  axis(side=1,at=seq(0,longest,500),cex.axis=axcex,lwd=recwid)
  axis(side=2,lwd=recwid,cex.axis=axcex)
  for(i in seq(0,longest-500,500)) {
    full = length(d[d[,1]=="full" & d[,2]>i & d[,2]<=i+500,1])
    partial = length(d[d[,1]=="partial" & d[,2]>i & d[,2]<=i+500,1])
    unannot = length(d[d[,1]=="unannotated" & d[,2]>i & d[,2]<=i+500,1])
    rect(i,0,i+500,partial,col=pcol,lwd=recwid)
    rect(i,partial,i+500,full+partial,col=fcol,lwd=recwid)
    rect(i,full+partial,i+500,full+partial+unannot,col=ucol,lwd=recwid)
  }

  full = length(d[d[,1]=="full" & d[,2]>longest,1])
  partial = length(d[d[,1]=="partial" & d[,2]>longest,1])
  unannot = length(d[d[,1]=="unannotated" & d[,2]>longest,1])
  tot = full+partial+unannot
  plot(1,type="n",xlim=c(-50,500),ylim=c(0,tot*1.1),ylab="Count longest reads",bty="n",xlab="",xaxt='n',yaxt='n',yaxs='i',cex.lab=axcex)
  axis(2,lwd=recwid,cex.axis=axcex)
  rect(0,0,500,partial,col=pcol,lwd=recwid)
  rect(0,partial,500,full+partial,col=fcol,lwd=recwid)
  rect(0,full+partial,500,full+partial+unannot,col=ucol,lwd=recwid)
  mtext(paste(">",longest),side=1,at=500,adj=1,line=1,cex=axcex*0.67)

  logtrans<-function(num) {
    if(num==0) {
      return(0)
    }
    if(num==1) {
      return(1)
    }
    return(log(num,2)+1)
  }
  untrans<-function(num) {
    if(num==0) {
      return(0)
    }
    if(num==1) {
      return(1)
    }
    return(2^(num-1))
  }
  neglogtrans<-function(num,lowest) {
    tymin = -1*log(lowest,2)
    return(-1*(-tymin+-1*log(num,2))/tymin)
  }

  # plot by exon distribution
  #find biggest
  maxexon = 20
  biggest = 0
  for(i in seq(1,maxexon,1)) {
    currsize = length(d[d[,3]==i &d[,1]=="full",1])
    if(currsize > biggest) { biggest = currsize }
    currsize = length(d[d[,3]==i &d[,1]=="partial",1])
    if(currsize > biggest) { biggest = currsize }
    currsize = length(d[d[,3]==i &d[,1]=="unannotated",1])
    if(currsize > biggest) { biggest = currsize }
  }
  currsize = length(d[d[,3]>=maxexon & d[,1]=="full",1])
  if(currsize > biggest) { biggest = currsize }
  currsize = length(d[d[,3]>=maxexon & d[,1]=="partial",1])
  if(currsize > biggest) { biggest = currsize }
  currsize = length(d[d[,3]>=maxexon & d[,1]=="unannotated",1])
  if(currsize > biggest) { biggest = currsize }

  endspace = 4
  par(mar=c(5,5,1.5,1))
  plot(1,type="n",xlim=c(0,maxexon+endspace),ylim=c(0,logtrans(biggest*2)),ylab="Number of Reads",bty="n",xlab="Exon Count (Reference Transcript)",xaxt='n',cex.lab=axcex,yaxt='n',yaxs='i')
  axispoints = seq(0,logtrans(biggest*2),1)
  axis(2,at=axispoints,labels=lapply(axispoints,untrans),cex.axis=axcex,lwd=recwid)
  axis(1,at=seq(1,maxexon,1),labels=seq(1,maxexon,1),cex.axis=axcex,lwd=recwid)
  mtext(paste(">",maxexon),side=1,at=maxexon+endspace-1,line=1,cex=axcex*0.67)
  for(i in seq(1,maxexon)) {
    full = length(d[d[,1]=="full" & d[,3]==i,1])
    partial = length(d[d[,1]=="partial" & d[,3]==i,1])
    unannot = length(d[d[,1]=="unannotated" & d[,3]==i,1])
    rect(i+0.1-0.5,0,i+0.8-0.5,logtrans(partial),col=pcol,lwd=recwid)
    rect(i+0-0.5,0,i+0.5-0.5,logtrans(full),col=fcol,lwd=recwid)
    rect(i+0.3-0.5,0,i+0.6-0.5,logtrans(unannot),col=ucol,lwd=recwid)
  }
  # get the longest pooled
  full = length(d[d[,1]=="full" & d[,3]>maxexon,1])
  partial = length(d[d[,1]=="partial" & d[,3]>maxexon,1])
  unannot = length(d[d[,1]=="unannotated" & d[,3]>maxexon,1])
  rect(maxexon+endspace-1+0.1-0.5,0,maxexon+endspace-1+0.8-0.5,logtrans(partial),col=pcol,lwd=recwid)
  rect(maxexon+endspace-1+0-0.5,0,maxexon+endspace-1+0.5-0.5,logtrans(full),col=fcol,lwd=recwid)
  rect(maxexon+endspace-1+0.3-0.5,0,maxexon+endspace-1+0.6-0.5,logtrans(unannot),col=ucol,lwd=recwid)
  dev.off()
}

args=commandArgs(trailingOnly=TRUE)
if(length(args)<2) {
  stop("Must supply input and output\n",call.=FALSE)
}
outfile=args[2]
infile = args[1]
infilex = substr(infile,nchar(infile)-1,nchar(infile))
if(infilex=="gz") {
  d1<-read.csv(infile,sep="\t",header=FALSE)
} else {
  d1<-read.csv(gzfile(infile),sep="\t",header=FALSE)
}
d<-data.frame(as.character(d1[,5]))
d<-cbind(d,as.numeric(d1[,12]),as.numeric(d1[,9]))
input_width = 3
if(length(args) > 2) {
  input_width = args[3]
}
text_adjust = 1.75
if(length(args) > 3) {
  text_adjust = args[4]
}
make_image(d,outfile,input_width,text_adjust)