#####################################################################################################
#################### Aim: estimate well-being weights for health states for WAHE
#####################################################################################################
rm(list=ls())
dev.off()

library(MASS)
library(sjmisc)
library(tidyr)
library(dplyr)

data.dir <- "C:\\Users\\Magdalena\\demography\\happyindex\\data\\SILC"
setwd(data.dir)

mydata <- read.table(file="silc2018new.csv", sep=",", header=TRUE)

#
# ###data clean-up to be included later in the data preparation files
# mydata <- read.table(file="silc2018.csv", sep=",", header=TRUE)
# #### if year of interview is missing we assume 2018
# ### if month of interview is missing we assume 06
# mydata$yearint[is.na(mydata$yearint)] <- 2018
# mydata$monthint[is.na(mydata$monthint)] <- 6
# mydata$monthbir[is.na(mydata$monthbir)] <- 6
# cases <- rep(1, nrow(mydata))
# age <- mydata$yearint-mydata$yearbir
# age[(mydata$monthint>mydata$monthbir)] <-0
# age2 <- mydata$yearint-mydata$yearbir+1
# mydata2 <- cbind(mydata,cases,age)
# mydata2$age[age==0] <- age2[age==0]
#
# ## drop all missing values
# chronicdata <- mydata2[(!is.na(mydata2$chronic) & !is.na(mydata2$sex)),]
# mydata <- chronicdata[(!is.na(chronicdata$happy) & chronicdata$happy<99),]
# #do not remove countries DE,MT
# Ghappy <- mydata[(mydata$country!="MT"& mydata$country!="DE"),]
#
# #we take only age 17+, 5-year age groups and 80+
# # remove DE (nobody older than 74), MT
# mydata <- Ghappy[(Ghappy$age>16),]
#
# agegr <- rep(0, nrow=nrow(mydata))
# mydata <- cbind(mydata,agegr)
# ages <- c(15,30,40,seq(50,80,5))
#
# for (i in 1:length(ages)){
#   mydata$agegr[mydata$age>=ages[i]] <- ages[i]
# }
#
# ### replace country names with numbers
# replco <- cbind(sort(unique(mydata$country)),(1:length(unique(mydata$country))))
#
# for (i in 1:nrow(replco)){
#   mydata$country[mydata$country==replco[i,1]] <- replco[i,2]
# }
# ###add 1 to well-being variable to remove 0, it might mess up the estimations
# mydata$happy <- mydata$happy+1
#
# write.table(mydata, file="silc2018new.csv", sep=",")
# write.table(replco, file="countriesnames.csv", sep=",")

######## extra data preparation steps for the  ordered probit models
mydata$happy <- ordered(as.factor(mydata$happy))
mydata$country <- as.factor(as.numeric(as.character(mydata$country)))

###### help variables
sex <- sort(unique(mydata$sex))
country <- sort(unique(mydata$country))

#####################################################################################################
############## GALI
#####################################################################################################
mydata$GALI2 <- plyr::revalue(as.factor(mydata$GALI), c("1"="3", "3"="1"))
mydata$GALI2 <- as.factor(as.numeric(as.character(mydata$GALI2)))
mydata$age2 <- (mydata$age)^2/100

GALIweights <- function(thedata){
  GALImodel <- polr(happy ~ GALI2+age+age2, data= thedata, method = "probit")
  ourmodel <- coef(summary(GALImodel))

  coef0 <- ourmodel[substr(rownames(ourmodel),1,1)==1][1]
  coef9 <- ourmodel[substr(rownames(ourmodel),1,2)==10][1]
  divi <- coef9-coef0

  GALIw <- ourmodel[substr(rownames(ourmodel),1,1)=="G"][1:2]
  GALIweights <- cbind(i,j,t(GALIw), coef0, coef9, t(1+ GALIw/divi))
  return(GALIweights)
  }

##set the file first and then append for other country,sex,age combinations
i=1
j=1

thedata <- mydata[(mydata$country==country[i]& mydata$sex==sex[j]),]
GALIw111 <- GALIweights(thedata)
colnames(GALIw111) <- c("country","sex", "coeffG1","coeffG2","thr1","thr10","GALI1", "GALI2")
write.table(GALIw111, file="GALIweights.csv", sep=",", row.names=FALSE)

j=2
thedata <- mydata[(mydata$country==country[i]& mydata$sex==sex[j]),]
GALIw12k <- GALIweights(thedata)
write.table(GALIw12k, file="GALIweights.csv", sep=",", row.names=FALSE, col.names=FALSE, append=TRUE)

for (i in 2:length(country)){
  for (j in 1:2){
      thedata <- mydata[(mydata$country==country[i]& mydata$sex==sex[j]),]
      GALIwijk <- GALIweights(thedata)
      write.table(GALIwijk, file="GALIweights.csv", sep=",", row.names=FALSE, col.names=FALSE, append=TRUE)
    }
  }

###############################################################################################################
##################### chronic
###############################################################################################################
mydata$chronic[mydata$chronic==2] <- 0
mydata$chronic <- as.factor(mydata$chronic)

chrweights <- function(thedata){
  chrmodel <- polr(happy ~ chronic+age+age2, data= thedata, method = "probit")
  ourmodel <- coef(summary(chrmodel))

  coef0 <- ourmodel[substr(rownames(ourmodel),1,1)==1][1]
  coef9 <- ourmodel[substr(rownames(ourmodel),1,2)==10][1]
  divi <- coef9-coef0

  chrw <- ourmodel[substr(rownames(ourmodel),1,1)=="c"][1]
  chrw <- cbind(i,j, chrw, coef0,coef9, t(1+ chrw/divi))
  return(chrw)
}

##set the file first and then append for other country,sex,age combinations
i=1
j=1

thedata <- mydata[(mydata$country==country[i]& mydata$sex==sex[j]),]
chronicw <- chrweights(thedata)
colnames(chronicw) <- c("country","sex","coeff","thr1","thr10","chronic")
write.table(chronicw, file="chronicweights.csv", sep=",", row.names=FALSE)

j=2
thedata <- mydata[(mydata$country==country[i]& mydata$sex==sex[j]),]
chronicw12k <- chrweights(thedata)
write.table(chronicw12k, file="chronicweights.csv", sep=",", row.names=FALSE, col.names=FALSE, append=TRUE)

for (i in 2:length(country)){
  for (j in 1:2){
      thedata <- mydata[(mydata$country==country[i]& mydata$sex==sex[j]),]
      chronicwijk <- chrweights(thedata)
      write.table(chronicwijk, file="chronicweights.csv", sep=",", row.names=FALSE, col.names=FALSE, append=TRUE)
    }
  }

###################################################################################################################
############Self-rated health
###################################################################################################################
mydata$selfrated <- as.factor(mydata$selfrated)

SRweights <- function(thedata){
  SRmodel <- polr(happy ~ selfrated+age+age2, data= thedata, method = "probit")
  ourmodel <- coef(summary(SRmodel))

  coef0 <- ourmodel[substr(rownames(ourmodel),1,1)==1][1]
  coef9 <- ourmodel[substr(rownames(ourmodel),1,2)==10][1]
  divi <- coef9-coef0

  SRw <- ourmodel[substr(rownames(ourmodel),1,1)=="s"][1:4]
  SRwe <- cbind(i,j, t(SRw), coef0,coef9, t(1+ SRw/divi))
  return(SRwe)
}

##set the file first and then append for other country,sex,age combinations
i=1
j=1

thedata <- mydata[(mydata$country==country[i]& mydata$sex==sex[j]),]
SRw111 <- SRweights(thedata)
colnames(SRw111) <- c("country","sex", "cSR2", "cSR3", "cSR4","cSR5", "coef1","coef10", "SR2","SR3", "SR4","SR5")
write.table(SRw111, file="selfweights.csv", sep=",", row.names=FALSE)

j=2
thedata <- mydata[(mydata$country==country[i]& mydata$sex==sex[j]),]
SRw12k <- SRweights(thedata)
write.table(SRw12k, file="selfweights.csv", sep=",", row.names=FALSE, col.names=FALSE, append=TRUE)

for (i in 2:length(country)){
  for (j in 1:2){
      thedata <- mydata[(mydata$country==country[i]& mydata$sex==sex[j]),]
      SRwijk <- SRweights(thedata)
      write.table(SRwijk, file="selfweights.csv", sep=",", row.names=FALSE, col.names=FALSE, append=TRUE)
    }
  }

####################################################################################################################
################# multidimensional
####################################################################################################################
Ghappy4 <- na.omit(mydata)
Ghappy4$multi <- as.numeric(paste(Ghappy4$chronic, Ghappy4$GALI2,Ghappy4$selfrated, sep=""))
Ghappy4$multi <- as.factor(Ghappy4$multi)

multiweights <- function(thedata){
  multimodel <- polr(happy ~ multi+age+age2, data= thedata, method = "probit")
  ourmodel <- coef(summary(multimodel))

  coef0 <- ourmodel[substr(rownames(ourmodel),1,1)==1][1]
  coef9 <- ourmodel[substr(rownames(ourmodel),1,2)==10][1]
  divi <- coef9-coef0

  multiw <- ourmodel[substr(rownames(ourmodel),6,9)!=""][1:(length(ourmodel[substr(rownames(ourmodel),6,9)!=""])/3)]
  multiwi <- 1+multiw/divi
  multiwnames <- substr(rownames(ourmodel)[substr(rownames(ourmodel),6,9)!=""],6,9)
  multiout <- cbind(i,j,multiwnames,multiw, coef0,coef9,multiwi)
  return(multiout)
}

i=1
j=1
thedata <- Ghappy4[(Ghappy4$country==country[i]& Ghappy4$sex==sex[j]),]
thedata <- droplevels(thedata)
multiw <- multiweights(thedata)

colnames(multiw) <- c("country","sex", "level", "coeff","thr1","thr10","weight")
write.table(multiw, file="multiweights.csv", sep=",", row.names=FALSE)

j=2
thedata <- Ghappy4[(Ghappy4$country==country[i]& Ghappy4$sex==sex[j]),]
thedata <- droplevels(thedata)
multiw12k <- multiweights(thedata)
write.table(multiw12k, file="multiweights.csv", sep=",", row.names=FALSE, col.names=FALSE, append=TRUE)

for (i in 2:29){
  for (j in 1:2){
      thedata <- Ghappy4[(Ghappy4$country==country[i]& Ghappy4$sex==sex[j]),]
      thedata <- droplevels(thedata)
      multiwijk <- multiweights(thedata)
      write.table(multiwijk, file="multiweights.csv", sep=",", row.names=FALSE, col.names=FALSE, append=TRUE)
  }
}


#Create a base raster file from a shapefile

rm(list=ls())

library(sf)
library(raster)
library(tidyverse)

belmontDataPath <- "C:/Users/k1076631/Google Drive/Research/Projects/Belmont/Data/"
setwd(paste(belmontDataPath, "Brazil/AdminBoundaries/IBGE", sep=""))

#read shape file
BRadmin = st_read("BRadmin.shp")

#5km base for use to ensure identical origin to 1km
BRadmin_latlon <- raster(ncols=901,
                    nrows=891,
                    xmn=-75.00007,
                    ymn=-34.01103,
                    ymx=6.053681,
                    xmx=-34.48571,
                    resolution=0.044966,
                    vals=NULL)

#create rasters from the shp using the empty raster
BRmunis_r_latlon <- rasterize(as(BRadmin, "Spatial"), y = BRadmin_latlon, field = "CD_GEOCMUn")
BRstates_r_latlon <- rasterize(as(BRadmin, "Spatial"), y = BRadmin_latlon, field = "State")

#remove non-simulated states
simStates <- c(29,31,35,41,42,43,50,51,52,17)                   #ids of states to simulate
simdf <- as.data.frame(cbind(simStates,simStates))           #create a df for next two functions
sim_BRstates_r_latlon <- subs(BRstates_r_latlon, simdf)            #retain simStates values, otherwise set to NA
sim_BRmunis_r_latlon <- mask(BRmunis_r_latlon,sim_BRstates_r_latlon)  #mask munis raster using NAs in simStates raster

#trim the extent of the raster (on NAs as default)
#sim_BRstates_r_latlon <- trim(sim_BRstates_r_latlon)
#sim_BRmunis_r_latlon <- trim(sim_BRmunis_r_latlon)

#check
#plot(sim_BRmunis_r_latlon)
#plot(sim_BRstates_r_latlon)

#writing to file
writeRaster(sim_BRmunis_r_latlon, "sim10_BRmunis_latlon_5km.asc", "ascii", overwrite = T, NAflag = -9999)
writeRaster(sim_BRstates_r_latlon, "sim10_BRstates_latlon_5km.asc", "ascii", overwrite = T, NAflag = -9999)

writeRaster(BRmunis_r_latlon, "BRmunis_latlon_5km.asc", "ascii", overwrite = T, NAflag = -9999)
writeRaster(BRstates_r_latlon, "BRstates_latlon_5km.asc", "ascii", overwrite = T, NAflag = -9999)


# script to test for differences in reworking between molina and other members
# Eric Barefoot
# Nov 2019

# load libraries

library(tidyverse)
library(here)
library(broom)
library(lme4)
library(devtools)  # for the next thing
library(colorspace)
library(paleohydror)
library(purrr)
library(rsample)

if (interactive()) {
    require(colorout)
}

# load data

chamb_data = readRDS(file = here('data','derived_data', 'chamberlin_model_data.rds'))
chamb_model = readRDS(file = here('data','derived_data', 'chamberlin_stat_model.rds'))
model = readRDS(file = here('data','derived_data','piceance_3d_model_data.rds'))
field = readRDS(file = here('data','derived_data','piceance_field_data.rds'))
combined = readRDS(file = here('data', 'derived_data', 'piceance_field_model_data.rds'))
boots = readRDS(file = here('data', 'derived_data', 'piceance_bar_preservation.rds'))

# bootstrap sampling already done in calc_3D_model_stats.r

format_function = function(pval, signif = 0.001) {
  if (pval > signif) {
    prep = paste('p =', signif(pval, 3))
  } else {
    prep = paste('p \\ll', signif)
  }
  return(prep)
}

# but maybe we want fewer resamples. modified script to only take four resamples.

source(here('analysis', 'analyzing_reworking', 'calc_3D_model_stats.r'))

barpres = model %>% filter(interpretations %in% c('full','partial','truncated')) %>%
transmute(formation = case_when(
  formation == 'molina' ~ 'molina',
  TRUE ~ 'bounding'),
  interp = case_when(
  interpretations == 'full' ~ 'full',
  TRUE ~ 'partial')
)

data_tab = table(barpres$interp, barpres$formation)

barpres_test = chisq.test(data_tab)

# quick hypothesis test since these are normally distributed.

# fit = aov(perc_full ~ formation, data = barpres)

# p_comp_reworking = summary(fit)[[1]][["Pr(>F)"]][1]

p_comp_reworking = format_function(barpres_test$p.value)

# if (barpres_test$p.value > 0.001) {
#   p_comp_reworking = paste('p =', barpres_test$p.value)
# } else {
#   p_comp_reworking = paste('p \\ll 0.001')
# }

# save(p_comp_reworking, file = here('data', 'data_summaries', 'reworking_pvalue.rda'))

barfractions = model %>% filter(interpretations %in% c('full','partial','truncated')) %>%
group_by(interpretations, formation) %>% summarize(n = n()) %>%
pivot_wider(values_from = n, names_from = interpretations) %>%
mutate(perc = 100 * full / (full + partial + truncated))

shirePerc = barfractions %>% filter(formation == 'shire') %>% pull(perc)
molinaPerc = barfractions %>% filter(formation == 'molina') %>% pull(perc)
atwellPerc = barfractions %>% filter(formation == 'atwell_gulch') %>% pull(perc)

boot_sds = boots %>% group_by(formation) %>% summarize(sdPres = sd(perc_full) * 100)

estimates = tibble(meanPres = c(shirePerc,molinaPerc,atwellPerc), formation = c('shire','molina','atwell_gulch'))

pres = inner_join(boot_sds, estimates, by = 'formation')

save(p_comp_reworking,
pres,
barpres_test,
file = here('data', 'data_summaries', 'paleo_pres.rda'))


# Zemljevid

GEO <- read_csv2("podatki/Tabela20.csv", locale=locale(encoding="Windows-1250")) %>%
  select(ImePriimek, Drzava, Premozenje, -X1)

geo_vrednosti <- GEO %>% group_by(Drzava) %>%
  summarise(Vsota_premozenja = sum(Premozenje), Stevilo_oseb = n_distinct(ImePriimek))

naj_bogatas <- GEO %>% group_by(Drzava) %>% slice_max(Premozenje, n=1)

geo_vrednosti <- left_join(geo_vrednosti, naj_bogatas, by="Drzava")

# zemlevid sveta ki prikazuje vsoto skupnega premozenja po drzavah in najbogatejse za posamezno drzavo
data("World")
tmap_mode("view")
svet <- tm_shape(merge(World, geo_vrednosti %>% filter(Drzava != "United States"),
                       by.x = "name", by.y = "Drzava" )) +
  tm_polygons("Vsota_premozenja", title = "Vsota premoženja (mio €)") +
  tm_text("ImePriimek", size = 1.5) +
  tm_view(text.size.variable = TRUE) +
  tm_shape(merge(World, geo_vrednosti %>% filter(Drzava == "United States"),
                 by.x = "name", by.y = "Drzava" )) + tm_polygons(col="red3") +
  tm_text("ImePriimek", size = 1.5)


library(mice)
library(randomForest)
set.seed(42)

# read training data

train <- read.csv('data/train.csv', sep=',', na.strings=c(''))

# drop some rows
train$PassengerId <- NULL
train$Cabin <- NULL
train$Ticket <- NULL
train$Name <- NULL
train$Fare <- NULL

# mark some rows as nominal
train$Sex <- as.factor(train$Sex)
train$Embarked <- as.factor(train$Embarked)
train$Survived <- as.factor(train$Survived)

# read test set
test <- read.csv('data/test.csv', sep=',')

test$Cabin <- NULL
test$Ticket <- NULL
test$Name <- NULL
test$Fare <- NULL

test$Sex <- as.factor(test$Sex)
test$Embarked <- as.factor(test$Embarked)

# impute missing values

mi <- mice(train)
train <- complete(mi)

mi <- mice(test)
test <- complete(mi)

summary(train)
summary(test)

model <- randomForest(
	Survived ~ Pclass + Sex + Age + SibSp + Parch + Embarked + Pclass:Sex + Pclass:Age + Age:Sex,
	data=train,
	ntree=2000
)
test$Survived <- predict(model, newdata=test, type="response")

write.csv(test[,c("PassengerId", "Survived")], file="predictions.csv", row.names=FALSE, quote=FALSE)


library("xml2")
library("dplyr")
library("stringr")
library("rlist")
library("xts")
library("quantmod")
library("PortfolioAnalytics")
library("DEoptim")
library("ROI")
require("ROI.plugin.glpk")
require("ROI.plugin.quadprog")

filter<-function(data,sour,ac,gf,riskave){
    ###initialize
    ac_all<-c()
    gf_all<-c()

    risk_all<-c() #annual volatility
    outline_all<-data.frame()
    fund_num<-ncol(sour)/2

    outfund_all<-data.frame()
    sel_all<-c()
    data2<-data.frame()
    reorderfund_all<-data.frame()
    return_all<-c()
    sorted_return_all<-c()
    writefund_all<-data.frame()
    finalfund_all<-data.frame()

    ###select asset class
    for(i in 1:4){
        if(ac[i]>3){next}
        acfilter<-switch(i,match(data[which(data$Asset.Class == "Equity"), ][,1],data[,1]),
            match(data[which(data$Asset.Class == "Fixed Income"), ][,1],data[,1]),
            match(data[which(data$Asset.Class == "Mixed Allocation"), ][,1],data[,1]),
            match(data[which(data$Asset.Class == "Money Market"), ][,1],data[,1]))
        ac_all<-c(ac_all,acfilter)
    }

    ###select geographical focus
    for(i in 1:7){
        if(gf[i]>4){next}
        gffilter<-switch(i,match(data[which(data$Geographical.Focus == "Africa& Middle West Region"), ][,1],data[,1]),
            match(data[which(data$Geographical.Focus == "Asian Pacific Region"), ][,1],data[,1]),
            match(data[which(data$Geographical.Focus == "Greater China"), ][,1],data[,1]),
            match(data[which(data$Geographical.Focus == "International"), ][,1],data[,1]),
            match(data[which(data$Geographical.Focus == "Latin American Region"), ][,1],data[,1]),
            match(data[which(data$Geographical.Focus == "U.S."), ][,1],data[,1]))
        gf_all<-c(gf_all,gffilter)
    }

    ###first selected
    fil<-intersect(gf_all,ac_all)
    cn<-max(index(fil))#total amount of funds we've got in the first selection

    ###continue to choose if first selected funds are less than 50

    while(cn<50){
        for(i in 1:7){
            if(gf[i]<5){next}
            gffilter<-switch(i,match(data[which(data$Geographical.Focus == "Africa& Middle West Region"), ][,1],data[,1]),
                match(data[which(data$Geographical.Focus == "Asian Pacific Region"), ][,1],data[,1]),
                match(data[which(data$Geographical.Focus == "European Region"), ][,1],data[,1]),
                match(data[which(data$Geographical.Focus == "Greater China"), ][,1],data[,1]),
                match(data[which(data$Geographical.Focus == "International"), ][,1],data[,1]),
                match(data[which(data$Geographical.Focus == "Latin American Region"), ][,1],data[,1]),
                match(data[which(data$Geographical.Focus == "U.S."), ][,1],data[,1]))
            gf_all<-c(gf_all,gffilter)
            fil<-intersect(gf_all,ac_all)
            cn<-max(index(fil))
            if(cn>50){break}
        }
    }

    for(k1 in fil){
        if(is.null(sour[2,(2*k1-1)])){break}
        if(as.Date(sour[1,(2*k1-1)])>="2014-12-01"){next}
        #print(111)
        #print(sour[1,(2*k1-1)])}
        tmp<-as.character(sour[,(2*k1-1)])
        temp<-as.Date(tmp,format="%Y/%m/%d")
        #print(222)

        data1<-data.frame(temp,sour[,2*k1])
        data1<-na.omit(data1,data1[,1:2])
        data1<-xts(data1[,2],data1[,1])
        #data1<-xts(data1[,2],as.Date(data1[,1]))
        colnames(data1)<-colnames(sour[(2*k1-1)])
        return<-Return.calculate(data1)
        #print(555)
        return_cu<-Return.cumulative(return)
        data2<-merge.xts(data2,data1)
        risk<-StdDev.annualized(return)#risk
        risk_all<-c(risk_all,risk)
    }
    #print("out!")
    fund_num<-ncol(data2)
    #print("hi")
    ###sort by volatility, and choose by input

    sorted_risk_all<-sort(risk_all,decreasing=FALSE)
    reorder<-match(sorted_risk_all,risk_all)

    ###reform the initial data, ranking by volatility, 1 for the least volatility[1552*708]
    for(k in reorder){
        reorderfund<-data2[,(k)]
        reorderfund<-na.omit(reorderfund,reorderfund[,1])
        reorderfund_all<-merge.xts(reorderfund_all,reorderfund)
    }
    #print("hi")

    group_num = 5###客户风险接受程度划分组数
    itv<-ceiling((fund_num)/group_num)

    ###for every 风险接受程度, find the first 5 funds

    for(ins in 1:group_num){
        return_all<-c()
        sorted_return_all<-c()
        outfund_all<-c()
        #risk_all<-c()
        index_upper<-itv*ins
        if(ins==group_num)
        {
            index_upper<-fund_num
        }
        selected<-((ins-1)*itv+1):index_upper#because fund_num/10 might not be integer

        ###for every ins, 3 for instance, find funds for this ins and calculate their average return
        for(k in selected){
            outfund<-reorderfund_all[,k]#
            outfund<-na.omit(outfund,outfund[,1])
            #outfund<-xts(outfund[,2],as.Date(outfund[,1]))
            return<-Return.calculate(outfund)
            return_cu<-Return.cumulative(return)
            return_all<-c(return_all,return_cu)
            outfund_all<-merge.xts(outfund_all,outfund)
        }
        sorted_return_all<-sort(return_all,decreasing=TRUE)
        selected_index<-match(head(sorted_return_all,5),return_all)

        ###find those 5 funds
        for(i in selected_index){
            writefund<-outfund_all[,i]
            writefund_all<-merge.xts(writefund_all,writefund)
            fund1<-na.omit(writefund,writefund[,1])
            ###for debugging
            #r<-Return.calculate(fund1)
            #rcu<-Return.cumulative(r)
            #print(rcu)
            #ri<-StdDev.annualized(r)#risk
            #print(ri)
        }
}

#writefund_all<-as.data.frame(writefund_all)
#write.csv(writefund_all,file="writefund.csv",na="")
    #print(ncol(writefund_all))
    #print(final_index)
    intv<-5
    final_index<-((riskave-1)*intv+1):(riskave*intv)
    for(i in final_index){
        final<-writefund_all[,i]
        finalfund_all<-merge.xts(finalfund_all,final)
    }

    finalfund_all<-as.data.frame(finalfund_all)
    #write.csv(finalfund_all,file="fivefund.csv",na="")
    finalfund_all = cbind(rownames(finalfund_all),finalfund_all)
    return(finalfund_all)
}

seven<-function(data){
    #data = read.csv("fund_5.csv",header = TRUE, fileEncoding = "UTF-8", sep=",", na.strings = "")
    data1_2 = read.csv("newfund.csv",header = TRUE, fileEncoding = "UTF-8", sep=",", na.strings = "")

    #print(data1_2[1,4])
    #print(data1_2[1,8])
    #print(ncol(data))
    data[,1] = as.Date(data[,1])
    fund_1 = data1_2[,8:9]
    fund_1[,1] = as.Date(fund_1[,1])
    fund_2 = cbind(as.Date(data1_2[,1]),data1_2[,5])

    max_date = nrow(data)
    fund_tmp = data.frame(base1 = -1*(1:max_date),base2 = -1*(1:max_date))
    date_tmp = data.frame(base1 = -1*(1:max_date),base2 = -1*(1:max_date))

    fund_1_date = 1
    fund_2_date = nrow(data1_2)
    while(!is.na(fund_1[fund_1_date,1])) fund_1_date = fund_1_date+1
    fund_1_date = fund_1_date - 1
    fund_tmp[1:fund_1_date,1] = fund_1[1:fund_1_date,2]
    fund_tmp[1:fund_2_date,2] = fund_2[1:fund_2_date,2]
    date_tmp[1:fund_1_date,1] = fund_1[1:fund_1_date,1]
    date_tmp[1:fund_2_date,2] = fund_2[1:fund_2_date,1]

    i = 1
    while (i <= max_date){
        if(is.na(date_tmp[i,1])||date_tmp[i,1]<0){
            date_tmp[i,1] = data[i,1]
            fund_tmp[i,1] = NA
            fund_1_date = fund_1_date + 1
        }
        else if(date_tmp[i,1] > data[i,1]){
            if(i < max_date){
                fund_tmp[(i+1):(fund_1_date+1),1] = fund_tmp[(i):(fund_1_date),1]
                date_tmp[(i+1):(fund_1_date+1),1] = date_tmp[(i):(fund_1_date),1]
                date_tmp[i,1] = data[i,1]
                fund_tmp[i,1] = NA
            }
            else if (i == max_date){
                date_tmp[i,1] = data[i,1]
                fund_tmp[i,1] = NA
            }
            fund_1_date = fund_1_date + 1
        }
        else if(date_tmp[i,1] < data[i,1]){
            #print(i)
            #print(date_tmp[i,1])
            #print(data[i,1])
            #print(fund_1_date)
            fund_tmp[(i):(fund_1_date),1] = fund_tmp[(i+1):(fund_1_date+1),1]
            date_tmp[(i):(fund_1_date),1] = date_tmp[(i+1):(fund_1_date+1),1]
            fund_tmp[fund_1_date,1] = NA
            date_tmp[fund_1_date,1] = NA
            fund_1_date = fund_1_date - 1
            i = i - 1
        }
        i = i + 1
        #print(i)
    }

    i = 1
    while (i <= max_date){
        if(is.na(date_tmp[i,2])||date_tmp[i,2]<0){
            date_tmp[i,2] = data[i,1]
            fund_tmp[i,2] = NA
            fund_2_date = fund_2_date + 1
        }
        else if(date_tmp[i,2] > data[i,1]){
            if(i < max_date){
                fund_tmp[(i+1):(fund_2_date+1),2] = fund_tmp[(i):(fund_2_date),2]
                date_tmp[(i+1):(fund_2_date+1),2] = date_tmp[(i):(fund_2_date),2]
                date_tmp[i,2] = data[i,1]
                fund_tmp[i,2] = NA
            }
            else if (i == max_date){
                date_tmp[i,2] = data[i,1]
                fund_tmp[i,2] = NA
            }
            fund_2_date = fund_2_date + 1
        }
        else if(date_tmp[i,2] < data[i,1]){
            #print(i)
            #print(date_tmp[i,2])
            #print(data[i,1])
            #print(fund_2_date)
            fund_tmp[(i):(fund_2_date),2] = fund_tmp[(i+1):(fund_2_date+1),2]
            date_tmp[(i):(fund_2_date),2] = date_tmp[(i+1):(fund_2_date+1),2]
            fund_tmp[fund_2_date,2] = NA
            date_tmp[fund_2_date,2] = NA
            fund_2_date = fund_2_date - 1
            i = i - 1
        }
        i = i + 1
        #print(i)
    }

    fund_tmp = fund_tmp[1:max_date,]
    data = cbind(data,fund_tmp)
    return (data)
}

fund_completion<-function(data){
    #data<-read.csv("fund_5.csv",header=TRUE,sep=",")
    data <- seven(data)
    #print(data)

    rows = nrow(data)
    fund_num = ncol(data) - 1
    ###Step 1: Complete all funds
    for (j in 1:fund_num){
        for (i in 1:rows){
            if(is.na(data[i,j+1])){
                if(i != rows){
                    #last_data = data[i-1,j+1]
                    i_tmp = i + 1;
                    while(is.na(data[i_tmp,j+1]) && i_tmp<=rows)
                    {
                        i_tmp = i_tmp + 1
                        #print(j)
                        #print(i_tmp)
                    }
                    if(i == 1)
                    {
                        data[i,j+1] = data[i_tmp,j+1]
                    }
                    else if (i_tmp == rows + 1) {
                        data[i,j+1] = data[i-1,j+1]
                    }
                    else{
                        data[i,j+1] = (data[i-1,j+1] + data[i_tmp,j+1]) / 2
                    }
                }
                else{
                    data[i,j+1] = data[i-1,j+1]
                }
            }
        }
    }

    return(data)
    #write.csv(data,"complete.csv",na="",row.names = F)
}

weights<-function(data) {
    ### Read data from last milestone
    #setwd("C:/Users/EDZ/Desktop/理享�?/Portfolio_Proj") #can be specified
    #data = read.csv("complete.csv",header = TRUE, sep=",", na.strings = "")
    seven_data = data[,7:8]
    #data = final_fund_all

    #Number of funds in the final portforlio, can be specified
    portfolio_num = 5
    fund_num = portfolio_num*10

    if(FALSE){
        fund_num_tmp = floor(fund_num/10)
        fund_num_upper = fund_num_tmp * ins
        if(ins == 10)
        {
            fund_num_upper = fund_num
        }
        selected <- data[,(fund_num_tmp*(ins-1)+1+1):(fund_num_upper+1)] #first plus one�? begin with 6-10; second plus one: first column of data is date
        selected <- cbind(data[,1],selected)
        #print(selected)
        data <- selected
    }

    data_print_out <- data
    #data_print_out <- cbind(data_print_out,seven_data)
    #print(rownames(data))
    #date_tmp = as.Date(rownames(data),format="%Y-%m-%d")
    #data = cbind(date_tmp,data)

    ### Construct the system by Markowitz model
    #Initialization
    rows = nrow(data)
    returns_tmp = c()
    return_tmp = data.frame()

    for (j in 1:portfolio_num){
        data_tmp <- data.frame(data[,1],data[,j+1])
        data_tmp <- xts(data_tmp[,2],as.Date(data_tmp[,1]))
        return_tmp <- periodReturn(data_tmp,period="daily",type="log")
        returns_tmp <- cbind(returns_tmp,return_tmp)
    }

    returns <- returns_tmp[,1:5]
    rownames(returns) <- data[,1]
    colnames(returns) <- c("fd1", "fd2", "fd3", "fd4","fd5")
    funds <- colnames(returns)
    init <- portfolio.spec(assets = funds)
    init <- add.constraint(portfolio=init, type="leverage",min_sum=1.00, max_sum=1.00)
    init <- add.constraint(portfolio=init, type="box", min=0.10, max=0.40)
    #print.default(init)

    #6.3 Minimize variance with ROI
    minvar <- add.objective(portfolio=init, type="risk", name="var")
    opt_minvar <- optimize.portfolio(R=returns, portfolio=minvar, optimize_method="ROI", trace=TRUE)
    #print(opt_minvar)
    #plot(opt_minvar, risk.col="StdDev", return.col="mean", main="Minimum Variance Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,200))

    w = extractWeights(opt_minvar)
    #print(head(data_print_out,5))
    #print(typeof(data_print_out[1,1]))
    #print(data_print_out[1,1])
    #print(head(w))
    #print(typeof(w[1]))

    data_print_out[,1] = as.integer(data_print_out[,1])
    data_print_out_final = rbind(data_print_out,w)
    #print("hi")
    return_data = data_print_out_final[,-1]
    #write.csv(return_data,"weight.csv",na="")
    return_data = rbind(colnames(return_data),return_data)
    return (return_data)
}

R_final<-function(init,source,asset_class,geo,risk_aversion){
        init<-read.csv("filter.csv",header=TRUE, sep=",")
        source<-read.csv("bloomberg.csv",header=T,sep=",")
    if(FALSE){
        asset_class<-c(1,2,3,4)
        geo<-c(2,4,3,1,6,5,7)
        risk_aversion<-3 #may get specified
    }
    level_1<-filter(init,source,asset_class,geo,risk_aversion)
    level_2<-fund_completion(level_1)
    level_3<-weights(level_2)
    return(level_3)
}


library(keras)

library(tensorflow)

use_virtualenv("r-tensorflow")

install_keras()

mnist <- dataset_mnist()

x_train <- mnist$train$x
y_train <- mnist$train$y
x_test <- mnist$test$x
y_test <- mnist$test$y


#!/usr/bin/Rscript
# Radar interpretation
library(tidyverse)
library(stringr)
library(gtools)
library(raster)
library(geosphere)
library(RCurl)
setwd("/mnt/R")
source("../config.r")

#02 = Melbourne
#49 = Yarrawonda

rad_tab=data.frame(rad=c("02","49"),time=c(6,10))
this_rad="49"

ss_rad = rad_tab[rad_tab$rad==this_rad,]
interval = ss_rad$time

date = as.POSIXct(format(Sys.time(),tz="UTC"),tz="UTC") - (interval) * 60
mins = formatC((as.numeric(format(date,"%M")) %/% interval) * interval,width=2,flag="0")
fdate = paste0(format(date,"%Y%m%d%H"),mins)
#2018 03 04 15 18

url_root = sprintf("ftp://ftp-reg.cloud.bom.gov.au/radar/IDR%sPOL.%s.txt",this_rad,fdate)

dat=getURLContent(url_root,userpwd=bompwd,binary=FALSE)
dat=strsplit(dat,"\n")[[1]]

delta_table = c("!","[","a","b","c","]","@",
                "/","d","e","f","g","h","\\",
                "i","j","k","<","l","m","n",
                "o","p","-",".","+","q","r",
                "s","t","u",">","v","w","x",
                "(","y","S","T","U","V",")",
                "$","{","W","X","Y","}","&")
delta_table = asc(delta_table)
delta_matrix = matrix(delta_table,nrow=7,byrow=TRUE)

delta_lookup = function(x){
  pos = which(delta_matrix==x)
  col=ceiling(pos / 7)
  vcol=col-4

  row = which(x == delta_matrix[,col])
  row=row-4
  return(c(vcol,row))
}

line_lat = dat[str_detect(dat,"LATITUDE")] %>% str_split(" ",simplify=TRUE)
LAT = -as.numeric(line_lat[2])

line_stn = dat[str_detect(dat,"STNID")] %>% str_split(" ",simplify=TRUE)
STNID = as.numeric(line_stn[2])

line_lat = dat[str_detect(dat,"LATITUDE")] %>% str_split(" ",simplify=TRUE)
LAT = -as.numeric(line_lat[2])

line_lon = dat[str_detect(dat,"LONGITUDE")] %>% str_split(" ",simplify=TRUE)
LON = as.numeric(line_lon[2])

line_RNGRES =  dat[str_detect(dat,"RNGRES")] %>% str_split(" ",simplify=TRUE)
RNGRES = as.numeric(line_RNGRES[2])

line_ANGRES =  dat[str_detect(dat,"ANGRES")] %>% str_split(" ",simplify=TRUE)
ANGRES = as.numeric(line_ANGRES[2])

line_STARTRNG =  dat[str_detect(dat,"STARTRNG")] %>% str_split(" ",simplify=TRUE)
STARTRNG = as.numeric(line_STARTRNG[2])

line_ENDRNG =  dat[str_detect(dat,"ENDRNG")] %>% str_split(" ",simplify=TRUE)
ENDRNG = as.numeric(line_ENDRNG[2])

line_VIDRES =  dat[str_detect(dat,"VIDRES")] %>% str_split(" ",simplify=TRUE)
VIDRES = as.numeric(line_VIDRES[2])

start_dat = which(str_detect(dat,"COPYRIGHT"))+1
end_dat = which(str_detect(dat,"END RADAR IMAGE"))-1

dat = dat[start_dat:end_dat]

nbins = (ENDRNG - STARTRNG) / RNGRES

out_mat = matrix(0,nrow=360,ncol=nbins)

for(i in dat){
  ang = as.numeric(substr(i,2,4))
  #print(ang)
  # Grab encoding vector
  avec = substr(i,5,nchar(i))

  # Convert to ascii
  avec = asc(avec)

  # Generate flagmode vector
  mvec = character(length=length(avec))

  # Mark ABS absolute encoding values
  mvec[avec >= strtoi(41,16) & avec <= strtoi(50,16)] = "ABS"

  # Mark RLE run-length encoding values
  mvec[avec >= strtoi(30,16) & avec <= strtoi(39,16)] = "RLE"

  buffer=rep(NA,nbins)
  output_position = 1
  input_position = 1
  RLE_cache = 0
  while(input_position < length(mvec)){
    # If we have an absolute value, just store it
    if(mvec[input_position]=="ABS"){
      buffer[output_position] = abs(avec[input_position])-65
      RLE_cache = abs(avec[input_position])-65
      input_position = input_position+1
      output_position = output_position+1
      next
    }
    # If we have an RLE - count digits, then insert RLE_cache previous value
    if(mvec[input_position]=="RLE"){
      if(mvec[input_position+1]!="RLE"){
        RLE_count = as.numeric(chr(avec[input_position]))
        skip=0
      }

      if(mvec[input_position+1]=="RLE" & mvec[input_position+2]!="RLE"){
        RLE_count = as.numeric(paste0(chr(avec[input_position]),chr(avec[input_position+1])))
        skip=1
      }

      if(mvec[input_position+1]=="RLE" & mvec[input_position+2]=="RLE"){
        RLE_count = as.numeric(paste0(chr(avec[input_position]),chr(avec[input_position+1]),chr(avec[input_position+2])))
        skip=2
      }
      buffer[output_position:(output_position+(RLE_count-1))]=RLE_cache
      output_position = output_position + RLE_count
      input_position = input_position + skip + 1
      next
    }

    if(mvec[input_position] == ""){
      deltas = delta_lookup(avec[input_position])
      RLE_cache = RLE_cache+ deltas[1]
      buffer[output_position]=RLE_cache
      RLE_cache = RLE_cache+ deltas[2]
      buffer[output_position+1]=RLE_cache
      output_position = output_position + 2
      input_position = input_position + 1
    }
  }

  out_mat[ang,] = buffer

}
out_mat[is.na(out_mat)]=0

## Make translation matrix (radar-dependent)

#d2r=function(x){x*pi/180}
#r2d=function(x){x*(180/pi)}

## Define grid

grid_extent=extent(LON-2,LON+2,LAT-2,LAT+2)
grid_layer=raster(grid_extent,nrows=800,ncols=800)

#dist_template=grid_layer
#ang_template=grid_layer

#for(this_cell in 1:(800*800)){

#  cp=xyFromCell(dist_template,this_cell)

#  cell_lon=cp[1]
#  cell_lat=cp[2]

#  d=distCosine(p1=c(cell_lon,cell_lat),p2=c(LON,LAT),r=6371000)

#  ag=bearing(p1=c(LON,LAT),p2=c(cell_lon,cell_lat))

#  dist_template[this_cell]=d
#  ang_template[this_cell]=ag
#}

#ang_template2 =floor(ang_template %% 361)+1

#dist_template2 = (dist_template-STARTRNG)/RNGRES
#dist_template2 = dist_template2+1
#dist_template2[dist_template2<1]=1
#dist_template2 = floor(dist_template2)

#pos_vec = values(dist_template2-1) * 360 + values(ang_template2)

pos_vec = readRDS(paste0("radar/posvec_",this_rad,".RDS"))
values(grid_layer) = out_mat[pos_vec]
proj4string(grid_layer)="+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0 "

values(grid_layer)[values(grid_layer)==0]=NA

colortable(grid_layer)=c("#FFFFFF00", "#CCCCFFDD", "#9999FFEE", "#6565FFff", "#3232FFff", "#0000FFff", "#3300CBff" ,"#660098ff" ,"#990065ff" ,"#CC0032ff","#FF0000ff", "#CC0000ff" ,"#980000ff" ,"#650000ff", "#320000ff", "#000000ff",rep("#FFFFFF00",256-16))
writeRaster(grid_layer,sprintf("radar/rad%s_%s.tif",fdate,this_rad),overwrite=TRUE,options=c("TIFFTAG_GDAL_NODATA=0"))

# Expand indexed tif to a rgba vrt
cmd="/usr/bin/gdal_translate"
args=c("-of vrt","-expand rgba",sprintf("radar/rad%s_%s.tif",fdate,this_rad),sprintf("radar/rad%s_%s.vrt",fdate,this_rad))
system2(cmd,args)

cmd="/usr/bin/gdal2tiles.py"
args=c(sprintf("radar/rad%s_%s.vrt",fdate,this_rad),"-a 0,0,0,0","-z 5-11",sprintf("tiles/rad_%s_%s",fdate,this_rad))
system2(cmd,args)

# Remove tifs

unlink(sprintf("radar/rad%s_%s.vrt",fdate,this_rad))
unlink(sprintf("radar/rad%s_%s.tif",fdate,this_rad))

# Remove old tiles

date = as.POSIXct(format(Sys.time(),tz="UTC"),tz="UTC") - (interval-1) * 60 - 120*60
flist = file.info(list.files("tiles",pattern="rad_",full.names=TRUE))
todel = rownames(flist)[flist$ctime < date]
unlink(todel,recursive=TRUE)
source("cat.r")


#' @include translate-sql-window.r
#' @include translate-sql-helpers.r
#' @include sql-escape.r
NULL

sql_if <- function(cond, if_true, if_false = NULL) {
  build_sql(
    "CASE WHEN (", cond, ")", " THEN (", if_true, ")",
    if (!is.null(if_false))
      build_sql(" WHEN NOT(", cond, ") THEN (", if_false, ")"),
    " END"
  )
}

#' @export
#' @rdname sql_variant
#' @format NULL
base_scalar <- sql_translator(
  `+`    = sql_infix("+"),
  `*`    = sql_infix("*"),
  `/`    = sql_infix("/"),
  `%%`   = sql_infix("%"),
  `^`    = sql_prefix("power", 2),
  `-`    = function(x, y = NULL) {
    if (is.null(y)) {
      if (is.numeric(x)) {
        -x
      } else {
        build_sql(sql("-"), x)
      }
    } else {
      build_sql(x, sql(" - "), y)
    }
  },

  `!=`    = sql_infix("!="),
  `==`    = sql_infix("="),
  `<`     = sql_infix("<"),
  `<=`    = sql_infix("<="),
  `>`     = sql_infix(">"),
  `>=`    = sql_infix(">="),

  `%in%` = function(x, table) {
    if (is.sql(table) || length(table) > 1) {
      build_sql(x, " IN ", table)
    } else {
      build_sql(x, " IN (", table, ")")
    }
  },

  `!`     = sql_prefix("not"),
  `&`     = sql_infix("and"),
  `&&`    = sql_infix("and"),
  `|`     = sql_infix("or"),
  `||`    = sql_infix("or"),
  xor     = function(x, y) {
    sql(sprintf("%1$s OR %2$s AND NOT (%1$s AND %2$s)", escape(x), escape(y)))
  },

  abs     = sql_prefix("abs", 1),
  acos    = sql_prefix("acos", 1),
  acosh   = sql_prefix("acosh", 1),
  asin    = sql_prefix("asin", 1),
  asinh   = sql_prefix("asinh", 1),
  atan    = sql_prefix("atan", 1),
  atan2   = sql_prefix("atan2", 2),
  atanh   = sql_prefix("atanh", 1),
  ceil    = sql_prefix("ceil", 1),
  ceiling = sql_prefix("ceil", 1),
  cos     = sql_prefix("cos", 1),
  cosh    = sql_prefix("cosh", 1),
  cot     = sql_prefix("cot", 1),
  coth    = sql_prefix("coth", 1),
  exp     = sql_prefix("exp", 1),
  floor   = sql_prefix("floor", 1),
  log     = function(x, base = exp(1)) {
    if (isTRUE(all.equal(base, exp(1)))) {
      sql_expr(ln(!!x))
    } else {
      sql_expr(log(!!base, !!x))
    }
  },
  log10   = sql_prefix("log10", 1),
  round   = sql_prefix("round", 2),
  sign    = sql_prefix("sign", 1),
  sin     = sql_prefix("sin", 1),
  sinh    = sql_prefix("sinh", 1),
  sqrt    = sql_prefix("sqrt", 1),
  tan     = sql_prefix("tan", 1),
  tanh     = sql_prefix("tanh", 1),

  tolower = sql_prefix("lower", 1),
  toupper = sql_prefix("upper", 1),
  trimws = sql_prefix("trim", 1),
  nchar   = sql_prefix("length", 1),
  substr = function(x, start, stop) {
    start <- as.integer(start)
    length <- pmax(as.integer(stop) - start + 1L, 0L)

    build_sql(sql("substr"), list(x, start, length))
  },

  `if` = sql_if,
  if_else = function(condition, true, false) sql_if(condition, true, false),
  ifelse = function(test, yes, no) sql_if(test, yes, no),

  case_when = function(...) sql_case_when(...),

  sql = function(...) sql(...),
  `(` = function(x) {
    build_sql("(", x, ")")
  },
  `{` = function(x) {
    build_sql("(", x, ")")
  },
  desc = function(x) {
    build_sql(x, sql(" DESC"))
  },

  is.null = function(x) sql_expr(((!!x) %is% NULL)),
  is.na = function(x)  sql_expr(((!!x) %is% NULL)),
  na_if = sql_prefix("NULL_IF", 2),
  coalesce = sql_prefix("coalesce"),

  as.numeric = sql_cast("NUMERIC"),
  as.double = sql_cast("NUMERIC"),
  as.integer = sql_cast("INTEGER"),
  as.character = sql_cast("TEXT"),

  c = function(...) c(...),
  `:` = function(from, to) from:to,

  between = function(x, left, right) {
    build_sql(x, " BETWEEN ", left, " AND ", right)
  },

  pmin = sql_prefix("min"),
  pmax = sql_prefix("max"),

  `%>%` = `%>%`,

  # stringr functions

  # SQL Syntax reference links:
  #   MySQL https://dev.mysql.com/doc/refman/5.7/en/string-functions.html
  #   Hive: https://cwiki.apache.org/confluence/display/Hive/LanguageManual+UDF#LanguageManualUDF-StringFunctions
  #   Impala: https://www.cloudera.com/documentation/enterprise/5-9-x/topics/impala_string_functions.html
  #   PostgreSQL: https://www.postgresql.org/docs/9.1/static/functions-string.html
  #   MS SQL: https://docs.microsoft.com/en-us/sql/t-sql/functions/string-functions-transact-sql
  #   Oracle: https://docs.oracle.com/middleware/bidv1221/desktop/BIDVD/GUID-BBA975C7-B2C5-4C94-A007-28775680F6A5.htm#BILUG685
  str_length      = sql_prefix("LENGTH"),
  str_to_upper    = sql_prefix("UPPER"),
  str_to_lower    = sql_prefix("LOWER"),
  str_replace_all = function(string, pattern, replacement){
                      build_sql(
                        "REPLACE(", string, ", ", pattern, ", ", replacement, ")"
                      )},
  str_detect      = function(string, pattern){
                      build_sql(
                        "INSTR(", pattern, ", ", string, ") > 0"
                      )},
  str_trim        = function(string, side = "both"){
                      build_sql(
                        sql(ifelse(side == "both" | side == "left", "LTRIM(", "(")),
                        sql(ifelse(side == "both" | side == "right", "RTRIM(", "(")),
                        string
                        ,"))"
                      )}
)

base_symbols <- sql_translator(
  pi = sql("PI()"),
  `*` = sql("*"),
  `NULL` = sql("NULL")
)

#' @export
#' @rdname sql_variant
#' @format NULL
base_agg <- sql_translator(
  # SQL-92 aggregates
  # http://db.apache.org/derby/docs/10.7/ref/rrefsqlj33923.html
  n          = function() sql("COUNT()"),
  mean       = sql_aggregate("avg"),
  var        = sql_aggregate("variance"),
  sum        = sql_aggregate("sum"),
  min        = sql_aggregate("min"),
  max        = sql_aggregate("max"),
  n_distinct = function(...) {
    vars <- sql_vector(list(...), parens = FALSE, collapse = ", ")
    build_sql("COUNT(DISTINCT ", vars, ")")
  }
)

#' @export
#' @rdname sql_variant
#' @format NULL
base_win <- sql_translator(
  # rank functions have a single order argument that overrides the default
  row_number   = win_rank("row_number"),
  min_rank     = win_rank("rank"),
  rank         = win_rank("rank"),
  dense_rank   = win_rank("dense_rank"),
  percent_rank = win_rank("percent_rank"),
  cume_dist    = win_rank("cume_dist"),
  ntile        = function(order_by, n) {
    win_over(
      build_sql("NTILE", list(as.integer(n))),
      win_current_group(),
      order_by %||% win_current_order()
    )
  },

  # Variants that take more arguments
  first = function(x, order_by = NULL) {
    win_over(
      build_sql("first_value", list(x)),
      win_current_group(),
      order_by %||% win_current_order()
    )
  },
  last = function(x, order_by = NULL) {
    win_over(
      build_sql("last_value", list(x)),
      win_current_group(),
      order_by %||% win_current_order()
    )
  },
  nth = function(x, n, order_by = NULL) {
    win_over(
      build_sql("nth_value", list(x, as.integer(n))),
      win_current_group(),
      order_by %||% win_current_order()
    )
  },

  lead = function(x, n = 1L, default = NA, order_by = NULL) {
    win_over(
      build_sql("LEAD", list(x, n, default)),
      win_current_group(),
      order_by %||% win_current_order()
    )
  },
  lag = function(x, n = 1L, default = NA, order_by = NULL) {
    win_over(
      build_sql("LAG", list(x, as.integer(n), default)),
      win_current_group(),
      order_by %||% win_current_order()
    )
  },

  # Recycled aggregate fuctions take single argument, don't need order and
  # include entire partition in frame.
  mean  = win_aggregate("avg"),
  var   = win_aggregate("variance"),
  sum   = win_aggregate("sum"),
  min   = win_aggregate("min"),
  max   = win_aggregate("max"),
  n     = function() {
    win_over(sql("COUNT(*)"), win_current_group())
  },
  n_distinct = function(...) {
    vars <- sql_vector(list(...), parens = FALSE, collapse = ", ")
    win_over(build_sql("COUNT(DISTINCT ", vars, ")"), win_current_group())
  },

  # Cumulative function are like recycled aggregates except that R names
  # have cum prefix, order_by is inherited and frame goes from -Inf to 0.
  cummean = win_cumulative("mean"),
  cumsum  = win_cumulative("sum"),
  cummin  = win_cumulative("min"),
  cummax  = win_cumulative("max"),

  # Manually override other parameters --------------------------------------
  order_by = function(order_by, expr) {
    old <- set_win_current_order(order_by)
    on.exit(set_win_current_order(old))

    expr
  }
)

#' @export
#' @rdname sql_variant
#' @format NULL
base_no_win <- sql_translator(
  row_number   = win_absent("row_number"),
  min_rank     = win_absent("rank"),
  rank         = win_absent("rank"),
  dense_rank   = win_absent("dense_rank"),
  percent_rank = win_absent("percent_rank"),
  cume_dist    = win_absent("cume_dist"),
  ntile        = win_absent("ntile"),
  mean         = win_absent("avg"),
  sd           = win_absent("sd"),
  var          = win_absent("var"),
  cov          = win_absent("cov"),
  cor          = win_absent("cor"),
  sum          = win_absent("sum"),
  min          = win_absent("min"),
  max          = win_absent("max"),
  n            = win_absent("n"),
  n_distinct   = win_absent("n_distinct"),
  cummean      = win_absent("mean"),
  cumsum       = win_absent("sum"),
  cummin       = win_absent("min"),
  cummax       = win_absent("max"),
  nth          = win_absent("nth_value"),
  first        = win_absent("first_value"),
  last         = win_absent("last_value"),
  lead         = win_absent("lead"),
  lag          = win_absent("lag"),
  order_by     = win_absent("order_by"),
  str_flatten = win_absent("str_flatten"),
  count        = win_absent("count")
)

# case_when ---------------------------------------------------------------

sql_case_when <- function(...) {
  # TODO: switch to dplyr::case_when_prepare when available

  formulas <- dots_list(...)
  n <- length(formulas)

  if (n == 0) {
    abort("No cases provided")
  }

  query <- vector("list", n)
  value <- vector("list", n)

  for (i in seq_len(n)) {
    f <- formulas[[i]]

    env <- environment(f)
    query[[i]] <- escape(eval_bare(f[[2]], env), con = sql_current_con())
    value[[i]] <- escape(eval_bare(f[[3]], env), con = sql_current_con())
  }

  clauses <- purrr::map2_chr(query, value, ~ paste0("WHEN (", .x, ") THEN (", .y, ")"))
  sql(paste0(
    "CASE\n",
    paste0(clauses, collapse = "\n"),
    "\nEND"
  ))
}


# -----

my_string <- "ciao"
print(my_string)

# -----
print("------------------------------------------")
# -----

bool <- TRUE
num <- 3
int <- 4L
complex <- 5 + 5i
ch <- "stringa"
raw <- charToRaw(ch)
vec <- c("a", "b", "c")
l <- list("a", 0, TRUE, c("a", "b"))
m <- matrix(c("a", "b", "c", "d", "e", "f"), nrow = 3, ncol = 2)
a <- array(c("a", "b", "c", "d", "e"), dim = c(4, 3, 2, 2))
f <- factor(c(0, 1, 2, 2, 2, 1, "a", "a", "b"))
data_frame <- data.frame(
    sex = c("male", "bene"),
    age = c(23, 24)
)

print(class(bool))
print(class(num))
print(class(int))
print(class(complex))
print(class(ch))
print(class(raw))
print(class(vec)) # prints character
print(class(l))
print(class(m))
print(class(a))
print(class(f))
print(class(data_frame))

# -----
print("------------------------------------------")
# -----

var.with.dots <- "che cazzo è sta merda" # nolint
print(var.with.dots)
5 -> right_var_ma_che_cazz
print(right_var_ma_che_cazz)
7 -> a -> b
cat(a, b)
print("haho")
"hidden " -> .hidden_var
print(.hidden_var)
mah <<- 1
print(mah)

# -----
print("------------------------------------------")
# -----

print(ls())
print(ls(pattern = "v"))
print(ls(all.names = TRUE))

# -----
print("------------------------------------------")
# -----

# remove everything
rm(list = ls())
print(ls())

# -----
print("------------------------------------------")
# -----

a <- c(1, 2, 3)
b <- c(3, 2, 1)

print(a + b)
print(a - b)
print(a * b)
print(a / b)
print(a %% b)
print(a %/% b)
print(a^b)

print(a > b)
# ....
print(c(1, 0, 0) && c(1, 0, 0)) # takes just first elements

# -----
print("------------------------------------------")
# -----

print(2:8)
print(2:-4)
print(1 %in% 0:5)

m <- matrix(c(1, 2), nrow = 4, ncol = 6)
print(m)
print(t(m) %*% m)

# -----
print("------------------------------------------")
# -----

if (is.integer(40L)) {
    print("it is integer")
} else {
    print("merda")
}

# -----
print("------------------------------------------")
# -----

a <- switch(1,
    "one",
    "two"
)
print(a)
a <- switch("bar",
    foo = {
        "one"
    },
    bar = {
        "two"
    }
)
print(a)

# -----
print("------------------------------------------")
# -----

i <- 0
repeat {
    print(i)
    i <- i + 1
    if (i > 5) break
}

i <- 0
while (i <= 5) {
    print(i)
    i <- i + 1
}

for (l in LETTERS[1:5]) {
    if (l == "C") {
        next
    }
    print(l)
}

# -----
print("------------------------------------------")
# -----

print(1:10)
print("/")
print(seq(1, 10))

my_procedure <- function(n = 2) {
    v <- 1:n
    print(v^2)
}
my_procedure((5))
my_procedure(n = 4)

new_function <- function(a, b) {
    print(a^2)
    print(a)
}
# Evaluate the function without supplying one of the arguments.
new_function(6)

# -----
print("------------------------------------------")
# -----

phrase <- paste("ciao", "come", "va", sep = " ")
print(phrase)

# -----
print("------------------------------------------")
# -----

# Total number of digits displayed. Last digit rounded off.
result <- format(23.123456789, digits = 9)
print(result)

# Display numbers in scientific notation.
result <- format(c(6, 13.14521), scientific = TRUE)
print(result)

# The minimum number of digits to the right of the decimal point.
result <- format(23.47, nsmall = 5)
print(result)

# Format treats everything as a string.
result <- format(6)
print(result)

# Numbers are padded with blank in the beginning for width.
result <- format(13.7, width = 6)
print(result)

# Left justify strings.
result <- format("Hello", width = 8, justify = "l")
print(result)

# Justfy string with center.
result <- format("Hello", width = 8, justify = "c")
print(result)

# -----
print("------------------------------------------")
# -----

for (n in 0:nchar("ciao")) {
    print(n)
}

# -----
print("------------------------------------------")
# -----

print(0.5:10.5)
print(seq(0.5, 10.5, by = 1.5))

# -----
print("------------------------------------------")
# -----

t <- c("Lun", "Mar", "Mer", "Gio", "Ven", "Sab", "Dom")
print(
    t[c(1, 3, 5)]
)
print(
    t[c(1, 5, 3, 5)]
)
print(
    t[c(FALSE, TRUE, FALSE, FALSE, TRUE, TRUE)]
)
print(
    t[c(-2, -5)]
)

print(sort(t))
print(sort(t, decreasing = TRUE))

t[9] <- "Non esiste"
print(t)

# -----
print("------------------------------------------")
# -----

l <- list(0, 1, "ciao")
c("zero", "uno", "saluto") -> names(l)
print(l)
cat(">>>>>", "\n")
print(l[1]) # returns a list
print(l["saluto"]) # returns a list
print(l$saluto) # returns an el
cat(">>>>>", "\n")
la <- list(1, 2)
lb <- list(3, 4)
names(lb) <- c("a", "b")
print(c(la, lb))
la <- unlist(la)
print(la)

# -----
print("------------------------------------------")
# -----

m <- matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2)
print(m)

m <- matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2, byrow = TRUE)
print(m)

m <- matrix(c(1, 2, 3, 4),
    nrow = 2, ncol = 2,
    dimnames = list(c("x", "y"), c("a", "b"))
)
print(m)

m <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8),
    nrow = 4, ncol = 4, byrow = TRUE,
    dimnames = list(c("a", "b", "c", "d"), c("e", "f", "g", "h"))
)
print(m)

print(m[1, 2])
print(m[1])
print(m[1, ])
print(m[, 1])
print(m[, 1, drop = FALSE])
print(m[1:2, 1:2])
print(m[c(2, 1), c(3, 1, 3)])
print(m[c("b", "d"), ])

# -----
print("------------------------------------------")
# -----

a <- array(c(1, 2, 3, 4),
    dim = c(4, 4, 2),
    dimnames = list(
        c("a", "b", "c", "d"),
        c("e", "f", "g", "h"), c("Matrix 1", "matrix 2")
    )
)
print(a)

new_array <- array(c(0, 1, 2), dim = c(3, 3, 2))
print(new_array)

result <- apply(new_array, c(3, 2, 1), sum)
print(result)

# -----
print("------------------------------------------")
# -----

# -----
print("------------------------------------------")
# -----

data <- c("pizza", "pasta", "pasta", "pizza", "pane")
f <- factor(data)
print(f)

height <- c(110, 170, 190)
weight <- c(60, 80, 90)
sex <- c("male", "female", "male")

df <- data.frame(height, weight, sex)
print(df)
print(df$sex)
print(df$height)

f <- gl(3, 2, labels = c("cane", "gatto", "mulo"))
print(f)

# -----
print("------------------------------------------")
# -----

name <- c("Eugenio", "Marco", "Luca")
surname <- c("Berretta", "Rossi", "Verdi")
age <- c(23, 34, 45)
school <- c("TUM", "UNITN", "UNIBZ")

df <- data.frame(name, surname, age, school)
print(df)

print(df$school)
print(df["school"])
print(df[c(1, 2), c(2, 1)])
print(df[, 4])

print(
    str(df)
)
print(summary(df))

# -----
print("------------------------------------------")
# -----

print(.libPaths())
# print(library()) # nolint
# install.packages("ggplot2") # nolint

# -----
print("------------------------------------------")
# -----

paste(getwd(), "assets", sep = "/") -> input_dir
input_path <- paste(input_dir, "prova.csv", sep = "/")
output_path <- paste(input_dir, "prova_2.csv", sep = "/")
print(input_path)
data <- read.csv(input_path)
print(data)
# data <- read.csv(input_path, header = FALSE) # nolint
# print(data) # nolint

print(data$salary)
print(data[, 3])
print(data["salary"])
print(data[3])
print(max(data$salary))
print(max(data["salary"]))
print(">>>>>>>>>")
print(subset(data, salary > 100 & id < 6))
print(">>>>>>>>>")
new_data <- subset(data, salary > 100 & id < 6)
write.csv(new_data, output_path)

# -----
print("------------------------------------------")
# -----

grepl("xlsx",installed.packages()) ->> v
print(length(v))
print(any(v))

# -----
print("------------------------------------------")
# -----

is_json_pckg_installed = any(grepl("rjson", installed.packages()))
if (!is_json_pckg_installed) {
    install.packages("rjson")
}

library("rjson")
input_path = paste(input_dir, "prova.json", sep = "/")
result <- fromJSON(file = input_path)
print(result)
print(">>>>>>>>>>>>>>>>")
print(result$a$c)


# FUnction used to get the value for the comparison
getmode <- function(v) {
   uniqv <- unique(v)
   uniqv[which.max(tabulate(match(v, uniqv)))]
}

#Data = AFTER

# Function to create the Grafic for Climatelabs
Fig.Global <- function(Data, ancho=750, alto=750, visible = TRUE, ...){

# Selecting the data
Test =  Data %>% filter( Variable != "Comments")

#Questions = Test %>% select(Variable, Descripcion) %>% group_by(Variable, Descripcion) %>% tally()
Test$Value = as.numeric(Test$Value)  # Puttin 'Value'as numeric

# Evaluacion del indice
Test = Test %>% group_by(Variable, University)%>% summarise(Level = getmode(Value))

if (Test$University %>% as.factor() %>% levels() %>% length() > 1 ) {

   # Add variable Global for Consortium
   Climatelabs = Test %>% group_by(Variable) %>% summarise(Level = mean(Level)) %>% mutate( University= "0- Tieurs-lieu Global" ) %>%
      select(Variable, University, Level)

   Test = rbind(Test, Climatelabs)

}

# PUtting the Description of the variables
Test = merge(Test, Questions, by="Variable") %>% as_tibble()

Test = Test %>% arrange(Role.Climatelabs)

# Identificando la longitud para la division
var = length( as.factor(Test$Variable) %>% levels())

# Organizacion de los factores por competencia
Test$Variable = as.factor(Test$Variable)

Test$Variable <- factor(Test$Variable, levels = Questions$Variable)

# Grafica
Test = Test %>% group_by(University) %>% mutate(degree =seq(from=0, to=360-(360/var), length.out= var ))

Test$o <- Test$Level * sin(Test$degree * pi / 180) # SOH
Test$a <- Test$Level * cos(Test$degree * pi / 180) # CAH
Test$X.exterior <- 5.8 * sin(Test$degree * pi / 180) # Outer ring x
Test$Y.exterior <- 5.8 * cos(Test$degree * pi / 180) # Outer ring y

Test$X10 <- 1 * sin(Test$degree * pi / 180) # 10% ring x
Test$Y10 <- 1 * cos(Test$degree * pi / 180) # 10% ring y
Test$X20 <- 2 * sin(Test$degree * pi / 180) # 20% ring x
Test$Y20 <- 2 * cos(Test$degree * pi / 180) # 20% ring y
Test$X30 <- 3 * sin(Test$degree * pi / 180) # 30% ring x
Test$Y30 <- 3 * cos(Test$degree * pi / 180) # 30% ring y
Test$X40 <- 4 * sin(Test$degree * pi / 180) # 40% ring x
Test$Y40 <- 4 * cos(Test$degree * pi / 180) # 40% ring y
Test$X50 <- 5 * sin(Test$degree * pi / 180) # 50% ring x
Test$Y50 <- 5 * cos(Test$degree * pi / 180) # 50% ring y

# Creacion de Grafica
Test = Test %>% arrange(University)

p = plot_ly( )

p = p %>%
   add_trace(
      x = c(0, Test$X.exterior[1:7], 0), y = c(0, Test$Y.exterior[1:7],0),
      color =  'rgba(255, 212, 96, 0.5)',  fillcolor = 'rgba(230, 233, 255, 0.5)',
      type = 'scatter',
      visible = TRUE,
      showlegend = FALSE,
      mode = "lines",
      line = list(color = "#d3d3d3", dash = "2px"),
      showlegend = FALSE,
      fill = 'toself',
      hoverinfo = "text",
      name="Facilitador",
      text = "Facilitador" ) %>%
   add_trace(
      x = c(0, Test$X.exterior[8:12], 0), y = c(0, Test$Y.exterior[8:12],0),
      color =  'rgba(255, 212, 96, 0.5)',  fillcolor = 'rgba(255, 230, 232, 0.5)',
      type = 'scatter',
      visible = TRUE,
      showlegend = FALSE,
      mode = "lines",
      line = list(color = "#d3d3d3", dash = "2px"),
      showlegend = FALSE,
      fill = 'toself',
      text = "Maker",
      hoverinfo = "text",
      name="Maker" ) %>%
   add_trace(
      x = c(0, Test$X.exterior[13:17], 0), y = c(0, Test$Y.exterior[13:17],0),
      color =  'rgba(255, 212, 96, 0.5)',  fillcolor = 'rgba(248, 248, 248, 0.5)',
      type = 'scatter',
      visible = TRUE,
      showlegend = FALSE,
      mode = "lines",
      line = list(color = "#d3d3d3", dash = "2px"),
      showlegend = FALSE,
      fill = 'toself',
      text = "Manager",
      hoverinfo = "text",
      name="Manager" ) %>%
   add_trace(
      x = c(0, Test$X.exterior[18:23], 0), y = c(0, Test$Y.exterior[18:23],0),
      color =  'rgba(255, 212, 96, 0.5)',  fillcolor = 'rgba(233, 255, 234, 0.6)',
      type = 'scatter',
      visible = TRUE,
      showlegend = FALSE,
      mode = "lines",
      line = list(color = "#d3d3d3", dash = "2px"),
      showlegend = FALSE,
      fill = 'toself',
      text = "Visionario",
      hoverinfo = "text",
      name="Visionario" )

p = p %>%
      add_annotations(
                       x = c(6,6,-6,-6),
                    y = c(6,-6,-6,6),
                    text = c("Facilitateur", "Maker", "Manager", "Visionnaire"),
                    xref = "x",
                    yref = "y",
                    showarrow = F,
                    font = list(color = '#264E86',
                                family = 'Palatino',
                                size = 20)
                    )

for(i in 1:23) {
   p <- add_trace(
      p,
      x = c(Test$X.exterior[i],0),
      y = c(Test$Y.exterior[i],0),
      type="scatter",
     # evaluate = TRUE,
      line = list(color = "#d3d3d3", dash = "2px"),
      showlegend = FALSE,
      hoverinfo = "text",
      text = Test$Descripcion[i],
      hoverlabel=list(font =list(family="Times New Roman"))
   )
}

# Conecting the lines
line.final = Test[1,]
Test=rbind(Test,line.final)
rm(line.final)

Perfil =
   p %>%
   add_trace(x = Test$X.exterior, y = Test$Y.exterior,
             text = Test$Variable,
             hoverinfo = "text",
             textposition = "top middle", mode = "text",
             textfont = list(family= "Helvetica" ,color = '#8e8e8e', size = 13) ,
             #line = list(color = "#d3d3d3", dash = "2px", shape = "spline"),
             text = paste(Test$Descripcion ),
             showlegend = FALSE) %>%

   add_trace(x = rep(0,6), y = c(0:5),
             text = c("", "Novice", "Novice Avancé", "Competente", "Performante", "Expert"),
             textposition = "top middle", mode = "text",
             textfont = list(family= "Helvetica" ,color = '#8e8e8e', size = 13),
             showlegend = FALSE)   %>%

   add_trace(x = Test$o, y = Test$a, color = Test$University,
             mode = "lines+markers",
             hoverinfo = "text",
             fill = 'toself',
             visible = visible,
             #visible = "legendonly",
             showlegend = TRUE,
             text = paste(Test$University, Test$Level,  Test$Descripcion, sep="\n")) %>%

   add_trace(x = Test$X10, y = Test$Y10, mode = "lines",
             line = list(color = "#d3d3d3", dash = "1px", shape = "spline"),
             hoverinfo = "none",
             showlegend = FALSE) %>%

   add_trace(x = Test$X20, y = Test$Y20, mode = "lines",
             line = list(color = "#d3d3d3", dash = "1px", shape = "spline"),
             hoverinfo = "none",
             showlegend = FALSE) %>%

   add_trace(x = Test$X30, y = Test$Y30, mode = "lines",
             line = list(color = "#d3d3d3", dash = "1px", shape = "spline"),
             hoverinfo = "none",
             showlegend = FALSE) %>%

   add_trace(x = Test$X40, y = Test$Y40, mode = "lines",
             line = list(color = "#d3d3d3", dash = "1px", shape = "spline"),
             hoverinfo = "none",
             showlegend = FALSE) %>%

   add_trace(x = Test$X50, y = Test$Y50, mode = "lines",
             line = list(color = "#d3d3d3", dash = "3px", shape = "spline"),
             hoverinfo = "none",
             showlegend = FALSE) %>%
   layout(
      legend = list(orientation = 'h'),
      #plot_bgcolor  = "rgba(0, 0, 0, 0)",
      #paper_bgcolor = "rgba(0, 0, 0, 0)",
      #fig_bgcolor   = "rgba(0, 0, 0, 0)",
      #autosize = FALSE,
      hovermode = "closest",
      width = ancho,
      #height = 900,
      height = alto,
      autosize = TRUE,
      #autoscale = TRUE,
      xaxis = list(showticklabels = FALSE, zeroline = FALSE, showgrid = FALSE),
      yaxis = list(showticklabels = FALSE, zeroline = FALSE, showgrid = FALSE)
   )

return(Perfil)

}


# https://www.jakeruss.com/cheatsheets/stargazer/
# https://www.rdocumentation.org/packages/stargazer/versions/5.2.2/topics/stargazer

suppressMessages(library(stargazer))
library(xtable)
library(functional)

load_model <- function(path){
    model <- readRDS(path)
    return(model)
}

format_covariate_labels <- function(model){
    labels <- sanitize(rownames(coef(summary(model))), type="latex")
    return(labels)
}

format_dependent_labels <- function(model){
    label <- sanitize(all.vars(formula(model))[1], type="latex")
    return(label)
}

models <- lapply({{ ensure_r_vector(depends_on) }}, load_model)

curry <- Curry(
    stargazer,
    title="Regression Results",
    align=TRUE,
    covariate.labels = sapply(models, format_covariate_labels),
    dep.var.labels = sapply(models, format_dependent_labels),
    out="{{ produces }}"
)

capture.output(do.call(curry, models))


# Do this for multiple folders.  So i am going to select.list ll the folders
#in my current directory that hass all my experiments listed.

#first select the folder that contains ALL experiments
main.dir<-"G:/"
setwd(main.dir)
exp.dir<-select.list(list.dirs(), multiple=T)

#name the experiments you will assess today.
rd.names<-c(
"RD.170112.30.m.p1",
"RD.170112.30.m.p2",
"RD.170112.30.m.p3",
"RD.170112.30.m.p4")

for(i in 1:length(rd.names)){
setwd(exp.dir[i])

# read in cell data.  This is a big data frame, but we only need a
# few collumns for now.
c.dat<-read.delim("celldatacells_filtered.txt", header=T, sep="\t")

#These are the collumns needed for analysis
green<-grep("CGRP", names(c.dat))
if(length(green)>1){
	c.dat.names<-c(
	"ObjectNumber",
	"AreaShape_Area",
	"AreaShape_Center_X",
	"AreaShape_Center_Y",
	"AreaShape_FormFactor",
	"AreaShape_Perimeter",
	"Intensity_MeanIntensity_CGRP",
	"Intensity_MeanIntensity_IB4_1",
	"Intensity_MeanIntensity_DNA_2",
	"Location_Center_X",
	"Location_Center_Y")

	c.dat.1<-c.dat[,c.dat.names]

	# i like to rename the collumns for my procpharm
names(c.dat.1)<-c(
	"id",
	"area",
	"center.x.simplified",
	"center.y.simplified",
	"circularity",
	"perimeter",
	"mean.gfp",
	"mean.tritc",
	"mean.dapi",
	"center.x",
	"center.y")
c.dat<-cbind(c.dat.1, c.dat)
}else{
c.dat.names<-c(
	"ObjectNumber",
	"AreaShape_Area",
	"AreaShape_Center_X",
	"AreaShape_Center_Y",
	"AreaShape_FormFactor",
	"AreaShape_Perimeter",
	"Intensity_MeanIntensity_IB4_1",
	"Intensity_MeanIntensity_DNA_2",
	"Location_Center_X",
	"Location_Center_Y")

c.dat.1<-c.dat[,c.dat.names]

	# i like to rename the collumns for my procpharm
	names(c.dat.1)<-c(
	"id",
	"area",
	"center.x.simplified",
	"center.y.simplified",
	"circularity",
	"perimeter",
	"mean.tritc",
	"mean.dapi",
	"center.y")
c.dat<-cbind(c.dat.1, c.dat)

}

# Now read in video Data
require(data.table)
f2.img<-fread("video_dataROI.txt")
#cell names

t.340<-xtabs(Intensity_MeanIntensity_f2_340~ImageNumber+ObjectNumber, f2.img)
t.380<-xtabs(Intensity_MeanIntensity_f2_380~ImageNumber+ObjectNumber, f2.img)
t.e.340<-xtabs(Intensity_MeanIntensityEdge_f2_340~ImageNumber+ObjectNumber, f2.img)
t.e.380<-xtabs(Intensity_MeanIntensityEdge_f2_380~ImageNumber+ObjectNumber, f2.img)
t.dat<-t.340/t.380
t.e.dat<-t.e.340/t.e.380

# add time info from file exported on nis veiwer
time.info<-read.delim("time.info.txt", sep="\t", fileEncoding="UCS-2LE")
if(length(which(is.na(time.info[3]), arr.ind=T)[,1])>=1){
	time.info<-time.info[-which(is.na(time.info[3]), arr.ind=T)[,1],]
}else{time.info<-time.info}#remove any nas
time.min<-round(time.info["Time..s."]/60, digits=3)

# Create row.names
cell.names<-paste("X.",c.dat$id,sep="")
c.dat[,"id"]<-cell.names
row.names(c.dat)<-cell.names

t.340<-cbind(time.min[,1], t.340)
t.340<- t.340[unique(row.names(t.340)),]#incase of duplicated rownames
colnames(t.340)<- c("Time",cell.names)
row.names(t.340)<-time.min[,1]
t.340<-as.data.frame(t.340)

t.e.340<-cbind(time.min[,1], t.e.340)
t.e.340<- t.e.340[unique(row.names(t.e.340)),]#incase of duplicated rownames
colnames(t.e.340)<- c("Time",cell.names)
row.names(t.e.340)<-time.min[,1]
t.e.340<-as.data.frame(t.e.340)

t.380<-cbind(time.min[,1], t.380)
t.380<- t.380[unique(row.names(t.380)),]#incase of duplicated rownames
colnames(t.380)<- c("Time",cell.names)
row.names(t.380)<-time.min[,1]
t.380<-as.data.frame(t.380)

t.e.380<-cbind(time.min[,1], t.e.380)
t.e.380<- t.e.380[unique(row.names(t.e.380)),]#incase of duplicated rownames
colnames(t.e.380)<- c("Time",cell.names)
row.names(t.e.380)<-time.min[,1]
t.e.380<-as.data.frame(t.e.380)

t.dat<-cbind(time.min[,1], t.dat)
t.dat<- t.dat[unique(row.names(t.dat)),]#incase of duplicated rownames
colnames(t.dat) <- c("Time",cell.names)
row.names(t.dat)<-time.min[,1]
t.dat<-as.data.frame(t.dat)

t.e.dat<-cbind(time.min[,1], t.e.dat)
t.e.dat<- t.e.dat[unique(row.names(t.e.dat)),]#incase of duplicated rownames
colnames(t.e.dat) <- c("Time",cell.names)
row.names(t.e.dat)<-time.min[,1]
t.e.dat<-as.data.frame(t.e.dat)

## Proof my dataframes are already sorting in the correct way.
#first create a dataframe from the video file x and y location data
#t.loc.x<-matrix(f2.img[,"Location_Center_X"],byrow=FALSE, nrow=max(cell.names))[,1]
#t.loc.y<-matrix(f2.img[,"Location_Center_Y"],byrow=FALSE, nrow=max(cell.names))[,1]
#t.loc<-cbind(t.loc.x, t.loc.y)
#t.loc<-round(t.loc, digits=3) #Then round dataframe to three digits

## Create datatrame from c.dat(c created above)
#c.xy<-c.dat[,c("center.x", "center.y")]
#c.xy<-round(c.xy, digits=3) # also round to three digits
#setdiff(t.loc[,2], c.xy[,2]) #There should be no difference between the two data frames

#setequal(t.loc[,1], c.xy[,1])#There should be no difference between the two data frame
#setequal(t.loc[,2], c.xy[,2])#There should be no difference between the two data frame

#example
#a<-seq(from=1,to=10,by=10)
#b<-seq(from=1,to=10,by=10)

############ wr1 import
wrdef<-"wr1.csv"
if(!is.null(wrdef))
	{
		wr <- ReadResponseWindowFile(wrdef)
		Wr<-length(wr[,1])#complete and revise this section
		if(length(colnames(wr))<2){w.dat<-WrMultiplex(t.dat,wr,n=Wr)}
		else{w.dat <- MakeWr(t.dat,wr)}
		}

# Initial and simple Data processing
tmp.rd <- list(t.dat=t.dat,w.dat=w.dat,c.dat=c.dat)
levs<-setdiff(unique(as.character(w.dat[,2])),"")
snr.lim=4;hab.lim=.05;sm=3;ws=30;blc="SNIP"
pcp <- ProcConstPharm(tmp.rd,sm,ws,blc)
scp <- ScoreConstPharm(tmp.rd,pcp$blc,pcp$snr,pcp$der,snr.lim,hab.lim,sm)
bin <- bScore(pcp$blc,pcp$snr,snr.lim,hab.lim,levs,tmp.rd$w.dat[,"wr1"])
bin <- bin[,levs]
bin["drop"] <- 0 #maybe try to generate some drop criteria from the scp file.
bin<-pf.function(bin,levs)

# Add images
require(png)
img1<-png::readPNG("bf.gfp.tritc.png")
#if(length(grep("gfp.png", list.files()))>=1){img.g<-png::readPNG("gfp.png")
#}else{img.g<-NULL}
img2<-png::readPNG("gfp.png")
img3<-png::readPNG("tritc.png")
img4<-png::readPNG("bf.lab.png")
img5<-png::readPNG("roi.img.png")
img6<-png::readPNG("fura2.png")
img7<-png::readPNG("gfp.tritc.dapi.png")
img8<-NULL

#img.t<-png::readPNG("tritc.png")
#img.b<-png::readPNG("bf.png")
#img.bl<-png::readPNG("bf.lab.png")
#img.f<-png::readPNG("fura2.png")

tmp.rd <- list(t.dat=t.dat,t.340=t.340,t.380=t.380,te.340=t.e.340,te.380=t.e.380, t.e.dat=t.e.dat,
w.dat=w.dat,c.dat=c.dat, bin=bin, scp=scp, snr=pcp$snr, blc=pcp$blc, der=pcp$der,
img1=img1,img2=img2,img3=img3,img4=img4,img5=img5,img6=img6,img7=img7)
#img.gtd=img.gtd, img.g=img.g, img.t=img.t, img.b=img.b,img.bl=img.bl, img.f=img.f)

## Check for duplicated rows
if(length(which(duplicated(row.names(t.dat))))>=1){
dup<-which(duplicated(row.names(t.dat)))
paste(dup)
t.dat<-t.dat[-dup,]
w.dat<-w.dat[-dup,]
}

##DESPIKE
wts <- tmp.rd$t.dat
for(j in 1:5) #run the despike 5 times.
{
	wt.mn3 <- Mean3(wts)
	wts <- SpikeTrim2(wts,1,-1)
	print(sum(is.na(wts))) #this prints out the number of points removed should be close to 0 after 5 loops.
	wts[is.na(wts)] <- wt.mn3[is.na(wts)]
}
tmp.rd$mp <- wts

rd.name<-rd.names[i]
f.name <- paste(rd.name,".Rdata",sep="")
assign(rd.name,tmp.rd)
save(list=rd.name,file=f.name)

rm(f2.img)
rm(rd.name)
rm(tmp.rd)
setwd(main.dir)
}


context("Pretty bytes")

test_that("pretty_bytes gives errors on invalid input", {

  expect_error(pretty_bytes(''), 'is.numeric.*is not TRUE')
  expect_error(pretty_bytes('1'), 'is.numeric.*is not TRUE')
  expect_error(pretty_bytes(TRUE), 'is.numeric.*is not TRUE')
  expect_error(pretty_bytes(list(1,2,3)), 'is.numeric.*is not TRUE')

})

test_that("pretty_bytes converts properly", {

  expect_equal(pretty_bytes(0), '0 B')
  expect_equal(pretty_bytes(10), '10 B')
  expect_equal(pretty_bytes(999), '999 B')
  expect_equal(pretty_bytes(1001), '1 kB')
  expect_equal(pretty_bytes(1e16), '10 PB')
  expect_equal(pretty_bytes(1e30), '1000000 YB')

})

test_that("pretty_bytes handles NA and NaN", {

  expect_equal(pretty_bytes(NA_real_), "NA B")
  expect_equal(pretty_bytes(NA_integer_), "NA B")
  expect_error(pretty_bytes(NA_character_), 'is.numeric.*is not TRUE')
  expect_error(pretty_bytes(NA), 'is.numeric.*is not TRUE')

  expect_equal(pretty_bytes(NaN), "NaN B")

})

test_that("pretty_bytes handles vectors", {

  expect_equal(pretty_bytes(1:10), paste(format(1:10), "B"))
  v <- c(NA, 1, 1e4, 1e6, NaN, 1e5)

  expect_equal(pretty_bytes(v),
    c(" NA B", "  1 B", " 10 kB", "  1 MB", "NaN B", "100 kB"))

  expect_equal(pretty_bytes(numeric()), character())
})

test_that("pretty_bytes handles negative values", {
  v <- c(NA, -1, 1e4, 1e6, NaN, -1e5)
  expect_equal(pretty_bytes(v),
    c("  NA B", "  -1 B", "  10 kB", "   1 MB", " NaN B", "-100 kB"))

})

test_that("always two fraction digits", {
  expect_equal(
    pretty_bytes(c(5.6, NA) * 1000 * 1000),
    c("5.60 MB", " NA B")
  )
})


#' barefootr: A package for holding useful functions for Eric
#'
#' I use this package to hold some functions that are useful to me.
#'
#' @section barefootr functions:
#'
#' The functions here make up a mix of tools to calculate and estimate modern suficial processes and back-calculate those processes in ancient rivers.
#'
#' \code{settle} calculates the settling velocity of particles following the formulation by Dietrich (1982).
#'
#' \code{lynds_one} estimates ancient river slope using the first method described by Lynds et al. (2014)
#'
#' \code{lynds_two} estimates ancient river slope using the second method described by Lynds et al. (2014)
#'
#' \code{lynds_three} estimates ancient river slope using the third method described by Lynds et al. (2014)
#'
#' \code{xset2H} estimates ancient river dune heights based on cross-set thicknesses. Methods from Leclair and Paola.
#'
#' \code{H2h} estimates ancient river depths based on dune heights. Methods from Bradley and Venditti.
#'
#' \code{xset2depthSimple} estimates ancient river depths directly from cross-set thicknesses using the simplest assumptions. Methods from Leclair, Paola, and Bradley and Venditti.
#'
#' \code{azStringConvert} Azimuth conversion for 'quadrant' based strike/trend measurements.
#'
#'
#'
#'
#'
#'
#'
#' @docType package
#' @name barefootr
NULL


#-------------------------------------------------------------------------------
# Script to run the assessment of Jack Mackerel and look at outputs
#
# By: Niels Hintzen
# Upate: 31 Aug 2011
#-------------------------------------------------------------------------------
rm(list=ls())
memory.size(4000)

# Set libraries & source code
library(lattice)
require(PBSadmb)
library(RColorBrewer)
library(doBy)

#-------------------------------------------------------------------------------
# Set paths
#-------------------------------------------------------------------------------
reposDir    <- "D:/Repository/JackMackerel/"
reposDir    <- "c:/users/jim/documents/_mymods/jjm/"
codePath    <- file.path(reposDir,"Code/R/")
inputPath   <- file.path(reposDir,"Code/admb/")
outputPath  <- file.path(reposDir,"Code/admb/arc/")
resultPath  <- file.path(reposDir,"Results/Assessment/")
setwd(codePath)

# Specify control file
controlFile <- "mod6a.ctrl"

# Run the assessment
source("diagnostics_v2.r")
source("ADMB2R_15102013.r")
system(paste('"jjm.exe"','-ind',paste(controlFile,".ctr",sep=""),'-nox'), wait = TRUE)

# Read in the output of the assessment
run_name="mod0.5"
dat_name="mod0.5.dat"

jjm.in  <- read.dat(iFilename = paste(dat_name,sep=""),iPath=inputPath)
jjm.out <- readList(file.path(inputPath,paste("arc/",run_name,"_r.rep",sep="")))
jjm.ypr <- readYPR(file.path(inputPath,paste( "arc/",run_name,".yld",  sep="")))

#-------------------------------------------------------------------------------
# Create diagnostics
#-------------------------------------------------------------------------------
pdf(paste(resultPath,"summary_",run_name,".pdf",sep=""),height=29.7/2.54,width=21/2.54,pointsize = 16, bg = "white")
diagnostics(jjm.out,jjm.in,jjm.ypr,what=c("input","fit","projections","ypr"))
dev.off()

#Write output to file
writeList(setOutputNames(jjm.out),fname=paste(controlFile,"_out.txt",sep=""),format="P")

#-------------------------------------------------------------------------------
# Visual compare runs
#-------------------------------------------------------------------------------
source("compareRuns.r")
getwd()
jjm0.0 <- readList(file.path(inputPath,paste("arc/Mod0.0_r.rep",sep="")))
jjm0.1 <- readList(file.path(inputPath,paste("arc/Mod0.1_r.rep",sep="")))
jjm0.2 <- readList(file.path(inputPath,paste("arc/Mod0.2_r.rep",sep="")))
jjm0.3 <- readList(file.path(inputPath,paste("arc/Mod0.3_r.rep",sep="")))
jjm0.4 <- readList(file.path(inputPath,paste("arc/Mod0.4_r.rep",sep="")))
jjm0.5 <- readList(file.path(inputPath,paste("arc/Mod0.5_r.rep",sep="")))
jjm0.6 <- readList(file.path(inputPath,paste("arc/Mod0.6_r.rep",sep="")))

lstOuts   <- list(
  Model_0.0= jjm0.0,
  Model_0.1= jjm0.1,
  Model_0.2= jjm0.2,
  Model_0.3= jjm0.3,
  Model_0.4= jjm0.4,
  Model_0.5= jjm0.5
                  )
lstOuts   <- list(
  Model_0.5= jjm0.5,
  Model_0.6= jjm0.6
)

pdf(paste(outputPath,"Compare_1_4.pdf",sep=""),height=29.7/2.54,width=21/2.54,pointsize = 24, bg = "white")

jjm.n2    <- readList(file.path(outputPath,"n3_r.rep"))
lstOuts   <- list(Model_N1=jjm.n1,Model_N2=jjm.n2)

jjm.s1    <- readList(file.path(outputPath,"s1_r.rep"))
jjm.s2    <- readList(file.path(outputPath,"s2_r.rep"))
lstOuts   <- list(Model_S1=jjm.s1,Model_S2=jjm.s2)

compareTime(lstOuts,"SSB",SD=T,Sum=NULL,legendPos="top")
compareTime(lstOuts,"SSB",SD=F,Sum=NULL,startYear=1953)
compareTime(lstOuts,"R",SD=T)
compareTime(lstOuts,"TotBiom",SD=T)

compareMatrix(lstOuts,"TotF",SD=F,Sum=NULL,YrInd=jjm.s2$Yr,Apply=mean)
compareMatrix(lstOuts,"N",   SD=F,         YrInd=jjm.s2$Yr,Apply=sum)
dev.off()

pdf(paste(resultPath,"Compare_0",".pdf",sep=""),height=29.7/2.54,width=21/2.54,pointsize = 16, bg = "white")
#-------------------------------------------------------------------------------
# Numerical compare runs
#-------------------------------------------------------------------------------

# Likelihood table
tab       <- cbind(lstOuts[[1]]$Like_Comp_names,do.call(cbind,lapply(lstOuts,function(x){round(x[["Like_Comp"]],2)})))
write.csv(tab,file=file.path(inputPath,"LikelihoodTable2013.csv"),row.names=F)
system("Likelihoodtable2013.csv")
tab
inputPath
# Risk tables
jjm.mod7  <- readList(file.path(inputPath,"mod7_r.rep"))
jjm.mod6  <- readList(file.path(inputPath,"mod6_r.rep"))
lstOuts   <- list(Model_6=jjm.mod6,Model_7=jjm.mod7)

# Get the future SSBs and SDs together in one file
fut       <- do.call(rbind,lapply(lstOuts,function(x){
                     do.call(rbind,lapply(x[grep("SSB_fut_",names(x))],
                                          function(y){return(y[,1:3])}))}))
fut       <- as.data.frame(fut,stringsAsFactors=F)
colnames(fut) <- c("year","SSB","SD")
fut$modelscenario <- paste(rep(names(lstOuts),each=nrow(lstOuts[[1]]$SSB_fut_1) *
                                                   length(grep("SSB_fut_",names(lstOuts[[1]])))),
                           paste("Scen",
                                 rep(1:length(grep("SSB_fut_",names(lstOuts[[1]]))),each=nrow(lstOuts[[1]]$SSB_fut_1)),
                                 sep="_"),
                           sep="_")
#Get the 2012 SSB and SDs together
fut
ass       <- do.call(rbind,lapply(lstOuts,function(x){
                                  x$SSB[which(x$SSB[,1] == (x$SSB_fut_1[1,1]-1)),1:3]}))
ass       <- as.data.frame(ass,stringsAsFactors=F)
colnames(ass) <- c("year","SSB","SD")
ass$modelscenario <- names(lstOuts)

#Do the risk calculation:
# Each final year, what is the risk of SSB(final year) < SSB(ass year)
rsktable    <- matrix(NA,nrow=length(lstOuts),ncol=length(grep("SSB_fut_",names(lstOuts[[1]]))),
                      dimnames=list(names(lstOuts),1:length(grep("SSB_fut_",names(lstOuts[[1]])))))
ratiotable  <- matrix(NA,nrow=length(lstOuts),ncol=length(grep("SSB_fut_",names(lstOuts[[1]]))),
                      dimnames=list(names(lstOuts),1:length(grep("SSB_fut_",names(lstOuts[[1]])))))

for(i in names(lstOuts)){
  futdat <-subset(fut,year==max(fut$year) &
                  paste("Model_",unlist(strsplit(fut$modelscenario,"_"))[seq(2,nrow(fut)*4,4)],sep="") == i)
  assdat <- subset(ass,modelscenario == i)
  rsktable[i,] <- dnorm(assdat$SSB,futdat$SSB,futdat$SD)
  ratiotable[i,] <- round((futdat$SSB / assdat$SSB),2 )# / futdat$SSB *100,1)
}
rsktable
ratiotable

#Average catch over entire timeseries
meancatch <- do.call(rbind,lapply(lstOuts,function(x){unlist(lapply(x[grep("Catch_fut_",names(x))],function(y){mean(y[,2])}))}))
meancatch


# chemotaxis
newtraj= traj[1]
burst(newtraj)=0

for (j in c(1: nrow(id_table))){
 Ttraj = traj[id(traj)==id_table$id[j]]
   alpha= env[[j]]$stripe_pos[[1]][1]
   for (i in c(1: length(Ttraj))){
    x=Ttraj[[i]]$x
    y=Ttraj[[i]]$y
    da=Ttraj[[i]]$date

    x2= x*sin(alpha)- y*cos(alpha)
    y2= y*sin(alpha)+ x*cos(alpha)
    z= data.frame(x2,y2)

    lt <- as.ltraj(z, da, id = attr(Ttraj[[i]], "id"), burst = attr(Ttraj[[i]],
                "burst"), typeII = attr(Ttraj[i], "typeII"))

    newtraj= c(newtraj,lt)
   }
  env[[j]]$stripe_pos[[1]][1] = pi/2
  env[[j]]$stripe_pos[[1]][2] = pi/2
 }

newtraj= newtraj[2:length(newtraj)]

##dist to odor
setwd(outputpath)
pdf("distance.pdf")
Distance = c()
for (j in c(1: nrow(id_table))){
 Ttraj = traj[id(traj)==id_table$id[j]]
   alpha= env[[j]]$stripe_pos[[1]][1]
   for (i in c(1: length(Ttraj))){
    x=Ttraj[[i]]$x
    y=Ttraj[[i]]$y

    Dy= env[[j]]$outer_r

    Dist = sqrt( (Dy+y)^2 + x^2)
    Distance= c(Distance,Dist)
    plot(Dist, ylim=c(0,140))
    abline(h=Dy)
    abline(h=Dy-env[[j]]$r, col=2)
    abline(h=Dy+env[[j]]$r, col=2)
   }
}
dev.off()

for (j in c(1:12)){
 Ttraj = traj[id(traj)==id_table$id[j]]
   alpha= env[[j]]$stripe_pos[[1]][1]
   for (i in c(1: length(Ttraj))){
    x=Ttraj[[i]]$x
    y=Ttraj[[i]]$y

    Dy= env[[j]]$outer_r

    Dist = sqrt( (Dy+y)^2 + x^2)
    Distance= c(Distance,Dist)
    plot(Dist, ylim=c(0,140))
    abline(h=Dy)
    abline(h=Dy-env[[j]]$r, col=2)
    abline(h=Dy+env[[j]]$r, col=2)
   }
}
plot(Distance, ylim=c(0,140))
    abline(h=Dy)
    abline(h=Dy-env[[j]]$r, col=2)
    abline(h=Dy+env[[j]]$r, col=2)
boxplot(Distance)
violinplot(Distance)


context("spacing")

test_that("start intervals are NA", {
  x <- tibble::tribble(
    ~ chrom, ~ start, ~ end,
    "chr1", 1, 100,
    "chr1", 150, 200,
    "chr2", 200, 300
  )

  res <- interval_spacing(x)

  first <- res %>%
    group_by(chrom) %>%
    slice(1) %>%
    select(chrom:end)

  nas <- filter(res, is.na(.spacing)) %>%
    select(chrom:end)

  expect_true(all(first == nas))
})

# from bedtools2
test_that("bt test succeeds", {
  x <- trbl_interval(
    ~ chrom, ~ start, ~ end,
    "chr1", 20, 30,
    "chr1", 25, 40,
    "chr1", 40, 50,
    "chr1", 60, 80,
    "chr1", 75, 100,
    "chr1", 105, 110,
    "chr2", 115, 130,
    "chr2", 120, 160,
    "chr2", 170, 180
  )

  res <- interval_spacing(x)

  exp <- c(NA, -5, 0, 10, -5, 5, NA, -10, 10)
  expect_equal(res$.spacing, exp)
})


args=commandArgs(T)
enhCutOff<-args[1]
intCutOff<-args[2]
setwd(paste0("/Volumes/LACIE_SHARE/project/2020-06-03-svmPipeline_corces2016_enh_int/output/enh",enhCutOff,"_int",intCutOff))

evaluate <- function(TrueLabelsPath, PredLabelsPath, Indices = NULL){
  "
  Script to evaluate the performance of the classifier.
  It returns multiple evaluation measures: the confusion matrix, median F1-score, F1-score for each class, accuracy, percentage of unlabeled, population size.

  The percentage of unlabeled cells is find by checking for cells that are labeled 'Unassigned', 'unassigned', 'Unknown', 'unknown', 'Nodexx', 'rand', or 'ambiguous'.

  Parameters
  ----------
  TrueLabelsPath: csv file with the true labels (format: one column, no index)
  PredLabelsPath: csv file with the predicted labels (format: one column, no index)
  Indices: which part of the csv file should be read (e.g. if more datasets are tested at the same time) (format: c(begin, end))

  Returns
  -------
  Conf: confusion matrix
  MedF1 : median F1-score
  F1 : F1-score per class
  Acc : accuracy
  PercUnl : percentage of unlabeled cells
  PopSize : number of cells per cell type
  "

  true_lab <- unlist(read.csv(TrueLabelsPath))
  pred_lab <- unlist(read.csv(PredLabelsPath))

  if (! is.null(Indices)){
    true_lab <- true_lab[Indices]
    pred_lab <- pred_lab[Indices]
  }

  unique_true <- unlist(unique(true_lab))
  unique_pred <- unlist(unique(pred_lab))

  unique_all <- unique(c(unique_true,unique_pred))
  conf <- table(true_lab,pred_lab)
  pop_size <- rowSums(conf)

  pred_lab = gsub('Node..','Node',pred_lab)

  conf_F1 <- table(true_lab,pred_lab,exclude = c('unassigned','Unassigned','Unknown','rand','Node','ambiguous','unknown'))

  F1 <- vector()
  sum_acc <- 0

  for (i in c(1:length(unique_true))){
    findLabel = colnames(conf_F1) == row.names(conf_F1)[i]
    if(sum(findLabel)){
      prec <- conf_F1[i,findLabel] / colSums(conf_F1)[findLabel]
      rec <- conf_F1[i,findLabel] / rowSums(conf_F1)[i]
      if (prec == 0 || rec == 0){
        F1[i] = 0
      } else{
        F1[i] <- (2*prec*rec) / (prec + rec)
      }
      sum_acc <- sum_acc + conf_F1[i,findLabel]
    } else {
      F1[i] = 0
    }
  }

  pop_size <- pop_size[pop_size > 0]

  names(F1) <- names(pop_size)

  med_F1 <- median(F1)

  total <- length(pred_lab)
  num_unlab <- sum(pred_lab == 'unassigned') + sum(pred_lab == 'Unassigned') + sum(pred_lab == 'rand') + sum(pred_lab == 'Unknown') + sum(pred_lab == 'unknown') + sum(pred_lab == 'Node') + sum(pred_lab == 'ambiguous')
  per_unlab <- num_unlab / total

  acc <- sum_acc/sum(conf_F1)

  result <- list(Conf = conf, MedF1 = med_F1, F1 = F1, Acc = acc, PercUnl = per_unlab, PopSize = pop_size)

  return(result)
}

TrueLabelsPath <- "./SVM_true.csv"
PredLabelsPath <- "./SVM_pred.csv"
OutputDir <- "./"
ToolName <- "SVM"

results <- evaluate(TrueLabelsPath, PredLabelsPath)
dir.create(file.path(OutputDir, "Confusion"))
dir.create(file.path(OutputDir, "F1"))
dir.create(file.path(OutputDir, "PopSize"))
dir.create(file.path(OutputDir, "Summary"))
write.csv(results$Conf, file.path(OutputDir, "Confusion", paste0(ToolName, ".csv")))
write.csv(results$F1, file.path(OutputDir, "F1", paste0(ToolName, ".csv")))
write.csv(results$PopSize, file.path(OutputDir, "PopSize", paste0(ToolName, ".csv")))
df <- data.frame(results[c("MedF1", "Acc", "PercUnl")])
write.csv(df, file.path(OutputDir, "Summary", paste0(ToolName, ".csv")))


# Graph of water use in the Lower Colorado River Basin
# Data from the US Bureau of Reclamation
# Compilation by John Fleck, University of New Mexico Water Resources Program
# fleckj@unm.edu
library(ggplot2)
library(tidyverse)
library(readr)
library(reshape2)

lb <- read_csv("./data/lower-basin-use.csv", col_names=TRUE)

newdata <- as_tibble(melt(lb, id.vars="Year",
                          variable.name="State",
                          value.name="Use"))

ggplot(newdata, aes(x=Year, y=Use/1000000, colour=State)) +
  theme_bw() +
  theme(plot.title = element_text(size = rel(2)),
        panel.background = element_rect(colour = NA),
        plot.background = element_rect(colour = NA),
        plot.subtitle = element_text(size = rel(1.5)),
        axis.title = element_text(face = "bold",size = rel(1))) +
  geom_line(size=1) +
  ylab("millions of acre feet") +
  xlab("Data: USBR\nGraph:John Fleck, University of New Mexico Water Resources Program\n
       Code and data: https://github.com/johnrfleck/colorado-river") +
  ggtitle("Colorado River Lower Basin Water Use")


# Load necessary packages
library(tidyverse)

# Load the data
responses <- read_csv('datasets/kagglesurvey.csv')

# Print the first 10 rows
head(responses, n = 10)

# Printing the first respondent's tools and languages
responses[1, 2]

# Add a new column, and unnest the new column
tools <- responses  %>%
    mutate(work_tools = str_split(WorkToolsSelect, ","))  %>%
    unnest(work_tools)

# View the first 6 rows of tools
head(tools)

# Group the data by work_tools, summarise the counts, and arrange in descending order
tool_count <- tools  %>%
    group_by(work_tools)  %>%
    summarise(count = n())  %>%
    arrange(desc(count))

# Print the first 6 results
head(tool_count)

# Create a bar chart of the work_tools column, most counts on the far right
ggplot(tool_count, aes(x = fct_reorder(work_tools, count), y = count)) +
    geom_bar(stat = "identity") +
    theme(axis.text.x  = element_text(angle=90, vjust=0.5, hjust= 1))

# Create a new column called language preference
debate_tools <- responses  %>%
    mutate(language_preference = case_when(
        str_detect(WorkToolsSelect, "R") & ! str_detect(WorkToolsSelect, "Python") ~ "R",
        str_detect(WorkToolsSelect, "Python") & ! str_detect(WorkToolsSelect, "R") ~ "Python",
        str_detect(WorkToolsSelect, "R") & str_detect(WorkToolsSelect, "Python")   ~ "both",
        TRUE ~ "neither"
    ))

# Print the first 6 rows
head(debate_tools)

# Group by language preference, calculate number of responses, and remove "neither"
debate_plot <- debate_tools %>%
    group_by(language_preference)  %>%
    summarise(count = n())  %>%
    filter(!language_preference == "neither")

# Creating a bar chart
ggplot(debate_plot, aes(x = language_preference, y = count)) +
  geom_bar(stat = "identity")

# Group by, summarise, arrange, mutate, and filter
recommendations <- debate_tools  %>%
    group_by(language_preference, LanguageRecommendationSelect)  %>%
    summarise(count = n())  %>%
    arrange(language_preference, desc(count))  %>%
    mutate(row = row_number()) %>%
    filter(row <= 4)

# Create a faceted bar plot
ggplot(recommendations, aes(x = LanguageRecommendationSelect, y = count)) +
    geom_bar(stat = "identity") +
    facet_wrap(~language_preference)

# Would R users find this statement TRUE or FALSE?
R_is_number_one = TRUE


if(!is.null(ag)) {
# Antigen -----------------------------------------------------------------

ag %>%
  select(Date, AGpos_minusPCRkonf, AGpos_PCRpos, AGpos_PCRneg) %>%
  pivot_longer(c(-Date)) %>%
  filter(Date > ymd("2021-01-31")) %>%
  ggplot() +
  geom_bar(stat = "identity", position = "stack", aes(Date, value, fill = name), width = 1) +
  scale_x_date(labels = my_date_labels, date_breaks = "1 month") +
  scale_y_continuous(limits = c(0, NA)) +
  scale_fill_manual(
    name = "Heraf:",
    labels = c("Ikke PCR testede", "PCR negative", "PCR positive"),
    values = c(alpha("gray80", 0.7), alpha("gray55", 0.7), alpha(pos_col, 0.9))
  ) +
  labs(
    y = "Antal positive",
    x = "Dato",
    title = "Dagligt antal positive SARS-CoV-2 antigentestede",
    caption = standard_caption
  ) +
  standard_theme

ggsave("../figures/ntl_ag_pos.png", width = 18, height = 10, units = "cm", dpi = 300)

ag %>%
  full_join(tests, by = "Date") %>%
  mutate(ag_testede = AG_testede - AGpos_PCRneg - AGpos_PCRpos - AGnegPCRneg - AGnegPCRpos) %>%
  select(Date, ag_testede, Tested) %>%
  pivot_longer(c(-Date)) %>%
  ggplot() +
  geom_bar(stat = "identity", position = "stack", aes(Date, value, fill = name), width = 1) +
  scale_x_date(labels = my_date_labels, date_breaks = "2 months") +
  scale_y_continuous(
    limits = c(0, NA),
    labels = scales::number
  ) +
  scale_fill_manual(
    name = "Heraf:",
    labels = c("Antigen", "PCR"),
    values = c(alpha(lighten(test_col, 0.6), 0.8), alpha(darken(test_col, 0), 0.9))
  ) +
  labs(
    y = "Antal",
    x = "Dato",
    title = "Dagligt antal SARS-CoV-2 testede",
    caption = standard_caption
  ) +
  standard_theme

ggsave("../figures/ntl_ag_test.png", width = 18, height = 10, units = "cm", dpi = 300)

ag_plot_data <-
  ag %>%
  full_join(tests, by = "Date") %>%
  filter(
    Date > ymd("2021-01-31"),
    Date < ymd(today) - 2) %>%
  mutate(
    total_testede = NotPrevPos + AG_testede - AGpos_PCRneg - AGpos_PCRpos - AGnegPCRneg - AGnegPCRpos,
    total_positive = NewPositive + AGpos_minusPCRkonf,
    PCRonly_testede = NotPrevPos - AGpos_PCRneg - AGpos_PCRpos - AGnegPCRpos - AGnegPCRneg,
    PCRonly_positive = NewPositive - AGnegPCRpos - AGpos_PCRpos,
    PCRAgneg_testede = NotPrevPos - AGpos_PCRneg - AGpos_PCRpos,
    PCRAgneg_positive = NewPositive - AGpos_PCRpos,
    daily_Antigen_pct = AG_pos / AG_testede * 100,
    daily_Antigen_zix = AG_pos / AG_testede ** 0.7,
    daily_PCRonly_pct = PCRonly_positive / PCRonly_testede * 100,
    daily_PCRonly_zix = PCRonly_positive / PCRonly_testede ** 0.7,
    daily_PCRAgneg_pct = PCRAgneg_positive / PCRAgneg_testede * 100,
    daily_PCRAgneg_zix = PCRAgneg_positive / PCRAgneg_testede ** 0.7,
    daily_PCRall_pct = NewPositive / NotPrevPos * 100,
    daily_PCRall_zix = NewPositive / NotPrevPos ** 0.7,
    daily_Total_pct = total_positive / total_testede * 100,
    daily_Total_zix = total_positive / total_testede ** 0.7) %>%
  mutate(
    ra_Antigen_pct = ra(daily_Antigen_pct),
    ra_Antigen_zix = ra(daily_Antigen_zix),
    ra_PCRonly_pct = ra(daily_PCRonly_pct),
    ra_PCRonly_zix = ra(daily_PCRonly_zix),
    ra_PCRAgneg_pct = ra(daily_PCRAgneg_pct),
    ra_PCRAgneg_zix = ra(daily_PCRAgneg_zix),
    ra_PCRall_pct = ra(daily_PCRall_pct),
    ra_PCRall_zix = ra(daily_PCRall_zix),
    ra_Total_pct = ra(daily_Total_pct),
    ra_Total_zix = ra(daily_Total_zix))

ag_plot_data %>%
select(Date, daily_Antigen_pct:ra_Total_zix) %>%
  pivot_longer(-Date, names_to = c("type", "method", "variable"), values_to = "value", names_sep = "_") %>%
  mutate(
    method = case_when(
      method == "PCRonly" ~ "PCR uden Ag-spor",
      method == "Antigen" ~ "Ag-spor",
      method == "PCRAgneg" ~ "PCR med pos fra Ag-spor",
      method == "PCRall" ~ "PCR med Ag-spor",
      TRUE ~ method
    )
  ) %>%
  ggplot() +
  geom_line(aes(Date, value, color = variable, size = type, alpha = type)) +
  facet_grid(~ method) +
  scale_x_date(labels = my_date_labels, date_breaks = "2 month", minor_breaks = "1 month") +
  scale_y_continuous(limits = c(0, NA)) +
  scale_color_manual(
    name = "",
    labels = c("Positivprocent", "Smitteindeks"),
    values = c(lighten(pct_col, 0.3), darken(pct_col, 0.3))
  ) +
  scale_size_manual(
    name = "",
    labels = c("Dagligt", "7-dages gennemsnit"),
    values = c(0.3, 1)
  ) +
  scale_alpha_manual(
    name = "",
    labels = c("Dagligt", "7-dages gennemsnit"),
    values = c(0.6, 1)
  ) +
  labs(
    y = "Procent / Indeks",
    x = "Dato",
    title = "Antal SARS-CoV-2 positive justeret for antal testede",
    caption = standard_caption,
    subtitle = 'Positivprocent = positive / testede \u00D7 100. Smitteindeks = positive / testede0.7'
  ) +
  facet_theme +
  theme(
    plot.subtitle = ggtext::element_markdown(),
    plot.margin = margin(.6, .6, 0.3, .6, "cm"),
    plot.title = element_text(),
    legend.position = "none"
  )

ggsave("../figures/ntl_ag_pct.png", width = 18, height = 10, units = "cm", dpi = 300)

ag_plot_data %>%
  select(Date, daily_Antigen_pct:ra_Total_zix) %>%
  pivot_longer(-Date, names_to = c("type", "method", "variable"), values_to = "value", names_sep = "_") %>%
  filter(method %in% c("PCRonly", "PCRall", "Total")) %>%
  mutate(
    method = case_when(
      method == "PCRonly" ~ "PCR uden Ag-spor",
      method == "Antigen" ~ "Ag-spor",
      method == "PCRAgneg" ~ "PCR med pos fra Ag-spor",
      method == "PCRall" ~ "PCR med Ag-spor",
      TRUE ~ method
    )
  ) %>%
  ggplot() +
  geom_line(aes(Date, value, color = variable, size = type, alpha = type)) +
  facet_grid(~ method) +
  scale_x_date(labels = my_date_labels, date_breaks = "2 month", minor_breaks = "1 month") +
  scale_y_continuous(limits = c(0, NA)) +
  scale_color_manual(
    name = "",
    labels = c("Positivprocent", "Smitteindeks"),
    values = c(lighten(pct_col, 0.3), darken(pct_col, 0.3))
  ) +
  scale_size_manual(
    name = "",
    labels = c("Dagligt", "7-dages gennemsnit"),
    values = c(0.3, 1)
  ) +
  scale_alpha_manual(
    name = "",
    labels = c("Dagligt", "7-dages gennemsnit"),
    values = c(0.6, 1)
  ) +
  labs(
    y = "Procent / Indeks",
    x = "Dato",
    title = "Antal SARS-CoV-2 positive justeret for antal testede",
    caption = standard_caption,
    subtitle = 'Positivprocent = positive / testede \u00D7 100. Smitteindeks = positive / testede0.7'
  ) +
  facet_theme +
  theme(
    plot.subtitle = ggtext::element_markdown(),
    plot.margin = margin(.6, .6, 0.3, .6, "cm"),
    plot.title = element_text(),
    legend.position = "none"
  )

ggsave("../figures/ntl_ag_pct2.png", width = 18, height = 10, units = "cm", dpi = 300)

rsq <- function(x, y) summary(lm(y~x))$r.squared

ag %>%
  select(Date, AGnegPCRpos, AGnegPCRneg, AG_testede, AG_pos) %>%
  mutate(share_PCR_pos = 100 * AGnegPCRpos / (AGnegPCRneg + AGnegPCRpos),
         share_PCR_test = 100 * (AGnegPCRneg + AGnegPCRpos) / (AG_testede - AG_pos)) %>%
 # pivot_longer(c(-Date)) %>%
  filter(Date > ymd("2021-01-31")) %>%
  ggplot() +
  geom_line(aes(Date, share_PCR_test), size = 1) +
  scale_x_date(labels = my_date_labels, date_breaks = "1 month") +
  scale_y_continuous(limits = c(0, NA)) +
  labs(
    y = "Procent",
    x = "Dato",
    title = "Andel Ag-negative der dobbelttestes med PCR",
    caption = standard_caption
  ) +
  standard_theme

ag_plot_data %>%
  mutate(
    ra_AG_testede = AG_testede,
    ra_PCR_testede = ra(PCRonly_testede)
    ) %>%
  select(ra_AG_testede, NewPositive, PCRonly_positive)  %>%
  rename(
    "PCR smittetal" = NewPositive,
    "PCR smittetal (uden personer fra Ag-spor)" = PCRonly_positive
  ) %>%
  #select(ra_AG_testede, ra_PCRall_zix, ra_PCRonly_zix)  %>%
  #pivot_longer(c(-ra_AG_testede, -ra_PCR_testede))  %>%
  pivot_longer(-ra_AG_testede)  %>%
  #pivot_longer(c(-name, -value), names_to = "test", values_to = "test_value")  %>%
  group_by(name) %>%
  mutate(r2 = rsq(ra_AG_testede, value)) %>%
  ggplot() +
  geom_point(aes(ra_AG_testede, value), alpha = 0.6) +
  geom_smooth(aes(ra_AG_testede, value), color = "orange", size = 0.5, method = "lm", se = FALSE) +
  geom_text(aes(x = 140000, y = 100, label = paste0("R2 = ", round(r2, 2))), check_overlap = TRUE) +
  facet_wrap(~name, scales = "free_x") +
  scale_x_continuous(labels = scales::number, breaks = c(0, 200000, 400000, 600000)) +
  scale_y_continuous(limits = c(0,NA), labels = scales::number) +
  labs(
    y = "Positive",
    x = "Antal testede i Ag-spor",
    title = "Smittetal vs antal Ag-testede",
    caption = standard_caption
  ) +
  standard_theme +
  theme(
    axis.title.x = element_text(face = "bold", margin = margin(t = 8, r = 0, b = 0, l = 0)),
  )
ggsave("../figures/ntl_ag_regression.png", width = 18, height = 10, units = "cm", dpi = 300)

}


source("simulation.R")
RNGkind("L'Ecuyer-CMRG")

seed <- 999983
s_k <- 5000
s_n <- 500
s_m <- 6

stephanie_5006 <- stephanie_type1(seed, s_k, s_n, s_m, L = 1000)
save(stephanie_5006, file = "stephanie_5006.RData")