###VISUALISE MODEL OUTPUTS###
library(tidyverse)
library(ggpubr)

folder <- dirname(rstudioapi::getSourceEditorContext()$path)

#load data
filename = 'national_market_results_sensitivity_analysis.csv'
data <- read.csv(file.path(folder, '..', 'results',
                           'sensitivity_analysis', filename))
unique(data$strategy)

data = data %>%
  separate(scenario, into = c("scenario", "capacity", NA, NA), sep="_") %>%
  separate(strategy, into = c("generation", "core", "backhaul",
                              NA, NA, NA, NA, "obf", "costs"), sep="_")

data$strategy = paste(data$generation, data$backhaul, sep='_')

data = data[data$strategy == "4G_wireless",]
data = data[data$scenario == "baseline",]
data = data[data$capacity == "10",]

data$GID_0 = factor(data$GID_0, levels=c("CIV",
                                             'MLI',
                                             "SEN",
                                             "KEN",
                                             "TZA",
                                             "UGA"),
                      labels=c("Cote D'Ivoire",
                               "Mali",
                               "Senegal",
                               "Kenya",
                               "Tanzania",
                               "Uganda"
                      ))

data$obf = factor(data$obf, levels=c('10', '20', '30' ),
                    labels=c('-50%', 'Baseline', '+50%'))

data$costs = factor(data$costs, levels=c('125', '100', '75'),
                  labels=c('+25%', 'Baseline', '-25%'))

data = select(data, GID_0, scenario, obf, costs, financial_cost)

data_obf = data[data$costs == "Baseline",]

min_value = round(min(data_obf$financial_cost)/1e9,0)
max_value = round(max(data_obf$financial_cost)/1e9,0)

obf_figure = ggplot(data_obf,
       aes(x=GID_0, y=round(financial_cost/1e9),
           group=obf, fill=obf)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(financial_cost/1e9)), size = 2.5,
            position = position_dodge(width = 1), hjust=-.25) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(
    title="(A) Cost Sensitivity for Active Network Users when Maintaining QoS",
    colour=NULL,
    subtitle = "Reported for 4G (W) targetting ~10 Mbps Per User",
    x = NULL, y = "Financial Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0), limits = c(0, max_value+17)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE))

data_costs = data[data$obf == "Baseline",]

min_value = round(min(data_costs$financial_cost)/1e9,0)
max_value = round(max(data_costs$financial_cost)/1e9,0)

costs_figure = ggplot(data_costs,
       aes(x=GID_0, y=round(financial_cost/1e9),
           group=costs, fill=costs)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(financial_cost/1e9)), size = 2.5,
            position = position_dodge(width = 1), hjust=-.25) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(
    title="(B) Cost Sensitivity to Model Input Costs",
    colour=NULL,
    subtitle = "Reported for 4G (W) targetting ~10 Mbps Per User",
    x = NULL, y = "Financial Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0), limits = c(0, max_value+17)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE))

combined <- ggarrange(obf_figure, costs_figure,
                      ncol = 1, nrow = 2)

path = file.path(folder, 'figures', 'sensitivity_analysis.png')
ggsave(path, units="in", width=8, height=11, dpi=300)
print(combined)
dev.off()


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

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

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

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

plotfreq<-function(dataall,freq1, freq2,cex_pt,alpha_pt,xlab='GWAS frequencies', ylab='GWAS cat frequencies'){
nbcat=20
height=1
perctrans<-90
ht<-hist(dataall[,freq1], nbcat, plot=F)
ht$counts<-ht$counts/sum(ht$counts)*height
ht2<-hist(dataall[,freq2], nbcat, plot=F)
ht2$counts<-ht2$counts/sum(ht2$counts)*height
layout.matrix <- matrix(c(2, 1, 0, 3), nrow = 2, ncol = 2)

layout(mat = layout.matrix,
       heights = c(max(ht$counts)*1.2, 1), # Heights of the two rows
       widths = c(2, max(ht2$counts)*2.4)) # Widths of the two columns
#layout.show(3)

#c(bottom, left, top, right)
par(mar=c(5, 4, 1, 1))
plot(c(0,1), c(0,1), type='n', cex=0.5, xlab=xlab, ylab=ylab, xlim=c(0,1), ylim=c(0,1), bty='n')
points(dataall[,freq1], dataall[,freq2], pch=22, ,col=t_col("blue",95), bg=t_col("blue",95),cex=cex_pt)
abline(a=0,b=1, lty=2 ,col=t_col('red'), lwd=2)
par(mar=c(0,4,1,0))
plot(ht, col=t_col("orange"), xlab="", ylab="", xlim=c(0,1),  xaxt='n',main="")
par(mar=c(5,0,1,1))
plot(c(0, max(ht2$counts)), c(0,1), type='n', cex=0.5, xlab='', ylab='', xlim=c(0,max(ht2$counts)), ylim=c(0,1), yaxt='n',bty='n')
rect(rep(0,length(ht2$counts)),(1:length(ht2$counts))/nbcat,
           ht2$counts,(1:length(ht2$counts))/nbcat-1/nbcat, col=t_col('red', perctrans), bg=t_col('red', perctrans))
}

plotZ<-function(dataall,Z1, Z2, xlab='Z (GWAS cat)', ylab='Z (AWIGEN)'){
datagwas$z.gwas<-NA
r2<-cor(dataall[,Z1],dataall[,Z2], method='spearman')
r2abs<-cor(abs(dataall[,Z1]), abs(dataall[,Z2]), method='spearman')
plot(dataall[,Z1], dataall[,Z2], pch=22, cex=0.5,bg=t_col("blue") ,col=t_col("blue"), xlab=xlab, ylab=ylab)
text(min(dataall[,Z1])-min(dataall[,Z1])*0.1,max(dataall[,Z2]), paste(paste("r2 :",round(r2,2)), paste("\n         r2 (abs) :",round(r2abs,2)), sep=""))
abline(h=0, col='red', lty=2)
abline(v=0, col='red', lty=2)
}

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

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

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

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

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

datagwascat=read.csv(opt[['gwascat']])
checkhead(headbpcat,datagwascat,'bp cat');checkhead(headchrcat,datagwascat,'chro cat')
#checkhead(opt[['wind']],datagwascat,'chro cat');

#datagwascat[,heada1cat]<-sapply(strsplit(as.character(datagwascat[,heada1catrs]),split='-'),function(x)x[2])
datagwascat$begin<-datagwascat[,headbpcat]-wind
datagwascat$end<-datagwascat[,headbpcat]+wind
datagwas<-read.table(opt[['gwas']], header=T)
checkhead(headpval, datagwas,'pval');checkhead(headse, datagwas,'se');checkhead(headbp, datagwas,'bp');checkhead(headchr, datagwas, 'chr');checkhead(headbeta, datagwas, 'beta')

#datagwas$p.adjust.fdr<-p.adjust(datagwas[,headpval],'fdr')
#datagwas$p.adjust.bonf<-p.adjust(datagwas[,headpval],'bonferroni')
headN<-opt[['N_value']]
if(is.null(opt[['N_gwas']])){
if(is.null(opt[['N_value']]))Nval<-10000 else Nval=opt[['N_value']]
datagwas[,'N_gwas']<-Nval
headN<-'N_gwas'
}
baliseh2=F
if(!is.null(headaf)){
checkhead(headaf, datagwas,'af');
datagwas$h2.gwas<-computedher(datagwas[,headbeta], datagwas[,headse], datagwas[,headaf],datagwas[,headN])
datagwas$z.gwas<-datagwas[,headbeta]/datagwas[,headse]
}else{
cat('no frequencie\n')
datagwas$h2.gwas<-NA
datagwas$z.gwas<-NA
baliseh2=T

}

##  merge windows
if(opt[['merge_wind']]==1){
NumWind<-1
Cmt<-1
for(chro in unique(datagwascat[,headchrcat])){
datagwascatchr<-datagwascat[datagwascat[,headchrcat]==chro,]
datagwascatchr$wind_num<- -1
datagwascatchr<-datagwascatchr[order(datagwascatchr$begin),]
datagwascatchr$wind_num[1]<-NumWind
if(nrow(datagwascatchr)>1)
for(wind in 2:nrow(datagwascatchr)){
if(datagwascatchr$begin[wind]<datagwascatchr$end[wind-1]){
NumWind<-NumWind
}else{
NumWind<-NumWind+1
}
datagwascatchr$wind_num[wind]<-NumWind
}
if(Cmt==1)datagwascatf<-datagwascatchr
else datagwascatf<-rbind(datagwascatf ,datagwascatchr)
Cmt<-Cmt+1
}
}else{
datagwascatf<-datagwascat
datagwascatf$wind_num<-1:nrow(datagwascatf)

}
MinWind<-aggregate(as.formula(paste('begin~wind_num+',headchrcat,sep='')), data=datagwascatf, FUN=min)
MaxWind<-aggregate(as.formula(paste('end~wind_num+',headchrcat,sep='')), data=datagwascatf, FUN=max)

AllWind<-merge(MinWind,MaxWind)

AllWind[,headchrcat]<-as.character(AllWind[,headchrcat])
datagwas[,headchr]<-as.character(datagwas[,headchr])
datagwas$wind_num<-NA
for(Cmtwindcat in 1:nrow(AllWind)){
windcat=AllWind[Cmtwindcat,]
balise=datagwas[,headchr]==windcat[,headchrcat] & datagwas[,headbp] >=windcat$begin & datagwas[,headbp] <=windcat$end
datagwas$wind_num[balise]<-windcat$wind_num
windcat$nbpos<-length(which(balise))
windcat$nbpos_sig<-length(which(balise & datagwas[,headpval]<opt[['min_pval']]))
PosMostSig<-which(min(datagwas[balise,headpval])==datagwas[,headpval] & balise)[1]
windcat$min_bp_gwas<-datagwas[PosMostSig,headbp]
#windcat$min_pval_gwas<-windcat[PosMostSig,headpval]
#windcat$min_beta_gwas<-windcat[PosMostSig,headbeta]
#windcat$min_se_gwas<-windcat[PosMostSig,headse]
if(Cmtwindcat==1)newwindcat<-windcat
else newwindcat <-rbind(newwindcat,windcat)
}

Allwingwasca<-merge(datagwascatf[,!(names(datagwascatf) %in% c("begin","end"))],merge(newwindcat,datagwas[!is.na(datagwas$wind_num) ,],by='wind_num'),by=c('wind_num'))

#write.csv(Allwingwasca,file=paste(opt[['out']],'_resume_allwind.csv',sep=''))
best_windcat<-merge(datagwascatf[,!(names(datagwascatf) %in% c("begin","end"))],merge(newwindcat,datagwas[!is.na(datagwas$wind_num) ,],by.x=c(headchrcat,'min_bp_gwas','wind_num'), by.y=c(headchr, headbp,'wind_num')),by=c('wind_num'))
write.csv(best_windcat,file=paste(opt[['out']],'_bestgwaswind.csv',sep=''))

infocat=strsplit(opt[['info_gwascat']],split=';')[[1]]
balise<-TRUE
best_windcat$info_gwascat=""
for(cat in infocat)best_windcat$info_gwascat[balise]<-paste(best_windcat$info_gwascat[balise],cat,':',best_windcat[balise,cat],',',sep='')

tmpinfocat<-aggregate(info_gwascat~wind_num, data=best_windcat,FUN=paste, collapse=';')
best_windcat_2<-merge(newwindcat,datagwas[!is.na(datagwas$wind_num) ,],by.x=c(headchrcat,'min_bp_gwas','wind_num'), by.y=c(headchr, headbp,'wind_num'))
resumebest<-merge(best_windcat_2,tmpinfocat, by='wind_num')

write.csv(resumebest,file=paste(opt[['out']],'_resume_bestgwaswind.csv',sep=''))

#Allwingwasca<-merge(datagwascatf[,names(datagwascatf)!=c("begin","end")],merge(AllWind,newwindcat, by='wind_num'),by=c('wind_num'))


# Source: https://towardsdatascience.com/doing-your-first-sentiment-analysis-in-r-with-sentimentr-167855445132
# Author: Matti Fuchs - https://towardsdatascience.com/@mattifuchs
# Data: http://jmcauley.ucsd.edu/data/amazon/

library(sentimentr)
library(ndjson)
library(sentimentr)
library(ggplot2)

# Load data
current_path <- paste(getwd(), "/data/", sep="" )
df <- stream_in(paste(current_path, "AmazonBeauty.json", sep = ""))
head(df)

# Get sentiment
df$reviewTextProcessed <- get_sentences(df$reviewText)
sentiment <- sentiment_by(df$reviewTextProcessed)

# Get results
summary(sentiment$ave_sentiment)
qplot(sentiment$ave_sentiment,
      geom="histogram",binwidth=0.1,main="Review Sentiment Histogram")

df$ave_sentiment=sentiment$ave_sentiment
df$sd_sentiment=sentiment$sd


set.cond <- function(x,condition,value) {
    x[which(condition)] <- value
    x
}
map <- function(x, ...) {
    key <- list(...)
    x[which(!x %in% names(key))] <- NA
    xp <- unlist(key)[match(x, names(key))]
    names(xp) <- names(x)
    print(table(original=x, mapped=xp, useNA="ifany"))
    xp
}
or.na <- function(...) {
    x <- sapply(list(...), function(x) x)
    is.na <- rowSums(!is.na(x)) == 0
    ret <- rowSums(x, na.rm=T) > 0
    ret[is.na] <- NA
    ret
}

alspac.vars <- c(
    "fh6892", ## dawba at 15.5 (1=yes, 2=no)
    "fh0011a", ## age of the child (months)
    "FJCI1001", ## cis-r at 17 (1=yes, 0=no)
    "fj003a", ## age of the child (months)
    "fkdq1000", ## cis-r mild depression at 24 (0=no, 1=yes)
    "fkdq1010", ## cis-r moderate depression at 24
    "fkar0010", ## age of the child (months)
    ## severe depression numbers too low
    "c600", ## EPDS at 32w gestation
    "c994", ## age of mother
    "c991", ## weeks gestation
    "t3255", ## EPDS at 18 years post-pregnancy
    "t9991a")## age of study child (months)

## fathers/partners epds not close enough to methylation time point
alspac.table <- eval.save({
    var.info <- findVars(alspac.vars)
    var.info <- filterVars(var.info, c600=list(obj="^c_"), t3255=list(obj="^t_"))
    alspac.table <- extractVars(var.info)
    colnames(alspac.table) <- tolower(colnames(alspac.table))
    alspac.table
}, "alspac")

stopifnot(all(tolower(alspac.vars) %in% colnames(alspac.table)))

alspac.table$dawba.15 <- map(alspac.table$fh6892, "1"=1, "2"=0)
alspac.table$dawba.15.age <- set.cond(alspac.table$fh0011a/12, alspac.table$fh0011a < 0, NA)
alspac.table$cisr.17 <- map(alspac.table$fjci1001, "0"=0, "1"=1)
alspac.table$cisr.17.age <- set.cond(alspac.table$fj003a/12, alspac.table$fj003a < 0, NA)
alspac.table$cisr.mild.24 <- map(alspac.table$fkdq1000, "0"=0, "1"=1)
alspac.table$cisr.mild.24.age <- set.cond(alspac.table$fkar0010/12,alspac.table$fkar0010 < 0, NA)
alspac.table$cisr.mod.24 <- map(alspac.table$fkdq1010, "0"=0, "1"=1)
alspac.table$cisr.mod.24.age <- set.cond(alspac.table$fkar0010/12,alspac.table$fkar0010 < 0, NA)
alspac.table$epds.preg <- set.cond(alspac.table$c600, alspac.table$c600 < 0, NA) >= 13
alspac.table$epds.preg.age <- set.cond(alspac.table$c994, alspac.table$c994 < 0, NA)
alspac.table$epds.mid <- set.cond(alspac.table$t3255, alspac.table$t3255 < 0, NA) >= 13
alspac.table$epds.mid.age <- set.cond(alspac.table$c994 + alspac.table$t9991a/12 + 2, alspac.table$c994 < 0 | alspac.table$t9991a < 0, NA)


#' Assess E.coli data at the year/site level.
#'
#' Compares E.coli data to 30-day and max criterion standards using Scenarios A, B, and C, and assigns e. coli assessment categories to each site.
#'
#' @param data A prepped dataframe object (likely the ecoli object within the prepped_data list--prepped_data$ecoli) containing e.coli data at the site/use/parameter level with standards assigned.
#' @param SeasonStartDate A string in the form "mm-dd" to define beginning of rec season over which to perform assessments.
#' @param SeasonEndDate A string in the form "mm-dd" to define end of rec season over which to perform assessments.
#' @param rec_season Logical. If TRUE, restricts assessments to recreation season data.
#' @return Returns list with three objects: assessments from all Scenarios on all data, and ecoli assessments aggregated over scenario and year and rolled up to site level.
#' @importFrom lubridate year
#' @importFrom lubridate month
#' @importFrom lubridate day
#' @importFrom plyr ddply
#' @import dplyr
#' @import tidyr
#' @export

## TESTING ###
# library(irTools)
# ecoli_data=read.csv("P:\\WQ\\Integrated Report\\Automation_Development\\elise\\z_archives\\e.coli_demo\\01_rawdata\\ecoli_example_data.csv")
# table(ecoli_data$IR_MLID)
# asmnt_rec=assessEColi(ecoli_data)
# recmlids <- as.character(unique(asmnt_rec$ecoli_allscenario_asmnts$IR_MLID))
# nonrecmlids <- as.character(unique(asmnt_rec$non_assessed_data$IR_MLID))
# unique_mlids1 <- unique(c(recmlids,nonrecmlids))
#
# asmnt_nonrec= assessEColi(ecoli_data, rec_season = FALSE)
# unique_mlids2 <- as.character(unique(asmnt_nonrec$ecoli_allscenario_asmnts$IR_MLID))
#
# test1 <- unique_mlids1[!unique_mlids1%in%unique_mlids2] # Empty
# test2 <- unique_mlids2[!unique_mlids2%in%unique_mlids1] # Empty

assessEColi <- function(data, rec_season = TRUE, SeasonStartDate="05-01", SeasonEndDate="10-31"){

  # data <- read.csv("P:\\WQ\\Integrated Report\\Automation_Development\\elise\\e.coli_demo\\01_rawdata\\ecoli_example_data.csv")
  # SeasonStartDate="05-01"
  # SeasonEndDate="10-31"
  # rec_season = TRUE

  # Create new object for holding ecoli assessments
  ecoli_assessments = list()

  # Read in data
  data_raw = data

  ecoli_assessments$raw_data = data

  # Geometric mean function
  gmean <- function(x){exp(mean(log(x)))}

  # Obtain unique use/criterion
  uses_stds <- unique(data_raw[,c("BeneficialUse","CriterionLabel","NumericCriterion")])
  uses_stds$NumericCriterion=as.numeric(uses_stds$NumericCriterion)

  # Remove duplicates from data
  data_raw <- data_raw[,!names(data_raw)%in%c("AsmntAggPeriod","AsmntAggPeriodUnit","AsmntAggFun","CriterionLabel","NumericCriterion")]
  data_raw <- unique(data_raw)

  # Convert dates to R dates
  data_raw$ActivityStartDate=as.Date(data_raw$ActivityStartDate,format='%Y-%m-%d')

  # Create year column for scenario calculations
  data_raw$Year=lubridate::year(data_raw$ActivityStartDate)

  # JV NOTE - <1 & >2419.6 are coerced to numeric in fillMaskedValues. Simplest solution I can think of right now is to do the conversions in 65 & 66 before coercing to numeric in fillMaskedValues.
  # EH NOTE: <1 and >2419.6 now handled in readWQP data, before data are coerced to numeric. However, retained in this assessment tool for (potential) data that bypass other segments of irTools.
  # Should we manually set anything over 2420 to 2420 for assessment? Some over-detect results in WQP have higher limits reported.
  data_raw$IR_Value=gsub("<1",1,data_raw$IR_Value)
  data_raw$IR_Value=as.numeric(gsub(">2419.6",2420,data_raw$IR_Value))

  # Restrict assessments to data collected during recreation season.
  if(rec_season){
    data_raw$Rec_Season=ifelse(lubridate::month(data_raw$ActivityStartDate)>=lubridate::month(as.Date(SeasonStartDate,format='%m-%d'))
                      &lubridate::day(data_raw$ActivityStartDate)>=lubridate::day(as.Date(SeasonStartDate,format='%m-%d'))
                      &lubridate::month(data_raw$ActivityStartDate)<=lubridate::month(as.Date(SeasonEndDate,format='%m-%d'))
                      &lubridate::day(data_raw$ActivityStartDate)<=lubridate::day(as.Date(SeasonEndDate,format='%m-%d')),"Yes","No")

    # Separate rec and non-rec season samples
    data_rec <- data_raw[data_raw$Rec_Season=="Yes",]
    data_nonrec <- data_raw[data_raw$Rec_Season=="No",]
    if(dim(data_nonrec)[1]>0){
      data_nonrec$IR_Cat <- "Not Assessed - Out of Rec Season"
    }

    # Place non-rec season samples in own REJECT object
    ecoli_assessments$non_assessed_data <- data_nonrec
    }else{
      data_rec = data_raw
    }

  ecoli_assessments$assessed_data = data_rec

  # Aggregate to daily values.
  data_processed=aggregate(IR_Value~IR_MLID+BeneficialUse+ActivityStartDate+Year,data=data_rec,FUN=function(x){exp(mean(log(x)))})

  cols2keep = c("ActivityStartDate","IR_MLID","IR_MLNAME","ASSESS_ID","AU_NAME","AU_Type","BEN_CLASS","R3172ParameterName",
                "IR_Value","IR_Unit","IR_DetCond","IR_Fraction","IR_ActivityType","IR_Lat","IR_Long","DataLoggerLine",
                "ActivityRelativeDepthName","ActivityDepthHeightMeasure.MeasureValue","R317Descrp","ActivityDepthHeightMeasure.MeasureUnitCode")

  data_processed_allcols <- merge(data_processed,unique(data_rec[,cols2keep]), all.x=TRUE)
  ecoli_assessments$dailyaggregated_data = data_processed

  # maxSamps48hr function - counts the maximum number of samples collected over the rec season that were not collected within 48 hours of another sample(s).
  maxSamps48hr = function(x){
    x = sort(x) # order by DOY
    consecutive.groupings <- c(0, which(diff(x) != 1), length(x)) # Determine breaks in 1 by 1 sequence
    consec.groups <- sum(ceiling(diff(consecutive.groupings)/2)) # Determine length of each sequential group, divide by two, and round up to get the max number of samples occurring at least 48 hours apart
    return(consec.groups)
  }

  # # Rounding function to ensure if 10% of the sample count is x.5 or higher, it will round up, and if it's x.4 or lower, it will round down.
  # rounding = function(x,max_exc_pct){
  #   y = x*max_exc_pct/100+0.5
  #   z = floor(y)
  #   return(z)
  # }

##### SCENARIO A #####

  assessA = function(x){
    out_48_hr = maxSamps48hr(x$ActivityStartDate)
    stdcrit = uses_stds$NumericCriterion[uses_stds$BeneficialUse==x$BeneficialUse[1]&uses_stds$CriterionLabel=="max_crit"]
    out <- x[1,c("IR_MLID","BeneficialUse","Year")]
    out$Scenario = "A"
    ncount = length(x$ActivityStartDate)
    out$SampleCount = ncount
    out$ExcCount = length(x$IR_Value[x$IR_Value>stdcrit])
    out$Percent_Exceed = ifelse(out_48_hr>=10,out$ExcCount/out$SampleCount,NA)
    if(out_48_hr<5){
      out$IR_Cat = ifelse(out$ExcCount>=1,"IDEX","IDNE")
    }else{
      if(out_48_hr<10){
        out$IR_Cat = ifelse(out$ExcCount>1,"NS","ScenB")
      }else{out$IR_Cat = ifelse(out$Percent_Exceed>0.1,"NS","ScenB")}
    }
    return(out)
    }

##### SCENARIO B #####

  assessB <- function(x){
    out_48_hr = maxSamps48hr(x$ActivityStartDate)
    if(out_48_hr<5){
      out <- x[1,c("IR_MLID","BeneficialUse","Year")]
      out$SampleCount = out_48_hr
      out$IR_Cat = "Not Assessed"
      out$Scenario = "B"
    }
    stdcrit = uses_stds$NumericCriterion[uses_stds$BeneficialUse==x$BeneficialUse[1]&uses_stds$CriterionLabel=="30-day"]
    # Create empty vector to hold geometric means
    geomeans <- vector()
    n = 1 # counter for geomeans vector population
    # Loop through each day
    for(i in 1:dim(x)[1]){
      dmax = x$ActivityStartDate[i]+29 # create 30 day window
      samps = x[x$ActivityStartDate>=x$ActivityStartDate[i]&x$ActivityStartDate<=dmax,] # Isolate samples occurring within that window
      # Calculate geometric mean on ALL samples IF 5 or more samples are spaced at least 48 hours apart
      geomeans[i] <- ifelse(maxSamps48hr(samps$ActivityStartDate)>=5,gmean(samps$IR_Value),0)
      }
    # Create output dataframe with MLID/Use/Year/SampleCount...etc.
      out <- samps[1,c("IR_MLID","BeneficialUse","Year")]
      out$SampleCount = length(geomeans[geomeans>0])
      out$ExcCountLim = 1
      out$ExcCount = length(geomeans[geomeans>=stdcrit])
      out$IR_Cat = ifelse(any(geomeans>=stdcrit),"NS","ScenC")
      out$Scenario = "B"
      return(out)
  }

##### SCENARIO C #####

  assessC <- function(x){
    out_48_hr = maxSamps48hr(x$ActivityStartDate)
    if(out_48_hr<5){
      out <- x[1,c("IR_MLID","BeneficialUse","Year")]
      out$SampleCount = out_48_hr
      out$IR_Cat = "Not Assessed"
      out$Scenario = "C"
    }else{
      stdcrit = uses_stds$NumericCriterion[uses_stds$BeneficialUse==x$BeneficialUse[1]&uses_stds$CriterionLabel=="30-day"]
      out <- x[1,c("IR_MLID","BeneficialUse","Year")]
      out$Scenario = "C"
      out$SampleCount = length(x$ActivityStartDate)
      geomean <- gmean(x$IR_Value)
      if(out$SampleCount<10){
        out$IR_Cat = ifelse(geomean>stdcrit,"IDEX","FS")
      }else{
        out$IR_Cat = ifelse(geomean>stdcrit,"NS","FS")
      }
    }
    return(out)
  }

    ##### COMBINE SCENARIOS ####

    ScenA = plyr::ddply(.data=data_processed,c("IR_MLID","BeneficialUse","Year"),.fun=assessA) #.() was not working when installed as package w/o importing all of plyr
    ScenB = plyr::ddply(.data=data_processed,c("IR_MLID","BeneficialUse","Year"),.fun=assessB)
    ScenC = plyr::ddply(.data=data_processed,c("IR_MLID","BeneficialUse","Year"),.fun=assessC)

    # Bind scenarios together into one object and add to ecoli_assessments list
    ScenABC = dplyr::bind_rows(ScenA, ScenB, ScenC)

    ecoli_assessments$ecoli_allscenario_asmnts = ScenABC

### Rank and Roll Up By Scenarios (one scenario assessment by MLID/use/year as determined by E. coli scenario hierarchy)###

  ScenABC = ScenABC[!(ScenABC$IR_Cat=="ScenB"|ScenABC$IR_Cat=="ScenC"),]
  ScenABC$S.rank = 4
  ScenABC$S.rank[ScenABC$Scenario=="B"] = 3
  ScenABC$S.rank[ScenABC$Scenario=="C"] = 2
  ScenABC$S.rank[ScenABC$IR_Cat=="Not Assessed"] = 1

  ScenABC_agg <- aggregate(S.rank~IR_MLID+BeneficialUse+Year, data=ScenABC, FUN=max)
  ScenABC_agg$Scenario = "A"
  ScenABC_agg$Scenario[ScenABC_agg$S.rank==3]="B"
  ScenABC_agg$Scenario[ScenABC_agg$S.rank==2]="C"
  ScenABC_agg$Scenario[ScenABC_agg$S.rank==1]="C"
  ScenABC_agg = ScenABC_agg[,!names(ScenABC_agg)%in%"S.rank"]

  ScenABC_assess <- merge(ScenABC_agg, ScenABC, all.x=TRUE)
  ScenABC_assess = ScenABC_assess[,!names(ScenABC_assess)%in%c("S.rank")]

  ecoli_assessments$ecoli_scenario_rollup = ScenABC_assess

### Roll up to site level assessments ###

  # Merge data back to original dataset
  data_raw1 <- unique(data_raw[,c("IR_MLID","ASSESS_ID","BeneficialUse","BEN_CLASS","R3172ParameterName")])

  # Using all scenarios for MLID/Use roll-up
  ecoli.assessed <- merge(ecoli_assessments$ecoli_allscenario_asmnts,data_raw1, all.x=TRUE)
  ecoli.assessed <- ecoli.assessed[ecoli.assessed$IR_Cat=="NS"|
                                    ecoli.assessed$IR_Cat=="IDNE"|
                                    ecoli.assessed$IR_Cat=="IDEX"|
                                     ecoli.assessed$IR_Cat=="FS",]

  length(unique(ecoli.assessed$IR_MLID))#953

  # For MLIDS that have a mix of years that are FS and IDNE, pick the most recent year to represent that category
  #Find MLID-uses
  mlid_cats = unique(ecoli.assessed[,c("IR_MLID","BeneficialUse","IR_Cat")])
  mlid_cats$present = 1
  cat_table = tidyr::pivot_wider(mlid_cats, names_from = "IR_Cat", values_from = "present")

  fsid_mlids = subset(cat_table, cat_table$IDNE==1&cat_table$FS==1&is.na(cat_table$NS)&is.na(cat_table$IDEX))

  mlid_uses = fsid_mlids[,c("IR_MLID","BeneficialUse")] # 158

  ecoli.assessed_fsid = merge(mlid_uses, ecoli.assessed, all.x = TRUE)
  fsid.agg = ecoli.assessed_fsid%>%group_by(IR_MLID,BeneficialUse)%>%filter(Year==max(Year))

  # Pull out MLID/Uses assessed above
  mlids2rem = unique(fsid.agg[,c("IR_MLID","BeneficialUse")])
  mlids2rem$remove = 1
  nsid = merge(ecoli.assessed, mlids2rem, all.x = TRUE)
  nsid$remove = ifelse(is.na(nsid$remove),0,1)
  nsid_data = nsid[nsid$remove==0,]

  # Represent categories numerically so we can select the "max" category to define the AU
  # Hierarchy of decision making within each subset: NS>TMDLa>IDEX>FS>IDNE
  nsid_data$AssessCat[nsid_data$IR_Cat=="NS"]<-4
  nsid_data$AssessCat[nsid_data$IR_Cat=="IDEX"]<-3
  nsid_data$AssessCat[nsid_data$IR_Cat=="FS"]<-2
  nsid_data$AssessCat[nsid_data$IR_Cat=="IDNE"]<-1

  # Group not supports by MLID and Use and pick the max ranked assessment category
  # nsid.agg = nsid_data%>%group_by(IR_MLID,BeneficialUse)%>%filter(AssessCat==max(AssessCat))
  # nsid.agg = nsid_data%>%group_by(IR_MLID,BeneficialUse)%>%filter(AssessCat==max(AssessCat), Year==max(Year))
  # nsid.agg = nsid.agg[,!names(nsid.agg)%in%"AssessCat"]

  nsid.agg <- aggregate(AssessCat~IR_MLID+ASSESS_ID+BeneficialUse+BEN_CLASS+R3172ParameterName, data=nsid_data, FUN=max)
  names(nsid.agg)[names(nsid.agg)=="AssessCat"]<- "IR_Cat"

  #Renaming assessment categories
  nsid.agg$IR_Cat=as.character(nsid.agg$IR_Cat)
  nsid.agg=within(nsid.agg,{
    IR_Cat[IR_Cat=="4"]="NS"
    IR_Cat[IR_Cat=="3"]="IDEX"
    IR_Cat[IR_Cat=="2"]="FS"
    IR_Cat[IR_Cat=="1"]="IDNE"
  })

  all.agg = plyr::rbind.fill(fsid.agg, nsid.agg)

  # Add in some columns for app
  mlid_info = unique(data_rec[,c("IR_MLID","IR_MLNAME","IR_Lat","IR_Long","AU_NAME")])
  ecoli.assess.agg = merge(all.agg, mlid_info, all.x = TRUE)

  ecoli_assessments$ecoli_mlid_asmnts = ecoli.assess.agg

  return(ecoli_assessments)
}

#### ALTERNATIVE METHOD FOR PULLING OUT IDNE/FS CANDIDATES
# mlid_cats = unique(ecoli.assessed[,c("IR_MLID","BeneficialUse","IR_Cat")])
# #mlid_cats$present = 1
# length(unique(mlid_cats$IR_MLID))
#
# cat_table_wide=reshape2::dcast(mlid_cats, IR_MLID+BeneficialUse~IR_Cat, fun.aggregate=length, value.var='IR_Cat')
# head(cat_table_wide)
# summary(cat_table_wide)
# length(unique(cat_table_wide$IR_MLID))
#
# cat_table_wide=within(cat_table_wide, {
#   to_reduce=ifelse(FS==1 & IDNE==1 & NS==0 & IDEX==0, 1, 0)
# })
#
# dim(ecoli.assessed)
# ecoli.assessed=merge(ecoli.assessed, cat_table_wide, all.x=T)
# dim(ecoli.assessed)
#
# to_reduce=subset(ecoli.assessed, to_reduce==1)
# ecoli.assessed=subset(ecoli.assessed, to_reduce==0)
# dim(ecoli.assessed)[1] + dim(to_reduce)[1]
#
# # One way:
# selected_year=aggregate(Year~IR_MLID+BeneficialUse, to_reduce, FUN='max')
# dim(selected_year)
# dim(unique(selected_year[,c('IR_MLID', 'BeneficialUse')]))
# names(selected_year)[names(selected_year)=='Year']='sel_year'
#
# reduced = merge(to_reduce, selected_year, all.x=T)
# dim(reduced)[1]==dim(to_reduce)[1]
#
# reduced=subset(reduced, Year==sel_year)
# reduced=reduced[,names(ecoli.assessed)]
#
# ecoli.assessed=rbind(ecoli.assessed, reduced)
# length(unique(ecoli.assessed$IR_MLID))
#
# nsid_data = ecoli.assessed


# GetAuditFreqData.r
#                                       RBLandau 20171230
# where to run?
# setwd("C:/cygwin64/home/landau/working/PreservationSimulation/audit/frequency")
#
# For copies 3,4,5, what is the impact of more frequent total audits?
#

source("../common/DataUtil.r")
source("../common/PlotUtil.r")

# G E T   D A T A
if (exists("results")) {rm(results)}
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.auditallcopies <- as.data.frame(fndfGetAuditData(results))
dat.auditall <- dat.auditallcopies[dat.auditallcopies$copies>=3
                & dat.auditallcopies$copies<=5,]

fnPlotAuditFreq1 <- function(trows, nCopies){

    p <- ggplot(data=trows
                , mapping=aes(x=lifem, y=safe(mdmlosspct)
                #    , color=factor(auditfrequency)
                    )
                )

    p <- p + geom_line(data=trows, size=2
                , mapping=aes(color=factor(auditfrequency))
                )
    p <- p + geom_point(data=trows, shape=(point.DOT), size=4
#                , mapping=aes(color=factor(auditfrequency))
                )
    p <- p + theme(legend.position=c(1,0.8)
                , legend.justification=c(1,0.5)
                )
    p <- p + labs(color="Audit frequency")
    p <- p + scale_color_manual(
                labels=c("month","quarter","half-year","1 year", "2 years")
                , values = c("black","purple","green","blue","red")
                )

    p <- fnPlotLogScales(p, x='yes', y='yes')
    p <- fnPlotPercentLine(p)

    sParams <- sprintf("copies=%s",
                    nCopies)

    p <- fnPlotTitles(p, title=("Audit frequency comparisons, " %+% sParams
                            %+% "\nIncreasing auditing frequency beyond annually "
                            %+% "yields small benefits "
                            %+% "\nbut at greatly increased cost in bandwidth"
                            )
                ,titlesize=16
                ,xlabel="1MB sector half-life (megahours)"
                    %+% "                  (lower error rate \u2192)"
                ,ylabel="permanent document losses (%)"
                ,labelsize=14
                )
}

# S U B S E T S

if (nrow(dat.auditall) > 0)
{
#    source("./AuditFreqPlots.r")

    dat.audit3 <- subset(dat.auditall, copies==3)
    gp <- fnPlotAuditFreq1(trows=dat.audit3, nCopies=3)
    plot(gp)
    fnPlotMakeFile(gp, "Audit_FrequencyComparisons_copies3_MonthToBiennial.png")

    dat.audit4 <- subset(dat.auditall, copies==4)
    gp <- fnPlotAuditFreq1(trows=dat.audit4, nCopies=4)
    plot(gp)
    fnPlotMakeFile(gp, "Audit_FrequencyComparisons_copies4_MonthToBiennial.png")

    dat.audit5 <- subset(dat.auditall, copies==5)
    gp <- fnPlotAuditFreq1(trows=dat.audit5, nCopies=5)
    plot(gp)
    fnPlotMakeFile(gp, "Audit_FrequencyComparisons_copies5_MonthToBiennial.png")

}

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

# Edit history:
# longago   RBL Original version.
# 20180326  RBL Put in unbelievably obscure and horrible syntax to control
#                legend title, colors, labels.  Who would guess that
#                "scale_color_manual()" would be the function to control
#                the line colors and the legend labels for the variable
#                factor(auditfrequency)?
#               Move fnPlotAuditFreq1() function into here from the
#                subsidiary file.
#
#

#END


println("Testing...")
println("Reading test data...")
real.test.data = read.table("corrected", sep="," ,
                  col.names=c("duration","protocol_type","service","flag","src_bytes","dst_bytes",
                              "land","wrong_fragment","urgent","hot","num_failed_logins","logged_in",
                              "num_compromised","root_shell","su_attempted","num_root","num_file_creations",
                              "num_shells","num_access_files","num_outbound_cmds","is_host_login",
                              "is_guest_login","count","srv_count","serror_rate","srv_serror_rate",
                              "rerror_rate","srv_rerror_rate","same_srv_rate","diff_srv_rate",
                              "srv_diff_host_rate","dst_host_count","dst_host_srv_count",
                              "dst_host_same_srv_rate","dst_host_diff_srv_rate",
                              "dst_host_same_src_port_rate","dst_host_srv_diff_host_rate",
                              "dst_host_serror_rate","dst_host_srv_serror_rate","dst_host_rerror_rate",
                              "dst_host_srv_rerror_rate","label"),
                  colClasses=c("label"="character","service"="character", "hardness" = "NULL"))
println("Generating five kinds of attack labels...")
real.test.data$attack.type <- apply(real.test.data, 1, function(a){

  label = gsub("\\.","",a[['label']])
  label = type.map[[label]]
})
real.test.data$is.common <- apply(real.test.data, 1, function(a){
  label = a['label']
  is.common = label %in% c('normal','smurf','neptune')
})
real.test.data$is.attack <- apply(real.test.data, 1, function(a){
  label = a['label']
  is.common = label != 'normal'
})
service.type = levels(as.factor(real.test.data$service))
for (i in 1:length(service.type)) {
  if (is.null(service.map[[service.type[i]]]))
    service.map[[service.type[i]]] = length(service.map) + 1;
}

real.test.data$service <- apply(real.test.data, 1, function(a) {
  label = a[['service']]
  label = service.map[[label]]
})
real.test.data$service <- as.numeric(real.test.data$service)
real.test.data$attack.type <- as.factor(real.test.data$attack.type)

# Predict is normal
# println("Detecting abnormal data...")

# y.is.attack = as.logical(predict(dt.model, data[,feature.selection], type='vector') - 1)

# print(confusionMatrix(y.is.attack, data$label != 'normal'))
# Predict attack type
# println("Classifying abnormal data..")
# y.attack.type = predict(nb.model, data[,feature.selection])
#
# y.hat = y.attack.type
#
# y.hat[y.is.attack == FALSE] = 'normal'


context("translate-ACCESS")

test_that("custom scalar translated correctly", {

  trans <- function(x) {
    translate_sql(!!enquo(x), con = simulate_odbc_access())
  }
  # Conversion
  expect_equal(trans(as.numeric(x)),   sql("CDBL(`x`)"))
  expect_equal(trans(as.double(x)),    sql("CDBL(`x`)"))
  expect_equal(trans(as.integer(x)),   sql("INT(`x`)"))
  expect_equal(trans(as.logical(x)),   sql("CBOOL(`x`)"))
  expect_equal(trans(as.character(x)), sql("CSTR(`x`)"))
  expect_equal(trans(as.Date(x)),      sql("CDATE(`x`)"))
  # Math
  expect_equal(trans(exp(x)),          sql("EXP(`x`)"))
  expect_equal(trans(log(x)),          sql("LOG(`x`)"))
  expect_equal(trans(log10(x)),        sql("LOG(`x`) / LOG(10)"))
  expect_equal(trans(sqrt(x)),         sql("SQR(`x`)"))
  expect_equal(trans(sign(x)),         sql("SGN(`x`)"))
  expect_equal(trans(floor(x)),        sql("INT(`x`)"))
  expect_equal(trans(ceiling(x)),      sql("INT(`x` + 0.9999999999)"))
  expect_equal(trans(ceil(x)),         sql("INT(`x` + 0.9999999999)"))
  # String
  expect_equal(trans(nchar(x)),        sql("LEN(`x`)"))
  expect_equal(trans(tolower(x)),      sql("LCASE(`x`)"))
  expect_equal(trans(toupper(x)),      sql("UCASE(`x`)"))
  expect_equal(trans(substr(x, 1, 2)), sql("RIGHT(LEFT(`x`, 2.0), 2.0)"))
  expect_equal(trans(paste(x)),        sql("CSTR(`x`)"))
  expect_equal(trans(trimws(x)),       sql("TRIM(`x`)"))
  expect_equal(trans(is.null(x)),      sql("ISNULL(`x`)"))
  expect_equal(trans(is.na(x)),        sql("ISNULL(`x`)"))
  expect_equal(trans(coalesce(x, y)),  sql("IIF(ISNULL(`x`), `y`, `x`)"))
  expect_equal(trans(pmin(x, y)),      sql("IIF(`x` <= `y`, `x`, `y`)"))
  expect_equal(trans(pmax(x, y)),      sql("IIF(`x` <= `y`, `y`, `x`)"))
  expect_equal(trans(Sys.Date()),      sql("DATE()"))

  # Special paste() tests
  expect_equal(trans(paste(x, y, sep = "+")), sql("`x` & '+' & `y`"))
  expect_equal(trans(paste0(x, y)), sql("`x` & `y`"))

  expect_error(trans(paste(x, collapse = "-")),"`collapse` not supported")

})

test_that("custom aggregators translated correctly", {

  trans <- function(x) {
    translate_sql(!!enquo(x), window = FALSE, con = simulate_odbc_access())
  }

  expect_equal(trans(sd(x)),  sql("STDEV(`x`)"))
  expect_equal(trans(var(x)), sql("VAR(`x`)"))

  expect_error(trans(cor(x)), "not available")
  expect_error(trans(cov(x)), "not available")
  expect_error(trans(n_distinct(x)), "not available")

})

test_that("queries translate correctly", {
  mf <- lazy_frame(x = 1, src = simulate_odbc_access())

  expect_equal(
    mf %>% head() %>% show_query(),
    sql("SELECT TOP 6 *\nFROM `df`")
  )

})


# Using C. elegans orthologs to define cluster cell types and identify

# load libraries
library(tidyverse)
library(ggplot2)
library(cowplot)
library(ZamanianLabThemes)

# import DEG matrix for each treatment with the C. elegans orthologs appended to the table
tBM_markers_ortho <- readRDS("~/Box/ZamanianLab/SeqLibraries/Mapping/singlecell/scRNAesq_Bma_multi/RDS_objects/scmulti_tBM_markers_ortho.rds")  # 14,863 marker genes in total
utBM_markers_ortho <- readRDS("~/Box/ZamanianLab/SeqLibraries/Mapping/singlecell/scRNAesq_Bma_multi/RDS_objects/scmulti_utBM_markers_ortho.rds") # 13,804 marker genes in total

# create new column in dataframe that corresponds to the difference of pct.1 and pct.2 for each marker
tBM_markers_ortho$pct.df <- tBM_markers_ortho$pct.1 - tBM_markers_ortho$pct.2
utBM_markers_ortho$pct.df <- utBM_markers_ortho$pct.1 - utBM_markers_ortho$pct.2

# remove rows that do not have a Bma_gene_name (NA)
tBM_clean <- tBM_markers_ortho[!is.na(tBM_markers_ortho$Bma_gene_name),]  # 4,381 marker genes remaining
utBM_clean <- utBM_markers_ortho[!is.na(utBM_markers_ortho$Bma_gene_name),] # 4,010 marker genes remaining

# create a new matrix with cluster ID as rows and bma gene names as columns. The number in the corresponding box will be the difference between pct.1 and pct.2 indicating the significane of cells where the gene is detected in the cluster indicated. Where Bma_gene_names is duplicated due to multiple C. elegans orthologs

## Generate matrix using C. elegans orthologs
# wide matrix
tBM_cel_wide <- tBM_clean %>%
  select(-Bma_gene_id, -p_val, -avg_log2FC, -pct.1, -pct.2, -p_val_adj, -gene, -Bma_gene_name) %>%
  group_by(tBM_clean$cel_ortho) %>%
  data.frame(cel_ortho = make.unique(as.character(tBM_clean$cel_ortho))) %>%
  ungroup() %>%
  pivot_wider(id_cols = "cluster", names_from = "cel_ortho", values_from = "pct.df", values_fn = list, names_sort = TRUE) %>%
  subset("pct.df" >= 0.2)

#long matrix
tBM_cel_long <- tBM_clean %>%
  group_by(tBM_clean$cel_ortho) %>%
  data.frame(cel_ortho = make.unique(as.character(tBM_clean$cel_ortho))) %>%
  select(-Bma_gene_id, -p_val, -avg_log2FC, -pct.1, -pct.2, -p_val_adj, -gene, -Bma_gene_name, -tBM_clean.cel_ortho)
  subset(pct.df >= 0.2)

## utBM matrices
  # wide matrix
  utBM_new_cel <- utBM_clean %>%
    select(-Bma_gene_id, -p_val, -avg_log2FC, -pct.1, -pct.2, -p_val_adj, -gene, -Bma_gene_name) %>%
    group_by(utBM_clean$cel_ortho) %>%
    data.frame(cel_ortho = make.unique(as.character(utBM_clean$cel_ortho))) %>%
    ungroup() %>%
    pivot_wider(id_cols = "cluster", names_from = "cel_ortho", values_from = "pct.df", values_fn = list, names_sort = TRUE) %>%
    subset(pct.df >= 0.5)

  #long for heatmap
  utBM_hm_cel <- utBM_clean %>%
    group_by(utBM_clean$cel_ortho) %>%
    data.frame(cel_ortho = make.unique(as.character(utBM_clean$cel_ortho))) %>%
    select(-Bma_gene_id, -p_val, -avg_log2FC, -pct.1, -pct.2, -p_val_adj, -gene, -Bma_gene_name, -utBM_clean.cel_ortho)

  subset(pct.df >= 0.15)

## Using cengen marker lists to make inferences about our cell type clusters

  # import cengen marker list for major cell types and neurons independently
  cengen_marker <- read.csv("~/Desktop/cengen_markers.csv")
  cengen_neurons <- read.csv("~/Desktop/cengen_neurons.csv")

# plots

# tBM heatmap plot
pdf("~/Desktop/tBM_hm_cel.pdf", width = 24)
tBM_cel_long %>%
  ggplot(aes(cel_ortho.1, cluster)) +
  geom_tile(aes(fill = pct.df))+
  scale_fill_gradient(low = "blue", high = "red") +
  theme(axis.text.x = element_text(angle = 90))
dev.off()

#utBM hm plot
pdf("~/Desktop/utBM_hm_cel.pdf")
utBM_hm_cel %>%
  ggplot(aes(cel_ortho.1, cluster)) +
  geom_tile(aes(fill = pct.df) +
  scale_fill_gradient(low = "blue", high = "red") +
  theme(axis.text.x = element_text(angle = 90, size=6))
dev.off()

# save RDS objects
saveRDS(tBM_clean, "~/Box/ZamanianLab/SeqLibraries/Mapping/singlecell/scRNAesq_Bma_multi/RDS_objects/scmulti_tBM_clean.rds")
saveRDS(utBM_clean, "~/Box/ZamanianLab/SeqLibraries/Mapping/singlecell/scRNAesq_Bma_multi/RDS_objects/scmulti_utBM_clean.rds")

# objects for import
tBM_clean <- readRDS("~/Box/ZamanianLab/SeqLibraries/Mapping/singlecell/scRNAesq_Bma_multi/RDS_objects/scmulti_tBM_clean.rds")
utBM_clean <- readRDS("~/Box/ZamanianLab/SeqLibraries/Mapping/singlecell/scRNAesq_Bma_multi/RDS_objects/scmulti_utBM_clean.rds")


args = commandArgs(trailingOnly=TRUE)
pars = list()
names_ = list()
for (arg in args) {
    s = strsplit(arg, "=")
    names_ = c(names_, s[[1]][1])
    pars = c(pars, s[[1]][2])
}

names(pars) = names_

distance <- function(pars){
    sumstat_0 = readRDS(pars$sumstat_0)
    # insert observed data here directly
    # note: by design, pyabc can currently not completely make sure
    # that the observed data are always the second argument,
    # and the simulated ones the first
    sumstat_1 = list(x=4, y=8, mtcars=mtcars, cars=cars)

    dist = sqrt((sumstat_0$x - sumstat_1$x)^2
        + abs(sumstat_0$y - sumstat_1$y)^2)

    write(dist, pars$target)
}

distance(pars)


# -------------------------------------------------
# Addition
# -------------------------------------------------

#' Binary Arithmetic
#'
#' Binary arithmetic operations for \code{memuse} objects.
#'
#' Simple binary arithmetic for \code{memuse} objects.  Options include any
#' combination of \code{memuse}, \code{object_size} (output from the
#' \code{object.size()} function), and \code{numeric} objects.
#'
#' @param e1,e2
#' \code{memuse}, \code{numeric}, or \code{object_size} objects.
#'
#' @return Returns a \code{memuse} class object.
#'
#' @examples
#' \dontrun{
#' x <- mu(200)
#' y <- mu(100)
#'
#' x+y
#' x-y
#' x*y
#' x/y
#' x^2
#' }
#'
#' @seealso \code{ \link{Constructor}, \link{memuse-class} }
#' @keywords Methods
#' @name Arithmetic
#' @rdname arithmetic
NULL

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    # if unit prefices disagree, use "IEC"
    if (e1@unit.prefix != e2@unit.prefix){
      if (e1@unit.prefix != "IEC")
        e1 <- swap.prefix(e1)
      if (e2@unit.prefix != "IEC")
        e2 <- swap.prefix(e2)
    }

    # if names disagree, use "short"
    if (e1@unit.names != e2@unit.names){
      if (e1@unit.names != "short")
        e1 <- swap.names(e1)
    }

    e1 <- convert_to_bytes(e1)
    e2 <- convert_to_bytes(e2)

    e1@size <- e1@size + e2@size

    ret <- swap.unit(e1, "best")

    ret
  }
)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    if (length(e2) != 1)
      stop("memuse + numeric : vector must be of length 1")

    e1 <- convert_to_bytes(e1)

    e1@size <- e1@size + e2

    ret <- swap.unit(e1, "best")

    ret
  }
)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    if (length(e1) != 1)
      stop("numeric + memuse : vector must be of length 1")
    else
      return( e2+e1 )
  }
)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="memuse", e2="object_size"),
  function(e1, e2)
  {
    e1 <- convert_to_bytes(e1)

    e1@size <- e1@size + unclass(e2)

    ret <- swap.unit(e1, "best")

    ret
  }
)

#' @rdname arithmetic
#' @export
setMethod("+", signature(e1="object_size", e2="memuse"),
  function(e1, e2)
    return( e2+e1 )
)

# -------------------------------------------------
# Subtraction
# -------------------------------------------------

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    ret <- e1+(-1*e2)
    mu.nonneg(ret)

    ret
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    if (length(e2) != 1)
      stop("memuse - numeric : vector must be of length 1")

    ret <- e1+(-1*e2)
    mu.nonneg(ret)

    ret
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    if (length(e1) != 1)
      stop("vector - numeric : vector must be of length 1")

    ret <- e1+(-1*e2)
    mu.nonneg(ret)

    ret
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="memuse", e2="missing"),
  function(e1, e2)
    return( -1*e1 )
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="memuse", e2="object_size"),
  function(e1, e2)
  {
    e1 <- convert_to_bytes(e1)

    e1@size <- e1@size - unclass(e2)

    ret <- swap.unit(e1, "best")
    mu.nonneg(ret)

    ret
  }
)

#' @rdname arithmetic
#' @export
setMethod("-", signature(e1="object_size", e2="memuse"),
  function(e1, e2)
  {
    e2 <- convert_to_bytes(e2)

    e2@size <- unclass(e1) - e2@size

    ret <- swap.unit(e2, "best")
    mu.nonneg(ret)

    ret
  }
)

# -------------------------------------------------
# Multiplication
# -------------------------------------------------

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    # if unit prefices disagree, use "IEC"
    if (e1@unit.prefix != e2@unit.prefix){
      if (e1@unit.prefix != "IEC")
        e1 <- swap.prefix(e1)
      if (e2@unit.prefix != "IEC")
        e2 <- swap.prefix(e2)
    }

    # if names disagree, use "short"
    if (e1@unit.names != e2@unit.names){
      if (e1@unit.names != "short")
        e1 <- swap.names(e1)
    }

    e1 <- convert_to_bytes(e1)
    e2 <- convert_to_bytes(e2)

    e1@size <- e1@size * e2@size

    swap.unit(e1, "best")
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
#    if (length(e2) != 1)
#      stop("memuse * numeric : vector must be of length 1")

    e1 <- convert_to_bytes(e1)

    e1@size <- e1@size * e2

    swap.unit(e1, "best")
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    if (length(e1) != 1)
      stop("numeric * memuse : vector must be of length 1")
    else
      return( e2*e1 )
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="memuse", e2="object_size"),
  function(e1, e2)
  {
    e1 <- convert_to_bytes(e1)

    e1@size <- e1@size * unclass(e2)

    swap.unit(e1, "best")
  }
)

#' @rdname arithmetic
#' @export
setMethod("*", signature(e1="object_size", e2="memuse"),
  function(e1, e2)
    return( e2*e1 )
)

# -------------------------------------------------
# Division
# -------------------------------------------------

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    # if unit prefices disagree, use "IEC"
    if (e1@unit.prefix != e2@unit.prefix){
      if (e1@unit.prefix != "IEC")
        e1 <- swap.prefix(e1)
      if (e2@unit.prefix != "IEC")
        e2 <- swap.prefix(e2)
    }

    # if names disagree, use "short"
    if (e1@unit.names != e2@unit.names){
      if (e1@unit.names != "short")
        e1 <- swap.names(e1)
    }

    e1 <- convert_to_bytes(e1)@size
    e2 <- convert_to_bytes(e2)@size

    e1 / e2
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    if (length(e2) != 1)
      stop("memuse * numeric : vector must be of length 1")

    e1 <- convert_to_bytes(e1)

    e1@size <- e1@size / e2

    swap.unit(e1, "best")
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    if (length(e1) != 1)
      stop("vector * numeric : vector must be of length 1")

    e2 <- convert_to_bytes(e2)
    e1 / e2@size
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="memuse", e2="object_size"),
  function(e1, e2)
  {
    e1 <- convert_to_bytes(e1)@size
    e1 / unclass(e2)
  }
)

#' @rdname arithmetic
#' @export
setMethod("/", signature(e1="object_size", e2="memuse"),
  function(e1, e2)
  {
    e2 <- convert_to_bytes(e2)@size
    unclass(e1) / e2
  }
)

# -------------------------------------------------
# Exponentiation
# -------------------------------------------------

#' @rdname arithmetic
#' @export
setMethod("^", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    # if unit prefices disagree, use "IEC"
    if (e1@unit.prefix != e2@unit.prefix){
      if (e1@unit.prefix != "IEC")
        e1 <- swap.prefix(e1)
      if (e2@unit.prefix != "IEC")
        e2 <- swap.prefix(e2)
    }

    # if names disagree, use "short"
    if (e1@unit.names != e2@unit.names){
      if (e1@unit.names != "short")
        e1 <- swap.names(e1)
    }

    e1 <- convert_to_bytes(e1)
    e2 <- convert_to_bytes(e2)

    e1@size <- e1@size ^ e2@size

    swap.unit(e1, "best")
  }
)

#' @rdname arithmetic
#' @export
setMethod("^", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    if (length(e2) != 1)
      stop("memuse ^ vector : vector must be of length 1")

    e1 <- convert_to_bytes(e1)

    e1@size <- e1@size ^ e2

    swap.unit(e1, "best")
  }
)


wd <- "/home/eric/Desktop/MXelsCalendGovt/reelec/presentations/"
setwd(wd)

# data prep (summary of calendarios reelección)
firstElecs <- data.frame(
    yr=2014:2024,
    df=   c(0,0,0,0, 0,0,0,1,0,0,0),
    sen=  c(0,0,0,0, 0,0,0,0,0,0,1),
    dl=   c(0,0,0,1,24,3,0,4,0,0,0),
    ay=   c(0,0,0,0,22,3,0,3,0,0,2),
    dl2 = c(0,0,0,0, 6,2,0,1,0,0,0),
    dl3 = c(0,0,0,0, 1,0,0,0,0,0,0),
    dl4 = c(0,0,0,1,17,1,0,3,0,0,0)
    )

f <- firstElecs
#
f$cumdl <- cumsum(f$dl)
f$cumay <- cumsum(f$ay)
#
f$cumdl4 <- cumsum(f$dl4)
f$cumdl3 <- cumsum(f$dl3)
f$cumdl2 <- cumsum(f$dl2)
f$cumdl1 <- 32 - f$cumdl2 - f$cumdl3 - f$cumdl4
#
f$cumay2 <- f$cumay; f$cumay1 <- 32 - f$cumay2
#
f$sen <- f$df <- NULL

# plots
# yes/no dl ban
plot(x = f$yr, y = seq(0, 32, length.out = 11), type = "n",
     axes = FALSE,
     xlab = "",
     ylab = "Frequency (states)",
     main = "State assembly incumbents banned from ballot")
axis(1, at = f$yr)
# i <- 2018 # debug year
w <- .15  # half-column width
d <- 32 - f$cumdl # what to plot
for (i in 2014:2021){
    j <- i-2013  # needed
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(32,d[j],d[j],32),
            col = "green")
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(0,d[j],d[j],0),
            col = "red")
}

# yes/no ay ban
plot(x = f$yr, y = seq(0, 32, length.out = 11), type = "n",
     axes = FALSE,
     xlab = "",
     ylab = "Frequency (states)",
     main = "Municipal incumbents banned from ballot")
axis(1, at = f$yr)
axis(2, at = seq(0,32,4))
# i <- 2018 # debug year
w <- .15  # half-column width
d <- 32 - f$cumay # what to plot
for (i in 2014:2024){
    j <- i-2013  # needed
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(32,d[j],d[j],32),
            col = "green")
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(0,d[j],d[j],0),
            col = "red")
}
f[,c("yr","dl4","dl3","dl2")]

# yes/no dl possib
library(RColorBrewer)
greens <- brewer.pal(n = 4, name = "Greens")
#fl <- "../pics/dldummy.pdf"; pdf(file = fl, width = 7, height = 5)
plot(x = f$yr, y = seq(0, 32, length.out = 11), type = "n",
     axes = FALSE,
     xlab = "",
     ylab = "Frequency (states)",
     main = "State legilators can run again")
axis(1, at = f$yr)
axis(2, at = seq(0,32,4))
# i <- 2018 # debug year
w <- .15  # half-column width
d <- f$cumdl # what to plot
for (i in 2014:2021){
    j <- i-2013  # needed
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(32,d[j],d[j],32),
            col = greens[1])
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(0,d[j],d[j],0),
            col = greens[4])
}
legend(x = 2022, y = 18, legend = c("no","yes"), fill = c(greens[1],greens[4]))
#dev.off()

# n term limits dl
library(RColorBrewer)
greens <- brewer.pal(n = 4, name = "Greens")
#fl <- "../pics/dlnterm.pdf"; pdf(file = fl, width = 7, height = 5)
plot(x = 2014:2024, y = seq(0, 32, length.out = 11), type = "n",
     axes = FALSE,
     xlab = "",
     ylab = "Frequency (states)",
     main = "Term limits for state legislators")
axis(1, at = f$yr)
axis(2, at = seq(0,32,4))
# i <- 2018 # debug year
w <- .15  # half-column width
d2 <- f$cumdl2 # what to plot
d3 <- f$cumdl3 # what to plot
d4 <- f$cumdl4 # what to plot
for (i in 2014:2021){
    j <- i-2013  # needed
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(32,d4[j]+d3[j]+d2[j],d4[j]+d3[j]+d2[j],32),
            col = greens[1])
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(d4[j]+d3[j],d4[j]+d3[j]+d2[j],d4[j]+d3[j]+d2[j],d4[j]+d3[j]),
            col = greens[2])
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(d4[j],d4[j]+d3[j],d4[j]+d3[j],d4[j]),
            col = greens[3])
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(0,d4[j],d4[j],0),
            col = greens[4])
}
legend(x = 2022, y = 18, legend = c(1:3,"4 terms"), fill = greens)
#dev.off()

# n term limits ay
library(RColorBrewer)
greens <- brewer.pal(n = 4, name = "Greens")
#fl <- "../pics/aynterm.pdf"; pdf(file = fl, width = 7, height = 5)
plot(x = 2014:2024, y = seq(0, 32, length.out = 11), type = "n",
     axes = FALSE,
     xlab = "",
     ylab = "Frequency (states)",
     main = "Term limits for municipal officers")
axis(1, at = f$yr)
axis(2, at = seq(0,32,4))
# i <- 2018 # debug year
w <- .15  # half-column width
d2 <- f$cumay2 # what to plot
d3 <- rep(0,11) # what to plot
d4 <- rep(0,11) # what to plot
for (i in 2014:2024){
    j <- i-2013  # needed
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(32,d4[j]+d3[j]+d2[j],d4[j]+d3[j]+d2[j],32),
            col = greens[1])
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(d4[j]+d3[j],d4[j]+d3[j]+d2[j],d4[j]+d3[j]+d2[j],d4[j]+d3[j]),
            col = greens[2])
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(d4[j],d4[j]+d3[j],d4[j]+d3[j],d4[j]),
            col = greens[3])
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(0,d4[j],d4[j],0),
            col = greens[4])
}
#dev.off()

# adds number of legislators nationwide that can reelect every new year
dd.old <- dd
dd <- "/home/eric/Desktop/MXelsCalendGovt/redistrict/ife.ine/mapasComparados/loc"
# dd <- "/home/eric/Desktop/MXelsCalendGovt/redistrict/ife.ine/redisProcess/ineRedist2017/deJsonConEtiquetas/loc"
setwd(dd)
#
edos <- c("ags", "bc", "bcs", "cam", "coa", "col", "cps", "cua", "df", "dgo", "gua", "gue", "hgo", "jal", "mex", "mic", "mor", "nay", "nl", "oax", "pue", "que", "qui", "san", "sin", "son", "tab", "tam", "tla", "ver", "yuc", "zac", "dipfed", "sen")
#
nsmd <- data.frame(edo = edos)
nsmd$smds <- c(rep(0,32), 300, 96)
nsmd$yr <- c(rep(0,32), 2021, 2024)
#
nsmd$smds[9]  <- 33 # df
nsmd$smds[17] <- 12 # mor
nsmd$smds[29] <- 15 # tlax
#
for (i in c(1:8,10:16,18:28,30:32)){
    #i <- 1
    edo <- edos[i]
    tmp <- read.csv(
        paste("../../redisProcess/ineRedist2017/deJsonConEtiquetas/loc/", edo, "Loc.csv", sep = "")
      , stringsAsFactors = FALSE)
    nsmd$smds[i] <- max(tmp$escenario1)
}
nsmd$yr <- c(2018, 2019, 2018, 2018, 2017, 2018, 2018, 2018, 2021, 2018, 2018, 2018, 2018, 2018, 2018, 2018, 2018, 2021, 2018, 2018, 2021, 2018, 2019, 2018, 2018, 2021, 2018, 2019, 2018, 2018, 2018, 2018, 2021, 2024)
#
n <- tapply(nsmd$smds, nsmd$yr, FUN = sum)
n <- c(0,0,0,n[1:3],0,n[4],0,0,n[5])
f$nleg <- n

# adds number ayuntamientos
# pending --- need to figure out n regidores in each municipio
m <- read.csv("../../../../elecReturns/mun.yrs.csv", stringsAsFactors = FALSE)
n <- tapply(m$munn, m$edon, FUN = length)
nsmd$nmun <- c(n,0,0)
nsmd$yray <- c(19,19,18,18,18,18,18,18,21,19,18,18,NA,18,18,18,18,24,18,18,21,18,18,18,18,21,18,18,24,NA,18,18,NA,NA)+2000
# break oax into usos/not, using dipfed slot for usos
nsmd$nmun[nsmd$edo=="oax"] <- 570-sum(m$dusos)
nsmd$nmun[nsmd$edo=="dipfed"] <- sum(m$dusos)
# add to table
n <- tapply(nsmd$nmun, nsmd$yray, FUN = sum)
n <- c(0,0,0,0,n[1:2],0,n[3],0,0,n[4])
f$nmun <- n
#
f$cumnleg <- cumsum(f$nleg)
f$cumnmun <- cumsum(f$nmun)
#
setwd(dd.old)

# n smd legislators who can reelect
N <- sum(f$nleg)
library(RColorBrewer)
greens <- brewer.pal(n = 4, name = "Greens")
#fl <- "../pics/legislatorsNationwide.pdf"; pdf(file = fl, width = 7, height = 5)
plot(x = 2014:2024, y = seq(0, N, length.out = 11), type = "n",
     axes = FALSE,
     xlab = "",
     ylab = "Frequency (legislators)",
     main = "Lawmakers nationwide (SMD) who can reelect")
axis(1, at = f$yr)
axis(2)
# i <- 2018 # debug year
w <- .15  # half-column width
d <- f$cumnleg # what to plot
axis(4, at = max(d))
#d3 <- rep(0,11) # what to plot
#d4 <- rep(0,11) # what to plot
for (i in 2014:2024){
    j <- i-2013  # needed
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(N,d[j],d[j],N),
            col = greens[1])
    ## polygon(x = c(i-w,i-w,i+w,i+w),
    ##         y = c(d4[j]+d3[j],d4[j]+d3[j]+d2[j],d4[j]+d3[j]+d2[j],d4[j]+d3[j]),
    ##         col = greens[2])
    ## polygon(x = c(i-w,i-w,i+w,i+w),
    ##         y = c(d4[j],d4[j]+d3[j],d4[j]+d3[j],d4[j]),
    ##         col = greens[3])
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(0,d[j],d[j],0),
            col = greens[4])
}
#dev.off()

# n municipios whose officers can reelect
N <- max(m$ord)
library(RColorBrewer)
greens <- brewer.pal(n = 4, name = "Greens")
#fl <- "../pics/ayuntamientos.pdf"; pdf(file = fl, width = 7, height = 5)
plot(x = 2014:2024, y = seq(0, N, length.out = 11), type = "n",
     axes = FALSE,
     xlab = "",
     ylab = "Frequency (municipalities)",
     main = "Municipalities whose officers can reelect")
axis(1, at = f$yr)
axis(2)
# i <- 2018 # debug year
w <- .15  # half-column width
d <- f$cumnmun # what to plot
axis(4, at = max(d))
#d3 <- rep(0,11) # what to plot
#d4 <- rep(0,11) # what to plot
for (i in 2014:2024){
    j <- i-2013  # needed
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(N,d[j],d[j],N),
            col = greens[1])
    ## polygon(x = c(i-w,i-w,i+w,i+w),
    ##         y = c(d4[j]+d3[j],d4[j]+d3[j]+d2[j],d4[j]+d3[j]+d2[j],d4[j]+d3[j]),
    ##         col = greens[2])
    ## polygon(x = c(i-w,i-w,i+w,i+w),
    ##         y = c(d4[j],d4[j]+d3[j],d4[j]+d3[j],d4[j]),
    ##         col = greens[3])
    polygon(x = c(i-w,i-w,i+w,i+w),
            y = c(0,d[j],d[j],0),
            col = greens[4])
}
polygon(x = c(i-w,i-w,i+w,i+w),
        y = c(N,N-sum(m$dusos),N-sum(m$dusos),N),
        col = "gray")
text(x = i,
     y = N-sum(m$dusos)/2,
     labels = "usos")
#dev.off()

colnames(m)


args <- commandArgs(trailingOnly=TRUE)

if (length(args) < 4) {
  stop("Usage: size-of-property.r common.r input.csv output.pdf granularity")
}

common <- args[1]
inFile <- args[2]
outPdf <- args[3]
granularity <- args[4]

source(common)

res = read.csv(inFile, header=TRUE)

dat = as.numeric(as.character(res$size))

if (length(dat) != 0) {
  startPdf(outPdf)
  title = "Histogram of the size of a property"
  if (granularity == "group-example-name-strategy") { title = paste(title, args[5], args[6], args[7]) }
  if (granularity == "group-strategy") { title = paste(title, args[5]) }
  h = hist(dat,
       main=title,
       xlab="Size",
       ylab="# of cases",
       breaks=seq(min(dat)-0.5, max(dat)+0.5, by=1))

  h$density = h$counts/sum(h$counts)
  plot(h,
       main=title,
       xlab="Size",
       ylab="relative # of cases",
       freq=FALSE)
} else {
  invalidDataPdf(outPdf)
}


#!/usr/bin/env Rscript

################################################
################################################
## LOAD LIBRARIES                             ##
################################################
################################################

library(optparse)
library(UpSetR)

################################################
################################################
## PARSE COMMAND-LINE PARAMETERS              ##
################################################
################################################

option_list <- list(make_option(c("-i", "--input_file"), type="character", default=NULL, help="Path to tab-delimited file containing two columns i.e sample1&sample2&sample3 indicating intersect between samples <TAB> set size.", metavar="input_file"),
                    make_option(c("-o", "--output_file"), type="character", default=NULL, help="Path to output file with '.pdf' extension.", metavar="output_file"))

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

if (is.null(opt$input_file)){
    print_help(opt_parser)
    stop("Input file must be supplied.", call.=FALSE)
}
if (is.null(opt$output_file)){
    print_help(opt_parser)
    stop("Output pdf file must be supplied.", call.=FALSE)
}

OutDir <- dirname(opt$output_file)
if (file.exists(OutDir) == FALSE) {
    dir.create(OutDir,recursive=TRUE)
}

################################################
################################################
## PLOT DATA                                  ##
################################################
################################################

comb.dat <- read.table(opt$input_file,sep="\t",header=FALSE)
comb.vec <- comb.dat[,2]
comb.vec <- setNames(comb.vec,comb.dat[,1])

sets <- sort(unique(unlist(strsplit(names(comb.vec),split='&'))), decreasing = TRUE)
nintersects = length(names(comb.vec))
if (nintersects > 70) {
    nintersects <- 70
}

pdf(opt$output_file,onefile=F,height=10,width=20)

upset(
    fromExpression(comb.vec),
    nsets = length(sets),
    nintersects = nintersects,
    sets = sets,
    keep.order = TRUE,
    sets.bar.color = "#56B4E9",
    point.size = 3,
    line.size = 1,
    mb.ratio = c(0.55, 0.45),
    order.by = "freq",
    number.angles = 30,
    text.scale = c(1.5, 1.5, 1.5, 1.5, 1.5, 1.2)
)

dev.off()

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


#devtools::test("asremlPlus")
context("prediction_presentation")

cat("#### Test for sort.alldiffs on Smarthouse with asreml4\n")
test_that("sort.alldiffs4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  data(Smarthouse.dat)

  #Set up without any sorting
  m1.asr <- asreml(y1 ~ Genotype*A*B,
                   random=~Replicate/Mainplot/Subplot,
                   data=Smarthouse.dat)
  testthat::expect_equal(length(m1.asr$vparameters),4)
  current.asrt <- as.asrtests(m1.asr)
  current.asrt <- rmboundary(current.asrt)
  m <- current.asrt$asreml.obj
  testthat::expect_equal(length(m$vparameters),3)

  diffs <- predictPlus(m, classify = "Genotype:A:B",
                       wald.tab = current.asrt$wald.tab,
                       error.intervals = "Stand", tables = "none")
  testthat::expect_is(diffs, "alldiffs")
  testthat::expect_true(validAlldiffs(diffs))
  testthat::expect_equal(nrow(diffs$predictions),120)
  testthat::expect_equal(ncol(diffs$predictions),8)
  testthat::expect_equal(as.character(diffs$predictions$Genotype[1]),"Axe")
  testthat::expect_equal(length(attributes(diffs)),11)
  testthat::expect_true(is.null(attr(diffs, which = "sortOrder")))

  testthat::expect_silent(plotPredictions(data = diffs$predictions,
                                          classify = "Genotype:A:B",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title")))

  #Test sort in plotPredictions
  testthat::expect_silent(plotPredictions(data = diffs$predictions,
                                          classify = "Genotype:A:B",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title"),
                                          sortFactor = "Genotype"))

  #Test sort.alldiffs and save order for use with other response variables
  diffs.sort <- sort(diffs, sortFactor = "Genotype")
  sort.order <- attr(diffs.sort, which = "sortOrder")
  testthat::expect_is(diffs.sort, "alldiffs")
  testthat::expect_equal(nrow(diffs.sort$predictions),120)
  testthat::expect_equal(ncol(diffs.sort$predictions),8)
  testthat::expect_equal(as.character(diffs.sort$predictions$Genotype[1]),"Gladius")
  testthat::expect_equal(length(attributes(diffs.sort)),13)
  testthat::expect_equal(length(attr(diffs.sort, which = "sortOrder")),10)

  #Test sort.alldiffs with supplied sortOrder
  m2.asr <- asreml(y2 ~ Genotype*A*B,
                   random=~Replicate/Mainplot/Subplot,
                   data=Smarthouse.dat)
  testthat::expect_equal(length(m1.asr$vparameters),4)
  current.asrt <- as.asrtests(m2.asr)
  diffs2.sort <- predictPlus(m2.asr, classify = "Genotype:A:B",
                             wald.tab = current.asrt$wald.tab,
                             error.intervals = "Stand", tables = "none",
                             sortFactor = "Genotype",
                             sortOrder = sort.order)
  testthat::expect_equal(as.character(diffs.sort$predictions$Genotype[1]),
                         as.character(diffs2.sort$predictions$Genotype[1]))
  testthat::expect_equal(attr(diffs.sort, which = "sortOrder"),
                         attr(diffs2.sort, which = "sortOrder"))

  #Test sort.alldiffs with sortParallelToCombo and increasing order
  diffs1.sort <- sort(diffs, sortFactor = "Genotype",
                      sortParallelToCombo = list(A = "N3", B = "D4"),
                      decreasing = TRUE)
  diffs1.sort <- renewClassify(diffs1.sort, newclassify = "A:B:Genotype")
  testthat::expect_is(diffs1.sort, "alldiffs")
  testthat::expect_equal(as.character(attr(diffs1.sort, which = "sortOrder")[2]),"Wyalkatchem")
  testthat::expect_equal(length(attr(diffs1.sort, which = "sortOrder")), 10)
  #Check plot
  testthat::expect_silent(plotPredictions(data = diffs1.sort$predictions,
                                          classify = "Genotype:A:B",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title"),
                                          sortFactor = "Genotype"))
})

cat("#### Test for sort.predictions.frame on WaterRunoff with asreml4\n")
test_that("sort.predictions.frame4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  data(WaterRunoff.dat)
  tmp <- subset(WaterRunoff.dat, Date == "05-18")

  ##Use asreml to get predictions
  #Analyse pH
  m1.asr <- do.call(asreml,
                    list(fixed = pH ~ Benches + (Sources * (Type + Species)),
                         random = ~ Benches:MainPlots,
                         keep.order=TRUE, data= tmp))
  current.asrt <- as.asrtests(m1.asr, NULL, NULL)
  current.asrt <- as.asrtests(m1.asr)
  current.asrt <- rmboundary(current.asrt)
  m1.asr <- current.asrt$asreml.obj

  #Get predictions and associated statistics
  TS.diffs <- predictPlus.asreml(classify = "Sources:Type",
                                 asreml.obj = m1.asr, tables = "none",
                                 wald.tab = current.asrt$wald.tab,
                                 present = c("Type","Species","Sources"))

  #Use sort.predictions.frame and save order for use with other response variables
  TS.preds <- TS.diffs$predictions
  TS.preds.sort <- sort(TS.preds, classify = "Sources:Type",
                        sortFactor = "Sources", sortParallelToCombo = list(Type = "Control"))
  TS.preds.sort[TS.preds.sort$Type == "Control", ]
  sort.order <- attr(TS.preds.sort, which = "sortOrder")
  testthat::expect_true(all(sort.order == c("Rain+Basalt", "Rain+Dolomite", "Tap water",
                                            "Recycled water", "Rainwater", "Rain+Quartzite")))

  diffs.full <- predictPlus.asreml(asreml.obj = m1.asr,
                                   classify = "Sources:Type:Species",
                                   wald.tab = current.asrt$wald.tab,
                                   present = c("Type","Species","Sources"),
                                   tables = "none", Vmatrix = TRUE)
  testthat::expect_true(setequal(names(diffs.full$predictions),
                                 c("Sources", "Type", "Species", "predicted.value",
                                   "standard.error", "upper.Confidence.limit",
                                   "lower.Confidence.limit", "est.status")))
  pred <- diffs.full$predictions
  diffs.sort <- sort(diffs.full, sortFactor = "Species", sortNestingFactor = "Type",
                    sortParallelToCombo = list(Sources = "Rain+Dolomite"))
 testthat::expect_true(all(diffs.sort$predictions$Species[diffs.sort$predictions$Sources ==  "Rain+Dolomite"] ==
                             c("S. oymwjrcnepv", "S. iqscjbogxah", "S. ocphawvtlgi", "S. orcxszbujml",
                               "S. hbpgtylxqku", "S. tkujbvipoyr", "S. xeqackngdrt", 'Non-planted')))
 testthat::expect_false(all(diffs.sort$predictions$predicted.value == pred$predicted.value))
 t <- merge(diffs.sort$predictions, pred, by = c("Sources","Type","Species"))
 testthat::expect_true(all(t$predicted.value.x == t$predicted.value.y))
})

cat("#### Test for sort.alldiffs on Oats with asreml4\n")
test_that("sort.alldiffs4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  data(Oats.dat)

  m1.asr <- asreml(Yield ~ Nitrogen*Variety,
                   random=~Blocks/Wplots,
                   data=Oats.dat)
  testthat::expect_equal(length(m1.asr$vparameters),3)
  current.asrt <- as.asrtests(m1.asr)

  #Test for as.alldiffs
  Var.pred <- predict(m1.asr, classify="Nitrogen:Variety", sed=TRUE)
  wald.tab <-  current.asrt$wald.tab
  den.df <- wald.tab[match("Variety", rownames(wald.tab)), "denDF"]
  Var.diffs <- as.alldiffs(predictions = Var.pred$pvals,
                           sed = Var.pred$sed,
                           tdf = den.df)
  testthat::expect_equal(length(attributes(Var.diffs)),4)
  testthat::expect_true(is.null(attr(Var.diffs, which = "sortOrder")))

  #Test for predictPlus no sorting
  diffs <- predictPlus(m1.asr, classify = "Nitrogen:Variety",
                       wald.tab = current.asrt$wald.tab,
                       error.intervals = "Stand", tables = "none")
  testthat::expect_is(diffs, "alldiffs")
  testthat::expect_equal(nrow(diffs$predictions),12)
  testthat::expect_equal(ncol(diffs$predictions),7)
  testthat::expect_equal(as.character(diffs$predictions$Variety[1]),"Victory")
  testthat::expect_equal(length(attributes(diffs)),11)
  testthat::expect_true(is.null(attr(diffs, which = "sortOrder")))

  testthat::expect_silent(plotPredictions(data = diffs$predictions,
                                          classify ="Nitrogen:Variety",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title")))
  #TestPlot with sort
  testthat::expect_silent(plotPvalues(diffs, gridspacing = 3,
                                      sortFactor = "Variety", decreasing = TRUE))

  #Test for sort.alldiffs
  diffs.sort <- sort(diffs, sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_equal(as.character(diffs.sort$predictions$Variety[1]),"Marvellous")
  testthat::expect_equal(rownames(diffs.sort$differences)[1],"0,Marvellous")
  testthat::expect_equal(colnames(diffs.sort$p.differences)[1],"0,Marvellous")
  testthat::expect_silent(plotPvalues(diffs.sort, gridspacing = 3))

  diffs.LSD <- redoErrorIntervals(diffs, error.intervals = "halfLeast", LSDtype = "factor", LSDby = "Variety")
  diffs.LSD.sort <- sort(diffs.LSD, sortFactor = "Variety", decreasing = TRUE)

  #Test for sort.predictions.frame
  preds <- diffs$predictions
  preds.sort <- sort.predictions.frame(preds, classify = "Nitrogen:Variety", sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_equal(as.character(preds.sort$Variety[1]),"Marvellous")

  #Test for predictPresent
  mx.asr <- asreml(Yield ~ xNitrogen*Variety,
                   random=~Blocks/Wplots,
                   data=Oats.dat)

  testthat::expect_equal(length(mx.asr$vparameters),3)
  current.asrt <- as.asrtests(mx.asr)
  print(current.asrt)

  diffs <- predictPresent(mx.asr, terms = "xNitrogen:Variety",
                          x.num = "xNitrogen", x.fac = "Nitrogen",
                          x.pred.values = sort(unique(Oats.dat$xNitrogen)),
                          wald.tab = current.asrt$wald.tab,
                          error.intervals = "Stand", tables = "none",
                          sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_is(diffs[[1]], "alldiffs")
  testthat::expect_equal(nrow(diffs[[1]]$predictions),12)
  testthat::expect_equal(ncol(diffs[[1]]$predictions),7)
  testthat::expect_equal(as.character(diffs[[1]]$predictions$Variety[[1]]),"Marvellous")
  testthat::expect_equal(length(attributes(diffs$xNitrogen.Variety)),13)
  testthat::expect_equal(length(attr(diffs[[1]], which = "sortOrder")),3)

  #Test for predictPlus with sortFactor
  diffs <- predictPlus(mx.asr, classify = "xNitrogen:Variety",
                       x.num = "xNitrogen", x.fac = "Nitrogen",
                       x.pred.values = sort(unique(Oats.dat$xNitrogen)),
                       wald.tab = current.asrt$wald.tab,
                       error.intervals = "Stand", tables = "none",
                       sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_is(diffs, "alldiffs")
  testthat::expect_equal(nrow(diffs$predictions),12)
  testthat::expect_equal(ncol(diffs$predictions),7)
  testthat::expect_equal(as.character(diffs$predictions$Variety[1]),"Marvellous")
  testthat::expect_equal(length(attributes(diffs)),13)
  testthat::expect_true(all(attr(diffs, which = "sortOrder") ==
                              levels(diffs$predictions$Variety)))
  testthat::expect_true(all(attr(diffs, which = "sortOrder") ==
                              c("Marvellous","Golden Rain", "Victory")))
  testthat::expect_silent(plotPredictions(data = diffs$predictions,
                                          classify ="xNitrogen:Variety",
                                          x.num = "xNitrogen", x.fac = "Nitrogen",
                                          y = "predicted.value",
                                          error.intervals = "StandardError",
                                          y.title = attr(diffs,
                                                         which = "response.title")))
  testthat::expect_silent(plotPvalues(diffs, gridspacing = 3))

})

cat("#### Test for sort in standard order for classify on Oats with asreml4\n")
test_that("classify.sort4", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(asreml)
  library(asremlPlus)
  library(dae)
  data(Oats.dat)

  m1.asr <- asreml(Yield ~ Nitrogen*Variety,
                   random=~Blocks/Wplots,
                   data=Oats.dat)
  testthat::expect_equal(length(m1.asr$vparameters),3)
  current.asrt <- as.asrtests(m1.asr)

  #Test for as.alldiffs
  Var.pred <- predict(m1.asr, classify="Variety:Nitrogen",
                                      sed=TRUE)
  wald.tab <-  current.asrt$wald.tab
  den.df <- wald.tab[match("Variety", rownames(wald.tab)), "denDF"]
  Var.diffs <- as.alldiffs(predictions = Var.pred$pvals,
                           sed = Var.pred$sed,
                           tdf = den.df)
  testthat::expect_equal(length(attributes(Var.diffs)),4)
  testthat::expect_true(is.null(attr(Var.diffs, which = "sortOrder")))
  testthat::expect_true(all(names(Var.diffs$predictions)[1:2] ==  c("Variety","Nitrogen")))

  #Test for allDifferences without sortFactor
  Var.diffs <- allDifferences(predictions = Var.pred$pvals,
                              classify = "Variety:Nitrogen",
                              sed = Var.pred$sed, tdf = den.df)
  testthat::expect_true(all(names(Var.diffs$predictions)[1:2] ==  c("Variety","Nitrogen")))
  testthat::expect_equal(as.character(Var.diffs$predictions$Variety[1]),"Victory")

  #TestPlot with sort
  testthat::expect_silent(plotPvalues(Var.diffs, gridspacing = 4))

  #Test for allDifferences with sortFactor
  Var.diffs <- allDifferences(predictions = Var.pred$pvals,
                              classify = "Variety:Nitrogen",
                              sed = Var.pred$sed, tdf = den.df,
                              sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_true(all(names(Var.diffs$predictions)[1:2] ==  c("Variety","Nitrogen")))
  testthat::expect_equal(as.character(Var.diffs$predictions$Variety[1]),"Marvellous")
  testthat::expect_equal(length(attr(Var.diffs, which = "sortOrder")),3)

  #TestPlot with sort
  testthat::expect_silent(plotPvalues(Var.diffs, gridspacing = 3,
                                      sortFactor = "Variety", decreasing = TRUE))

  #Test for sort.alldiffs
  diffs <- allDifferences(predictions = Var.pred$pvals,
                          classify = "Variety:Nitrogen",
                          sed = Var.pred$sed, tdf = den.df)
  diffs.sort <- sort(diffs, sortFactor = "Variety", decreasing = TRUE)
  testthat::expect_equal(as.character(diffs.sort$predictions$Variety[1]),"Marvellous")
  testthat::expect_silent(plotPvalues(diffs.sort, gridspacing = 3))

})


library(ggplot2)

visualize_as_line <- function(corpus) {
    melted <- melt_and_group_columns(corpus)
    manifest <- corpus$manifest

    plot <- ggplot(melted, aes(x = id, y = value, col = variable)) +
    # ggplot(data, aes(x = c)) +
        (
            if(manifest['smooth'][[1]])
            geom_smooth(size=1, alpha=0.4, linetype=1, show.legend=!manifest['disable-legend'][[1]], level=0.98)
            else
            geom_line(size=1, alpha=0.9, linetype=1, show.legend=!manifest['disable-legend'][[1]])
        ) +
        # geom_line(size=1, alpha=0.9, linetype=1, show.legend=!manifest['disable-legend'][[1]]) +
        # geom_smooth(size=1, alpha=0.9, linetype=1, show.legend=!manifest['disable-legend'][[1]], method="loess", level=0.5) +
        # geom_smooth(aes(y = x), color="#e52165", size=1, alpha=0.9, linetype=1) +
        xlab(manifest['labels'][[1]]['x-axis']) +
        ylab(manifest['labels'][[1]]['y-axis']) +
        ggtitle(
            # eval(parse(text="expression(atop(bold('ok'),atop('ok')))"))
            eval(parse(text=paste('expression(
                atop(
                    bold(
                        ', manifest['labels'][[1]]['title'], '
                    ),
                atop(
                    ', manifest['labels'][[1]]['subtitle'], ', ""
                    )
                )
            )', sep='')))
        ) + theme(
            # axis.text.x = element_text(angle=-45, hjust=0, vjust=1),
            plot.title = element_text(size = 14, colour = "black", vjust = -1, hjust=0.5)
        ) +
        guides(color = guide_legend(override.aes = list(fill = NA)),
        linetype = guide_legend(override.aes = list(fill = NA))) +
        theme(legend.key = element_rect(fill = "white"))

    if (get_property_value(manifest, 'show-points', FALSE)) {
        plot + geom_point()
    }

    return(plot)
}


context("Vague time intervals")

## Amount, unit, default result, short, terse
all_tests <- list(
  list(  1,      "secs",  "moments ago",            "<1 min",   " 1s"),
  list( 30,      "secs",  "less than a minute ago", "<1 min",   "30s"),
  list( 50,      "secs",  "about a minute ago",     "1 min",    " 1m"),
  list( 14,      "mins",  "14 minutes ago",         "14 min",   "14m"),
  list( 70,      "mins",  "about an hour ago",      "1 hour",   " 1h"),
  list(  5,      "hours", "5 hours ago",            "5 hours",  " 5h"),
  list( 25,      "hours", "a day ago",              "1 day",    " 1d"),
  list(  5,      "days",  "5 days ago",             "5 day",    " 5d"),
  list( 30,      "days",  "about a month ago",      "1 mon",    " 1M"),
  list( 30 * 3,  "days",  "3 months ago",           "3 mon",    " 3M"),
  list(365,      "days",  "about a year ago",       "1 year",   " 1y"),
  list(365 * 10, "days",  "10 years ago",           "10 years", "10y")
)

test_that("vague_dt works", {

  sapply(all_tests, function(case) {
    dt <- as.difftime(case[[1]], units = case[[2]])
    default <- vague_dt(dt)
    short   <- vague_dt(dt, format = "short")
    terse   <- vague_dt(dt, format = "terse")
    expect_equal(default, case[[3]], info = paste(case[[1]], case[[2]], "default"))
    expect_equal(short,   case[[4]], info = paste(case[[1]], case[[2]], "short"))
    expect_equal(terse,   case[[5]], info = paste(case[[1]], case[[2]], "terse"))
  })

})

test_that("time_ago works", {

  sapply(all_tests, function(case) {
    t <- Sys.time() - as.difftime(case[[1]], units = case[[2]])
    default <- time_ago(t)
    short   <- time_ago(t, format = "short")
    terse   <- time_ago(t, format = "terse")
    expect_equal(default, case[[3]], info = paste(case[[1]], case[[2]], "default"))
    expect_equal(short,   case[[4]], info = paste(case[[1]], case[[2]], "short"))
    expect_equal(terse,   case[[5]], info = paste(case[[1]], case[[2]], "terse"))
  })

})


###############################################################################
## Purpose: this file loads COVID survey data
## from each timepoint, cleans it, and outputs a joined dataset.

## Depends:
## O1PatientDataCleanSplit.r
## 02CaregiverDataCleanSplit.r
## tidyverse

## Inputs:
## IntData/covid_pat.csv
## IntData/covid_care.csv
## IntData/partid_missing_demo.csv

## Outputs:
## IntData/covid.csv

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

## Packages
library(tidyverse)

## Functions

## Data In

### Patient

dat_p <- read_csv(
  file = "IntData/fact_pat.csv"
)

### Caregiver

dat_c <- read_csv(
  file = "IntData/fact_care.csv"
)

partid_missing_demo <- read_csv(
  file = "IntData/partid_missing_demo.csv"
)$value
## Data Tidy

### Per rubric, 1, 2, 3, 4, 5, 6, 12, 13, 14 and 15 are reverse scored
#### Patient
dat_p <- dat_p %>%
  rename("fact01" = fact1,
"fact02" = fact2,
"fact03" = fact3,
"fact04" = fact4,
"fact05" = fact5,
"fact06" = fact6,
"fact07" = fact7,
"fact08" = fact8,
"fact09" = fact9) %>%
  mutate(across(
    matches(c("01", "02", "03", "04", "05", "06", "12", "13", "14", "15")),
    ~ case_when(
      . == 0 ~ 4,
      . == 1 ~ 3,
      . == 2 ~ 2,
      . == 3 ~ 1,
      . == 4 ~ 0
    )
  ))

#### Caregiver
  dat_c <- dat_c %>%
  rename("fact01" = fact1,
"fact02" = fact2,
"fact03" = fact3,
"fact04" = fact4,
"fact05" = fact5,
"fact06" = fact6,
"fact07" = fact7,
"fact08" = fact8,
"fact09" = fact9) %>%
    mutate(across(
      matches(c("01", "02", "03", "04", "05", "06", "12", "13", "14", "15")),
      ~ case_when(
        . == 0 ~ 4,
        . == 1 ~ 3,
        . == 2 ~ 2,
        . == 3 ~ 1,
        . == 4 ~ 0
      )
    ))
### Score COVID

#### Patient

dat_p <- dat_p %>%
  rowwise() %>% ## swaps it so I can mutate this way
  mutate(sum_p = sum(c_across(fact01:fact15))) %>%
  ungroup()

#### Caregiver

dat_c <- dat_c %>%
  rowwise() %>% ## swaps it so I can mutate this way
  mutate(sum_c = sum(c_across(fact01:fact15))) %>%
  ungroup()
### Merge datasets

#### Narrow to retain only sums

##### Patient

dat_narrow_p <- dat_p %>%
  select(partid, redcap_event_name, sum_p)

##### Caregiver
dat_narrow_c <- dat_c %>%
  select(partid, redcap_event_name, sum_c)

#### Create COST dataset

dat <- dat_narrow_p %>%
  left_join(dat_narrow_c, by = c("partid", "redcap_event_name"))

#### Drop the ones with missing predictors

dat <- dat %>%
filter(!partid %in% partid_missing_demo)

### Create concordance variable

#### Directional

dat <- dat %>%
  mutate(con_dir = (sum_p - sum_c))

  ### Lengthen and add survey type

  dat <- dat %>%
  pivot_longer(
      cols = !partid:redcap_event_name,
      names_to = "observation",
      values_to = "score"
    ) %>%
    mutate(survey = "FACT") %>%
    select(partid, redcap_event_name,survey,observation,score)

## Data out

write_csv(dat, file = "IntData/fact.csv")


p_saturazione <- function(t) {
    .Call('biometeoR_p_saturazione', PACKAGE = 'biometeoR', t)
}


library(jsonlite)
library(tidyverse)
library(lubridate)

#' Function to create and update rt_estimates_<date>.csv based on Epiforecasts Rt estimates
read_epipose_rt_csv <- function()
{
    rt_url     <- "https://raw.githubusercontent.com/epiforecasts/covid-global/34310a5412e4f7448e3ee335a2a00260c9fd09a5/national-summary/rt.csv"
    rt_est_raw <- rt_url %>% read.csv
    rt_est     <- rt_est_raw %>% select(!type & !prob_control)

    return(rt_est)
}

read_oxford_policy_csv <- function()
{
    action_url <- "https://raw.githubusercontent.com/OxCGRT/covid-policy-tracker/master/data/OxCGRT_latest.csv"

    action_data_raw <- action_url %>% read.csv
    action_data <- action_data_raw %>%
        as_tibble %>%
        select(CountryCode, Date, contains("_")) %>%
        pivot_longer(cols = contains("_"), names_to = "policy_name") %>%
        mutate(flag = ifelse(str_detect(policy_name, "_Flag"), "policy_flag", "policy_value")) %>%
        mutate(policy_name = str_replace(policy_name, "_.*", ""),
               Date = (Date %>% as.character %>% as_date)) %>%
        rename(cnt = CountryCode, date = Date) %>%
        pivot_wider(names_from = flag, values_from = value)

    stringency_data <- action_data_raw %>%
        as_tibble %>%
        mutate(Date = (Date %>% as.character %>% as_date)) %>%
        rename(cnt = CountryCode, date = Date, stringency = StringencyIndex) %>%
        select(cnt, date, stringency)

    return(list(action_data = action_data, stringency_data = stringency_data))
}

create_plm_dataset_v3 <- function( rt_estimates,
                                   mobility_data,
                                   GDP_2019,
                                   stringency_data,
                                   UN_household,
                                   covid19_pkg_data,
                                   urban_rural)
{
    rt_estimates$cnt  <- unlist(lapply(rt_estimates$country, parse_iso_code))
    GDP_2019$cnt      <- unlist(lapply(GDP_2019$Country, parse_iso_code))

    mobility_data$cnt <- unlist(lapply(mobility_data$region, parse_iso_code))
    mobility_spread   <- mobility_data %>% pivot_wider(names_from = transportation_type, values_from = utilization)

    policy_spread     <- policy_data
    joined_data       <-
        full_join(
            full_join(
                full_join(
                    policy_spread,rt_estimates, by = c("date", "cnt")),
                stringency_data,by = c("date", "cnt")),
            mobility_spread,by = c("date", "cnt"))
    joined_data       <- joined_data[joined_data$cnt!="NA",]

    # For interventions represented by continuous (USD) instead of ordinal variables (E3, E4, H4, H5)
    # X_n   = variable divided by GDP (normalised to [0,1])
    # X_nc  = cumulative X_n between Jan 1 and current time
    # X_ind = 1 if X_nc > 0, 0 otherwise
    joined_data       <- joined_data %>% replace_na(list(E3=0))  %>% replace_na(list(H4=0))  %>% replace_na(list(H5=0))
    joined_data$E3_n  <- joined_data$E3_nc <- joined_data$E3_ind <- joined_data$E3
    joined_data$E4_n  <- joined_data$E4_nc <- joined_data$E4_ind <- joined_data$E4
    joined_data$H4_n  <- joined_data$H4_nc <- joined_data$H4_ind <- joined_data$H4
    joined_data$H5_n  <- joined_data$H5_nc <- joined_data$H5_ind <- joined_data$H5

    for( cnt_in in unique(joined_data$cnt)[-1])
    {
        if(dim(GDP_2019[GDP_2019$cnt==cnt_in,])[1]) GDP_in <- GDP_2019[GDP_2019$cnt==cnt_in,]$GDP else GDP_in <- 10e8  # proxy for small countries where we don't have GDP data
        joined_data[joined_data$cnt==cnt_in,]$E3_n         <- joined_data[joined_data$cnt==cnt_in,]$E3 / GDP_in
        joined_data[joined_data$cnt==cnt_in,]$E4_n         <- joined_data[joined_data$cnt==cnt_in,]$E4 / GDP_in
        joined_data[joined_data$cnt==cnt_in,]$H5_n         <- joined_data[joined_data$cnt==cnt_in,]$H5 / GDP_in
        joined_data[joined_data$cnt==cnt_in,]$H4_n         <- joined_data[joined_data$cnt==cnt_in,]$H4 / GDP_in

        if(cnt_in=="SVN") joined_data[joined_data$cnt==cnt_in,]$E3_n <- 0    # Oxford data has an issue for Slovenia at the moment, so set to zero for now

        joined_data[joined_data$cnt==cnt_in,]$E3_nc        <- cumsum(joined_data[joined_data$cnt==cnt_in,]$E3_n)
        joined_data[joined_data$cnt==cnt_in,]$E4_nc        <- cumsum(joined_data[joined_data$cnt==cnt_in,]$E4_n)

        joined_data[joined_data$cnt==cnt_in,]$E3_ind       <- as.numeric(cumsum(joined_data[joined_data$cnt==cnt_in,]$E3_n)>0)
        joined_data[joined_data$cnt==cnt_in,]$E4_ind       <- as.numeric(cumsum(joined_data[joined_data$cnt==cnt_in,]$E4_n)>0)

        joined_data[joined_data$cnt==cnt_in,]$H5_nc        <- cumsum(joined_data[joined_data$cnt==cnt_in,]$H5_n)
        joined_data[joined_data$cnt==cnt_in,]$H4_nc        <- cumsum(joined_data[joined_data$cnt==cnt_in,]$H4_n)

        joined_data[joined_data$cnt==cnt_in,]$H5_ind       <- as.numeric(cumsum(joined_data[joined_data$cnt==cnt_in,]$H5_n)>0)
        joined_data[joined_data$cnt==cnt_in,]$H4_ind       <- as.numeric(cumsum(joined_data[joined_data$cnt==cnt_in,]$H4_n)>0)
    }
}


a<-Read.summary.data()
write.csv(a,file.path(data.path,'Assess_species.csv'),row.names = F)

a<-Read.other.predator()
write.csv(a,file.path(data.path,'other_Predators.csv'),row.names = F)

a<-read.table(file.path(data.path,'summary_table_raw.out'),header=TRUE)
a<-data.frame(Species=sp.names[a$Species.n],a)
write.csv(a,file.path(data.path,'Assess_summary.csv'),row.names = F)

stom<-Read.stomach.data()
stom<-subset(stom,select=c(Year,Quarter, Predator,Prey,Predator.length.mean,Predator.weight,Predator.weight,Prey.length.mean,Prey.weight,
            N.samples,stom.input,stomcon,stomcon.hat))
write.csv(stom,file.path(data.path,'Stomachs.csv'),row.names = F)

a<-read.table(file.path(data.path,'partial_M2.out'),header=TRUE)
a<-data.frame(Predator=sp.names[a$Predator.n],Prey=sp.names[a$Prey.n],a)
a<-subset(a,select=c(Year,Quarter,Predator,Predator.age, Prey ,  Prey.age ,  Part.M2))

write.csv(a,file.path(data.path,'partial_M2.csv'),row.names = F)


#!/usr/bin/env Rscript

library(reticulate) # call Python library

use_python("/opt/python3.7/bin/python")

np <- import("numpy")
paddle <- import("paddle.fluid.core")

set_config <- function() {
    config <- paddle$AnalysisConfig("")
    config$set_model("data/model/__model__", "data/model/__params__")
    config$switch_use_feed_fetch_ops(FALSE)
    config$switch_specify_input_names(TRUE)
    config$enable_profile()

    return(config)
}

zero_copy_run_mobilenet <- function() {
    data <- np$loadtxt("data/data.txt")
    data <- data[0:(length(data) - 4)]
    result <- np$loadtxt("data/result.txt")
    result <- result[0:(length(result) - 4)]

    config <- set_config()
    predictor <- paddle$create_paddle_predictor(config)

    input_names <- predictor$get_input_names()
    input_tensor <- predictor$get_input_tensor(input_names[1])
    input_data <- np_array(data, dtype="float32")$reshape(as.integer(c(1, 3, 300, 300)))
    input_tensor$copy_from_cpu(input_data)

    predictor$zero_copy_run()

    output_names <- predictor$get_output_names()
    output_tensor <- predictor$get_output_tensor(output_names[1])
    output_data <- output_tensor$copy_to_cpu()
    output_data <- np_array(output_data)$reshape(as.integer(-1))
    #all.equal(output_data, result)
}

if (!interactive()) {
    zero_copy_run_mobilenet()
}


#------------------------------------------ overview ------------------------------------------
#' Creates model overview
#'
#' Create an overview of the models within a project. This overview includes the meta data
#' of the models and if results are available, also the objective function and run-times
#'
#' @param ... additional arguments passed to \code{\link{get_proj}}
#'
#' @export
#' @return a data frame is returned with the overview
#' @author Richard Hooijmaijers
#' @examples
#'
#' \dontrun{
#'  overview()
#' }
overview <- function(...){
  obj  <- get_proj(...)
  mdln <- names(obj)[names(obj)!="meta"]
  res1 <- lapply(mdln, function(x){
    if(class(obj[[x]]$modeleval)=="try-error"){
      c(NA,"","","","")
    }else{
      meta <- obj[[x]]$modeleval$meta
      c(ifelse(is.null(meta$imp),NA,meta$imp), ifelse(is.null(meta$desc),"",meta$desc),ifelse(is.null(meta$ref),"",meta$ref),
        ifelse(is.null(meta$data),"",meta$data),ifelse(is.null(meta$est),"",meta$est))
    }
  })
  res2 <- lapply(obj[mdln], function(x){
    if(!is.null(x$results)) c(round(x$results$OBJF,3),round(x$results$tottime,3)) else c("","")
  })
  res <- data.frame(cbind(mdln,do.call(rbind,res1),do.call(rbind,res2)),stringsAsFactors = FALSE)
  if(nrow(res)!=0){
    names(res) <- c("models","importance","description","ref","data","method","OBJF","runtime")
    dOBJF      <- lapply(res$models,function(x) round(as.numeric(res$OBJF[which(res$models==x)]) - as.numeric(res$OBJF[which(res$models==res$ref[res$models==x])]),4))
    res$dOBJF  <- sapply(dOBJF,function(x) ifelse(length(x)==0,NA,x))
    res        <- res[,c("models","importance","description","ref","data","method","OBJF","dOBJF","runtime")]
  }
  res
}