setwd("C:\\Users\\Ashish Arora\\Desktop\\logistic reg case study")

mydata<-read.csv("Proactive Attrition Management-Logistic Regression Case Study.csv",header=T)

#View(mydata)
#str(mydata)

mydata$CHURN<- factor(mydata$CHURN)
mydata$CSA<- factor(mydata$CSA)
mydata$CHILDREN<- factor(mydata$CHILDREN)
mydata$CREDITA<- factor(mydata$CREDITA)
mydata$CREDITAA<- factor(mydata$CREDITAA)
mydata$CREDITB<- factor(mydata$CREDITB)
mydata$CREDITC<- factor(mydata$CREDITC)
mydata$CREDITDE<- factor(mydata$CREDITDE)
mydata$CREDITGY<- factor(mydata$CREDITGY)
mydata$CREDITZ<- factor(mydata$CREDITZ)
mydata$PRIZMRUR<- factor(mydata$PRIZMRUR)
mydata$PRIZMUB<- factor(mydata$PRIZMUB)
mydata$PRIZMTWN<- factor(mydata$PRIZMTWN)
mydata$REFURB<- factor(mydata$REFURB)
mydata$WEBCAP<- factor(mydata$WEBCAP)
mydata$TRUCK<- factor(mydata$TRUCK)
mydata$RV<- factor(mydata$RV)
mydata$OCCPROF<- factor(mydata$OCCPROF)
mydata$OCCCLER<- factor(mydata$OCCCLER)
mydata$OCCCRFT<- factor(mydata$OCCCRFT)
mydata$OCCSTUD<- factor(mydata$OCCSTUD)
mydata$OCCHMKR<- factor(mydata$OCCHMKR)
mydata$OCCRET<- factor(mydata$OCCRET)
mydata$OCCSELF<- factor(mydata$OCCSELF)
mydata$OWNRENT<- factor(mydata$OWNRENT)
mydata$MARRYUN<- factor(mydata$MARRYUN)
mydata$MARRYYES<- factor(mydata$MARRYYES)
mydata$MARRYNO<- factor(mydata$MARRYNO)
mydata$MAILORD<- factor(mydata$MAILORD)
mydata$MAILRES<- factor(mydata$MAILRES)
mydata$MAILFLAG<- factor(mydata$MAILFLAG)
mydata$TRAVEL<- factor(mydata$TRAVEL)
mydata$PCOWN<- factor(mydata$PCOWN)
mydata$CREDITCD<- factor(mydata$CREDITCD)
mydata$NEWCELLY<- factor(mydata$NEWCELLY)
mydata$NEWCELLN<- factor(mydata$NEWCELLN)
mydata$INCMISS<- factor(mydata$INCMISS)
mydata$MCYCLE<- factor(mydata$MCYCLE)
mydata$SETPRCM<- factor(mydata$SETPRCM)
mydata$RETCALL<- factor(mydata$RETCALL)
mydata$CALIBRAT<- factor(mydata$CALIBRAT)
mydata$CHURNDEP<- factor(mydata$CHURNDEP)

var_Summ=function(x){
  if(class(x)=="numeric"){
    Var_Type=class(x)
    n<-length(x)
    nmiss<-sum(is.na(x))
    mean<-mean(x,na.rm=T)
    std<-sd(x,na.rm=T)
    var<-var(x,na.rm=T)
    min<-min(x,na.rm=T)
    p1<-quantile(x,0.01,na.rm=T)
    p5<-quantile(x,0.05,na.rm=T)
    p10<-quantile(x,0.1,na.rm=T)
    q1<-quantile(x,0.25,na.rm=T)
    q2<-quantile(x,0.5,na.rm=T)
    q3<-quantile(x,0.75,na.rm=T)
    p90<-quantile(x,0.9,na.rm=T)
    p95<-quantile(x,0.95,na.rm=T)
    p99<-quantile(x,0.99,na.rm=T)
    max<-max(x,na.rm=T)
    UC1=mean(x,na.rm=T)+3*sd(x,na.rm=T)
    LC1=mean(x,na.rm=T)-3*sd(x,na.rm=T)
    UC2=quantile(x,0.99,na.rm=T)
    LC2=quantile(x,0.01,na.rm=T)
    iqr=IQR(x,na.rm=T)
    UC3=q3+1.5*iqr
    LC3=q1-1.5*iqr
    ot1<-max>UC1 | min<LC1
    ot2<-max>UC2 | min<LC2
    ot3<-max>UC3 | min<LC3
    return(c(Var_Type=Var_Type, n=n,nmiss=nmiss,mean=mean,std=std,var=var,min=min,p1=p1,p5=p5,p10=p10,q1=q1,q2=q2,q3=q3,p90=p90,p95=p95,p99=p99,max=max,ot_m1=ot1,ot_m2=ot2,ot_m2=ot3))
  }
  else{
    Var_Type=class(x)
    n<-length(x)
    nmiss<-sum(is.na(x))
    fre<-table(x)
    prop<-prop.table(table(x))
    #x[is.na(x)]<-x[which.max(prop.table(table(x)))]

    return(c(Var_Type=Var_Type, n=n,nmiss=nmiss,freq=fre,proportion=prop))
  }
}

#Vector of numaerical variables
num_var= sapply(mydata,is.numeric)
Other_var= !sapply(mydata,is.numeric)

#Applying above defined function on numerical variables
my_num_data<-t(data.frame(apply(mydata[num_var], 2, var_Summ)))
my_cat_data<-data.frame(t(apply(mydata[Other_var], 2, var_Summ)))

# Number of missing values
apply(is.na(mydata[,]),2,sum)

#Missing Value Treatment
mydata$REVENUE[is.na(mydata$REVENUE)]<-0
mydata$MOU[is.na(mydata$MOU)]<-0
mydata$RECCHRGE[is.na(mydata$RECCHRGE)]<-0
mydata$DIRECTAS[is.na(mydata$DIRECTAS)]<-0
mydata$OVERAGE[is.na(mydata$OVERAGE)]<-0
mydata$ROAM[is.na(mydata$ROAM)]<-0
mydata$CHANGEM[is.na(mydata$CHANGEM)]<-0
mydata$CHANGER[is.na(mydata$CHANGER)]<-0
mydata$AGE1[is.na(mydata$AGE1)]<-0
mydata$AGE2[is.na(mydata$AGE2)]<-0
mydata$PHONES[is.na(mydata$PHONES)]<-0
mydata$MODELS[is.na(mydata$MODELS)]<-0
mydata$EQPDAYS[is.na(mydata$EQPDAYS)]<-0

mydata$REVENUE[is.na(mydata$REVENUE)]<-mean(mydata$REVENUE)
mydata$MOU[is.na(mydata$MOU)]<-mean(mydata$MOU)
mydata$RECCHRGE[is.na(mydata$RECCHRGE)]<-mean(mydata$RECCHRGE)
mydata$DIRECTAS[is.na(mydata$DIRECTAS)]<-mean(mydata$DIRECTAS)
mydata$OVERAGE[is.na(mydata$OVERAGE)]<-mean(mydata$OVERAGE)
mydata$ROAM[is.na(mydata$ROAM)]<-mean(mydata$ROAM)
mydata$CHANGEM[is.na(mydata$CHANGEM)]<-mean(mydata$CHANGEM)
mydata$CHANGER[is.na(mydata$CHANGER)]<-mean(mydata$CHANGER)
mydata$AGE1[is.na(mydata$AGE1)]<-mean(mydata$AGE1)
mydata$AGE2[is.na(mydata$AGE2)]<-mean(mydata$AGE2)
mydata$PHONES[is.na(mydata$PHONES)]<-mean(mydata$PHONES)
mydata$MODELS[is.na(mydata$MODELS)]<-mean(mydata$MODELS)
mydata$EQPDAYS[is.na(mydata$EQPDAYS)]<-mean(mydata$EQPDAYS)

M1_fun <- function(x){
  quantiles <- quantile( x, c(.01, .99 ),na.rm=TRUE )
  x[ x < quantiles[1] ] <- quantiles[1]
  x[ x > quantiles[2] ] <- quantiles[2]
  x
}
mydata[,"OPEAKVCE"] <- M1_fun( mydata[,"OPEAKVCE"] )
mydata[,"MOUREC"] <- M1_fun( mydata[,"MOUREC"] )
mydata[,"OUTCALLS"] <- M1_fun( mydata[,"OUTCALLS"] )
mydata[,"MOU"] <- M1_fun( mydata[,"MOU"] )
mydata[,"PEAKVCE"] <- M1_fun( mydata[,"PEAKVCE"] )
mydata[,"INCALLS"] <- M1_fun( mydata[,"INCALLS"] )
mydata[,"CALLWAIT"] <- M1_fun( mydata[,"CALLWAIT"] )
mydata[,"UNANSVCE"] <- M1_fun( mydata[,"UNANSVCE"] )
mydata[,"DROPVCE"] <- M1_fun( mydata[,"DROPVCE"] )
mydata[,"OVERAGE"] <- M1_fun( mydata[,"OVERAGE"] )
mydata[,"CUSTCARE"] <- M1_fun( mydata[,"CUSTCARE"] )
mydata[,"PHONES"] <- M1_fun( mydata[,"PHONES"] )
mydata[,"MODELS"] <- M1_fun( mydata[,"MODELS"] )
mydata[,"SETPRC"] <- M1_fun( mydata[,"SETPRC"] )
mydata[,"EQPDAYS"] <- M1_fun( mydata[,"EQPDAYS"] )
mydata[,"AGE1"] <- M1_fun( mydata[,"AGE1"] )
mydata[,"AGE2"] <- M1_fun( mydata[,"AGE2"] )
mydata[,"INCOME"] <- M1_fun( mydata[,"INCOME"] )
mydata[,"REVENUE"] <- M1_fun( mydata[,"REVENUE"] )
mydata[,"ROAM"] <- M1_fun( mydata[,"ROAM"] )
mydata[,"DIRECTAS"] <- M1_fun( mydata[,"DIRECTAS"] )
mydata[,"RECCHRGE"] <- M1_fun( mydata[,"RECCHRGE"] )
mydata[,"BLCKVCE"] <- M1_fun( mydata[,"BLCKVCE"] )
mydata[,"DROPBLK"] <- M1_fun( mydata[,"DROPBLK"] )
mydata[,"THREEWAY"] <- M1_fun( mydata[,"THREEWAY"] )
mydata[,"UNIQSUBS"] <- M1_fun( mydata[,"UNIQSUBS"] )
mydata[,"ACTVSUBS"] <- M1_fun( mydata[,"ACTVSUBS"] )
mydata[,"RETACCPT"] <- M1_fun( mydata[,"RETACCPT"] )
mydata[,"RETCALLS"] <- M1_fun( mydata[,"RETCALLS"] )
mydata[,"MONTHS"] <- M1_fun( mydata[,"MONTHS"] )
mydata[,"CREDITAD"] <- M1_fun( mydata[,"CREDITAD"] )
mydata[,"CHANGEM"] <- M1_fun( mydata[,"CHANGEM"] )
mydata[,"CHANGER"] <- M1_fun( mydata[,"CHANGER"] )
mydata[,"REFER"] <- M1_fun( mydata[,"REFER"] )
mydata[,"CALLFWDV"] <- M1_fun( mydata[,"CALLFWDV"] )

#vars<- c("OPEAKVCE","MOUREC","OUTCALLS","MOU","PEAKVCE","INCALLS","CALLWAIT","UNANSVCE",
#         "DROPVCE","OVERAGE","CUSTCARE","PHONES", "MODELS","SETPRC","EQPDAYS","AGE1",
#         "AGE2","INCOME","REVENUE","ROAM","DIRECTAS","RECCHRGE","BLCKVCE","DROPBLK",
#        "THREEWAY","UNIQSUBS","ACTVSUBS","RETACCPT","RETCALLS","MONTHS","CREDITAD","CHANGEM",
#       "CHANGER","REFER","CALLFWDV")

#Splitting data into development and Validaton Dataset
dev <- subset(mydata, CALIBRAT == 1)

val <- subset(mydata, CALIBRAT == 0)

#Building Models for dev dataset
#Building First model with all variables or we can go for factor analysis first and remove some collinearity

fit<-glm(CHURN~CALLFWDV+  REVENUE+  MOU+  RECCHRGE+  DIRECTAS+  OVERAGE+  ROAM+  CHANGEM+
           CHANGER+  DROPVCE+  BLCKVCE+  UNANSVCE+  CUSTCARE+  THREEWAY+  MOUREC+  OUTCALLS+
           INCALLS+  PEAKVCE+  OPEAKVCE+  DROPBLK+  CALLWAIT+ MONTHS+  UNIQSUBS+  ACTVSUBS+
           PHONES+  MODELS+  EQPDAYS +  AGE1+  AGE2+  INCOME+  SETPRC+  REFER+  CREDITAD+  CHILDREN+
           CREDITA+  CREDITAA+  CREDITB+  CREDITC+  CREDITDE+  CREDITGY+  CREDITZ+  PRIZMRUR+  PRIZMUB+
           PRIZMTWN+  REFURB+  WEBCAP+  TRUCK+  RV+  OCCPROF+  OCCCLER+  OCCCRFT+  OCCSTUD+  OCCHMKR+
           OCCRET+  OCCSELF+  OWNRENT+  MARRYUN+  MARRYYES+  MARRYNO+  MAILORD+  MAILRES+  MAILFLAG+  TRAVEL+
           PCOWN+  CREDITCD+  NEWCELLY+  NEWCELLN+  INCMISS+  MCYCLE+  SETPRCM,data = dev,
         family = binomial(logit))

#Output of Logistic Regression
summary(fit)
ls(fit)
fit$model

coeff<-fit$coef #Coefficients of model

#Checking for concordance
source("Concordance.R")
Concordance(fit)

#Stepwise regression
step1=step(fit,direction="both")

#Final Model
final_fit<-glm(CHURN ~ REVENUE + MOU + RECCHRGE + OVERAGE + ROAM + CHANGEM +
                 CHANGER + BLCKVCE  + THREEWAY + INCALLS +
                 PEAKVCE + DROPBLK + MONTHS + UNIQSUBS + ACTVSUBS + PHONES +
                 EQPDAYS + AGE1 + INCOME + SETPRC + CREDITAD + CHILDREN +
                 CREDITAA + CREDITB + CREDITC + CREDITDE + PRIZMUB + REFURB +
                 WEBCAP +  MARRYUN + MAILRES + NEWCELLY + INCMISS +
                   SETPRCM,data = dev,
               family = binomial(logit))

#Output of Logistic Regression
summary(final_fit)
ls(final_fit)

coeff<-final_fit$coef #Coefficients of model
write.csv(coeff, "coeff.csv")

#Checking for concordance
source("Concordance.R")
Concordance(final_fit)

#Concordance acheived with this model is  0.62125 and all the variables are significant to atleast 90% confidence level.
#Though a model with 85% confidence level will yield a better concordance. But to make the variables significant we consider 90% level.

################################VALIDATION ##############################
#Decile Scoring for Development dataset
dev1<- cbind(dev, Prob=predict(final_fit, type="response")) #response calculates the probability value.
#View(dev1)

decLocations <- quantile(dev1$Prob, probs = seq(0.1,0.9,by=0.1))
dev1$decile <- findInterval(dev1$Prob,c(-Inf,decLocations, Inf))
#View(dev1)

#Decile Analysis Reports
require(sqldf)
devdata_deciles <- sqldf("select decile, min(Prob) as Min_prob
                         , max(Prob) as max_prob
                         , sum(CHURN) as churn_Count
                         , (count(decile)-sum(CHURN)) as Non_churn_Count
                         from dev1
                         group by decile
                         order by decile desc")

write.csv(devdata_deciles,"devdata_deciles.csv",row.names = F)

##Validation dataset
val1<- cbind(val, Prob=predict(final_fit,val, type="response"))
#View(val1)

decLocations <- quantile(val1$Prob, probs = seq(0.1,0.9,by=0.1))
val1$decile <- findInterval(val1$Prob,c(-Inf,decLocations, Inf))

#Decile Analysis Reports
require(sqldf)

val_deciles <- sqldf("select decile, min(Prob) as Min_prob
                     , max(Prob) as max_prob
                     , sum(CHURN) as churn_Count
                     , (count(decile)-sum(CHURN)) as Non_churn_Count
                     from val1
                     group by decile
                     order by decile desc")

write.csv(val_deciles,"val_deciles.csv",row.names = F)

#val1<-cbind(val, Prob=predict(final_fit, val, type="response"))
#val1$CHURNDEP <- ifelse(val1$Prob>0.501, 1,0)
#sum(val1$CHURNDEP)


'
The file "esimate_returns.r" estimates returns to tenure by age and
education from CPS data.
'

# read in arguments (1: path input file, 2: path output file)
args <- commandArgs(trailingOnly=TRUE)
# args <- c(
#   "C:\\Users\\user\\projects\\data_analysis_cps\\bld\\out\\data\\cps_supplement_tenure_extract.csv",
#   "C:\\Users\\user\\projects\\data_analysis_cps\\bld\\out\\results\\cps_returns_to_tenure.csv"
# )

# load required packages
library(foreign)
library(plyr)
library(dplyr)
library(spatstat)
library(tidyr)
library(ggeffects)

#####################################################
# SCRIPT
#####################################################

## DATA PREPARATION
# load data
df <- read.csv(file = args[1])

# drop observations out of scope and with missing values
df <- drop_na(df, c(
  "earnings_weekly_deflated",
  "tenure",
  "education",
  "age_group",
  "marital_status",
  "race",
  "weight"
))
df <- df[df$earnings_weekly_deflated!=0,]
df <- subset(df, "sex"="MALE")

# data cleaning and processing
# truncate tenure at 45 years
df[df$tenure>45,"tenure"] <- 45

# add reduced education category
df$education_reduced <- revalue(df$education, c(
  "Less than 5th Grade"="low",
  "5th Grade to 12th Grade without Diploma"="low",
  "High School Graduates, No College"="medium",
  "Some College or Associate Degree"="medium",
  "Bachelor's degree and higher"="high"
))

# transform categorical variables to factors
df$year <- factor(df$year)
df$marital_status <- factor(df$marital_status)
df$race <- factor(df$race)
df$citizenship_status <- factor(df$citizenship_status)

# compute log earnigns
df$log_earnings <- log(df$earnings_weekly_deflated)

## ESTIMATION AND PREDICTION
# estimate linear model of returns to tenure
model_tenure <- lm(log_earnings ~ education_reduced * tenure
  + education_reduced * I(tenure^2)
  + age + I(age^2) + year + state + marital_status + race,
                     weights = weight,
                     data=df
)

# predict log earnings by tenure and education
returns_predicted <- ggeffect(model_tenure, terms=c("tenure [0:40 by=5]", "education_reduced"))

# transform log earnings to earnings
returns_predicted$predicted <- exp(returns_predicted$predicted)
returns_predicted$conf.high <- exp(returns_predicted$conf.high)
returns_predicted$conf.low <- exp(returns_predicted$conf.low)

## OUTPUT
# store results
write.csv(returns_predicted, file = args[2], row.names = FALSE)


# 3. faza: Izdelava zemljevida

# Uvozimo funkcijo za pobiranje in uvoz zemljevida.
source("lib/uvozi.zemljevid.r")

# Uvozimo zemljevid.
cat("Uvažam zemljevid...\n")
svet <- uvozi.zemljevid("http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/cultural/ne_110m_admin_0_countries.zip",
                          "europa", "ne_110m_admin_0_countries.shp", mapa = "zemljevid",
                          encoding = "Windows-1250")

# Funkcija, ki podatke preuredi glede na vrstni red v zemljevidu
preuredi <- function(podatki, zemljevid) {
  nove.svet <- c()
  manjkajo <- ! nove.svet %in% rownames(podatki)
  M <- as.data.frame(matrix(nrow=sum(manjkajo), ncol=length(podatki)))
  names(M) <- names(podatki)
  row.names(M) <- nove.svet[manjkajo]
  podatki <- rbind(podatki, M)

  out <- data.frame(podatki[order(rownames(podatki)), ])[rank(levels(zemljevid$NAME_1)[rank(zemljevid$NAME_1)]), ]
  if (ncol(podatki) == 1) {
    out <- data.frame(out)
    names(out) <- names(podatki)
    rownames(out) <- rownames(podatki)
  }
  return(out)
}

# Preuredimo podatke, da jih bomo lahko izrisali na zemljevid.
drzave <- levels(t4[,2])

#Vektor, ki pove v koliko različnih mestah ima dano državo razvite sisteme.
aa <- table(t4[,2])
#naredimo urejenostno spremenljivko

v<-rep(2,length(drzave))
v[aa<4]<-1
v[aa>30]<-3
names(v)<-drzave
#1 - low; 2 - medium; 3 - high

e1<-sapply(drzave, function(x) sum(t4[t4[,2]==x,9], na.rm=TRUE)) #število razpoložvljivih koles v vsaki državi
names(e1)<-drzave
m <- match(svet$name_long, drzave)
svet$urejenost <- v[m]
svet$stevilo.koles <- e1[m]

svet[31,65]<-0 # Kitajska damo stran, ker ima 100 krat več koles. Brez njo dobimo boljši zemljevid.

#Statistični podatki za 1. zemljevid
med1<-median(svet$stevilo.koles[!is.na(svet$stevilo.koles)]) #790
mean1<-mean(svet$stevilo.koles,na.rm=TRUE) #3593.204
sd1<-sd(svet$stevilo.koles,na.rm=TRUE) #7690.308

#Narišimo zemljevide

cat("Rišem zemljevid...\n")
pdf("slike/zemljevid1.pdf")

print(spplot(svet, "stevilo.koles", col.regions = c("white",  rainbow(15,
                    start=0, end = 10/12)), main="Število razpoložljivih koles v vsaki državi"))

dev.off()

colo<-c()
colo["1"]<-"red"
colo["2"]<-"blue"
colo["3"]<-"green"
cat("Rišem zemljevid...\n")
pdf("slike/zemljevid2.pdf")
#Razporedimo države po tem koliko postajališč imajo
plot(svet, col=ifelse(svet$urejenost=="1",colo[1],
                      ifelse(svet$urejenost=="2",colo[2],ifelse(svet$urejenost=="3",colo[3],"white"))),
      main="Porazdelitev držav v treh skupinah")
legend("bottom", legend = c("1. cona - države, ki imajo razvite sisteme v manj kot 4 mesta"
                                ,"2. cona - države, ki imajo razvite sisteme v 4-30 mest",
                                "3. cona - države, ki imajo razvite sisteme v več kot 30 mest"),
       fill = c("red","blue","green"), bg = "white")

dev.off()

svet$st.koles.prebivalstvo<-sapply(1:177,
                                   function(x) svet$stevilo.koles[x]/svet$pop_est[x])

cat("Rišem zemljevid...\n")
pdf("slike/zemljevid3.pdf")

print(spplot(svet, "st.koles.prebivalstvo",
             col.regions = c("white",rainbow(15, start=0, end = 10/12)),
             main="Razmerje med število razpoložljivih koles in število prebivalcev"))

dev.off()


#' Extract the information from the simulation data frame to analyse the interaction effects
#'
#' @param allsim dataset with all simulations values
#' @param dataset dataset with all variables
#' @param exposures a vector with exposures
#' @param confounders a vector with confounders
#' @param squem squeme of the values of the prediction values
#' @return data frame with interaction values
#' @examples
#' data(expose_data)
#' data(simu)
#' data(gen)
#' delta=c(1,0)
#' seku <- seq(0,1,0.05)
#' Exposures<- c('Var1','Var2','Var3','Var4','Var5')
#' summary_table_lines <- gen[[2]]
#' it <- interact (allsim = simu[[1]], dataset = expose_data,exposures = Exposures,
#' confounders = c('sex'), squem = summary_table_lines)
#' @export

interact <- function(allsim, dataset, exposures, confounders, squem) {

  dataset <- data.frame(dataset)
    N <- dim(dataset)[1]
    sim <- dim(allsim)[2]

    m2 <- NA
    len_cof <- length(confounders)
    len_exp <- length(exposures)
    len_tot <- len_exp + len_cof
    var_tot <- c(exposures, confounders)

    ext2 <- squem[grep("ITE_", squem$Group), ]

    ini <- ext2$From[1]
    fin <- ext2$To[nrow(ext2)]

    allsim <- allsim[ini:fin, ]

    h <- 0
    n <- 1
    z <- len_exp + len_cof
    z2 <- (z * (z - 1)) / 2

    azken_taula <- data.frame(matrix(NA, z2, sim + 1))
    names(azken_taula)[1] <- c("Interaction")
    ec <- 1
    h <- 1
    for (ex in 1:len_tot) {
        ec <- ec + 1
        if (len_tot == ex)
            break
        for (ex2 in ec:len_tot) {
            inter2 <- paste0(var_tot[ex], "-", var_tot[ex2])
            azken_taula[h, 1] <- inter2
            h <- h + 1
        }
    }
    ec <- 1
    h3 <- 1
    gehi <- 0
    for (ex in 1:len_tot) {
        ec <- ec + 1
        if (len_tot == ex)
            break
        for (ex2 in ec:len_tot) {
            inter2 <- paste0(var_tot[ex], "-", var_tot[ex2])
            for (si in 1:sim) {
                n <- 1 + gehi
                n2 <- n + N
                a <- allsim[n:(n2 - 1), si]
                n <- n2
                n2 <- n + N
                b <- allsim[n:(n2 - 1), si]
                n <- n2
                n2 <- n + N

                c <- allsim[n:(n2 - 1), si]
                n <- n2
                n2 <- n + N

                d <- allsim[n:(n2 - 1), si]
                n <- n2
                azken_taula[h3, si + 1] <- mean(a - b - c + d)
            }
            gehi <- gehi + 4 * N
            h3 <- h3 + 1
        }
    }
    azken_taula2 <- data.frame(matrix(NA, z2, 3))
    m1 <- apply(azken_taula[, -1], 1, mean)
    m2 <- apply(azken_taula[, -1], 1, stats::sd)
    azken_taula2 <- data.frame(azken_taula$Interaction, m1, m2)
    names(azken_taula2) <- c("Interaction", "Mean", "SD")
    return(azken_taula2)
}


#First we need to load the RSocrata package.  You may need to install it first.

require(RSocrata)

#Next we will need the plyr package.

require(plyr)

#Now we'll load the dataframe.

slc <- read.socrata("https://opendata.utah.gov/Health/Salt-Lake-School-District-Vaccinations-2014/yud6-5333")

head(slc) #Let's see what the data looks like.

row.names(slc) <- slc$School #Replaces the numbered rows with values from the column 'School'
slc <- slc[,-c(1:5)] #Removes columns 1:5, columns start at 1

#Remove the '%' sign from the numerical data in the three rows we are analyzing

slc$X..adequately.immunized <- gsub("%", "", as.character(slc$X..adequately.immunized))
slc$X..receiving.MMR <- gsub("%", "", as.character(slc$X..receiving.MMR))
slc$X..receiving.DTaP <- gsub("%", "", as.character(slc$X..receiving.DTaP))

slc <- slc[order(slc$X..adequately.immunized),] #Order the data with priority to the column X..adequately.immunized

#Rename columns using the plyr library
slc <- rename(slc, c(X..adequately.immunized="All Six Vaccines", X..receiving.MMR="MMR", X..receiving.DTaP="DTaP"))

slc_matrix <- data.matrix(slc) #The heatmap needs data in a matrix format

#Create the heatmap with R's built in heatmap function
slc_heatmap <- heatmap(slc_matrix, Rowv=NA, Colv=NA, col=brewer.pal(9,"Blues"), scale="column", margins=c(17,17), main="Salt Lake School District Vaccinations 2014")


library(data.table)
library(ggplot2)

setwd("~/Dropbox/upf_global_studies/2017/slides/global_studies_research_methods")

gft = fread('gft_spain.csv')

gft$Date = as.Date(gft$Date)

ggplot(data=gft, aes(Date, Spain)) + geom_line() + ylab("Spain Prediction")

gt = fread('mosquito_trend.csv')

class(gt$Week)
gt$Week = as.Date(gt$Week)
names(gt)[2] = "term"

plt = ggplot(data=gt, aes(Week, term)) + geom_line() + ylab('"Mosquito" Searches Worldwide')

ggsave("mosquito_trend.png", plt)

gt = fread('research_methods_trend.csv')

class(gt$Week)
gt$Week = as.Date(gt$Week)
names(gt)[2] = "term"

plt = ggplot(data=gt, aes(Week, term)) + geom_line() + ylab('"Research Methods" Searches Worldwide')

ggsave("research_methods_trend.png", plt)

gt = fread('machine_learning_trend.csv')

class(gt$Week)
gt$Week = as.Date(gt$Week)
names(gt)[2] = "term"

plt = ggplot(data=gt, aes(Week, term)) + geom_line() + ylab('"Machine Learning" Searches Worldwide')

ggsave("machine_learning_trend.png", plt)

gt = fread('correlate-Influenza_like_Illness_CDC_.csv')
names(gt)
names(gt)[1] = "Week"
names(gt)[2] = "ILI"
names(gt)[3] = "infa"
gt$Week = as.Date(gt$Week, format="%m/%d/%y")

plt = ggplot(data=gt) + geom_line(size=1, aes(Week, ILI, color="ILI (CDC)")) + ylab("Normalized Search Activity / ILI Visits") + geom_line(aes(Week, infa, color="'influenza type a'")) + labs(colour="")

plt = ggplot(data=gt) + geom_point(aes(infa, ILI)) + ylab("ILI (CDC)") + xlab("'influenza type a'")
plt
ggsave("google_correlate_scatter.png", plt)


# library
library(ggplot2)

data = read.csv(file='cleaned_data.csv', sep=',', header = TRUE)
var <- data$streak

plot <- ggplot(data, aes(factor(1), streak)) +
  coord_flip() +
  geom_boxplot()
  # geom_density(binwidth = 1)

print(plot)


#' Check white blood cell measurements against the differential measurements
#' @param data a dataframe
#' @param wbc The name of the column with WBC measurements
#' @param lymph The name of the column with lymphocyte measurements
#' @param mono The name of the column with monocyte measurements
#' @param neutro The name of the column with neutrophil measurements
#' @param eosin The name of the column with eosinophil measurements
#' @param baso The name of the column with basophil measurements
#' @export

wbcCheck<-function(data,wbc="wbc_ncnc_bld",lymph="lymphocyte_ncnc_bld",mono="monocyte_ncnc_bld",
             neutro="neutrophil_ncnc_bld",eosin="eosinophil_ncnc_bld",baso="basophil_ncnc_bld"){
  if(class(data) != "data.frame") stop("data needs to be a dataframe")
  nms<-c(wbc,lymph,mono,neutro,eosin,baso)
  print(nms)
  if(!all(is.element(nms,names(data)))) stop("missing required variables")
  nms2<-c("wbc","lymph","mono","neutro","eosin","baso")
  for(i in 1:6){
    names(data)[names(data)==nms[i]]<-nms2[i]
  }
  print(names(data))
  out<-vector("list",length=5)
  names(out)<-c("wbc.na","sum_withNA_bad","sum_noNA_bad", "abs_dif", "density")
  n<-is.na(data$wbc)
  n2<- !is.na(data$lymph) | !is.na(data$mono) | !is.na(data$neutro) | !is.na(data$eosin) | !is.na(data$baso)
  nq<-n2 & n
  out[[1]]<-sum(nq)

  sel<-!n &n2 # has wbc value and at least one differential value
  n3<- is.na(data$lymph) | is.na(data$mono) | is.na(data$neutro) | is.na(data$eosin) | is.na(data$baso)
  sel2<-sel & n3
  tmp<-data[sel2,]
  tmp3<-data[sel2,c("lymph","mono","neutro","eosin","baso")]
  tmp3$sum<-rowSums(tmp3,na.rm=TRUE)
  dif<-(tmp3$sum - tmp$wbc)/tmp$wbc
  ck<- dif > 0.05
  out[[2]]<-sum(ck)

  n4<- !is.na(data$lymph) & !is.na(data$mono) & !is.na(data$neutro) & !is.na(data$eosin) & !is.na(data$baso)
  sel3<-!n & n4 # has value for wbc and all differentials
  tmp<-data[sel3,]
  tmp4<-tmp[,c("lymph","mono","neutro","eosin","baso")]
  tmp4$sum<-rowSums(tmp4,na.rm=TRUE)
  tmp4$dif <- (tmp4$sum - tmp$wbc)/tmp$wbc
  tmp4$abs_dif <- abs(tmp4$sum - tmp$wbc)/tmp$wbc
  ck<-tmp4$abs_dif > 0.05
  out[[3]]<-sum(ck)

  out[[4]] <- tmp4$abs_dif

  g2 <- tmp4[tmp4$sum != tmp$wbc, ] %>%
    ggplot(aes(x = dif)) + geom_density()
  out[[5]] <- g2

  return(out)
}


source("lib/uvozi.zemljevid.r", encoding = "UTF-8")
library(ggplot2)
library(dplyr)

pretvori.zemljevid <- function(zemljevid) {
  fo <- fortify(zemljevid)
  data <- zemljevid@data
  data$id <- as.character(0:(nrow(data)-1))
  return(inner_join(fo, data, by="id"))
}

# 1. Slovenske občine

mesta <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/ESP_adm_shp.zip",
                          "ESP_adm2", encoding = "UTF-8")
mst <- pretvori.zemljevid(mesta)

## Zemljevid z barvami za površino
zem <- ggplot() + geom_polygon(data = mst, aes(x=long, y=lat, group=group),
                               color = "grey") +
                  scale_fill_gradient(low="#3F7F3F", high="#00FF00")
print(zem)

## Dodamo pike za mesta po tipu občine
zem2 <- zem + geom_point(data = obcine@data, aes(x = Y_C, y = X_C, color = OB_TIP)) +
              scale_color_manual(name="Tip", breaks = c("D", "N"),
                                 labels = c("Mestna občina", "Občina"),
                                 values = c("red", "blue"))
print(zem2)

## Dodamo imena glavnih mest mestnih občin
zem3 <- zem2 + geom_text(data = obcine@data %>% filter(OB_TIP == "D"),
                         aes(x = Y_C, y = X_C, label = OB_UIME),
                         size = 3, vjust = 2)
print(zem3)

# 2. Zvezne države ZDA

zda <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/states_21basic.zip", "states")
capitals <- read.csv("podatki/uscapitals.csv")
row.names(capitals) <- capitals$state
capitals <- preuredi(capitals, zda, "STATE_NAME")
capitals$US.capital <- capitals$capital == "Washington"

## Dodamo podatke o predsedniških volitvah v zemljevid
zda$vote.2012 <- capitals$vote.2012
zda$electoral.votes <- capitals$electoral.votes
usa <- pretvori.zemljevid(zda)

# Zemljevid elektorskih glasov
map1 <- ggplot() + geom_polygon(data = usa, aes(x = long, y = lat, group = group,
                                                fill = electoral.votes))
print(map1)

usa.cont <- usa %>% filter(! STATE_NAME %in% c("Alaska", "Hawaii"))
capitals.cont <- capitals %>% filter(! state %in% c("Alaska", "Hawaii"))

map2 <- ggplot() + geom_polygon(data = usa.cont,
                                aes(x = long, y = lat,
                                    group = group, fill = vote.2012)) +
                   scale_fill_manual(values = c("blue", "red")) +
                   guides(fill = guide_legend("Volitve 2012"))
print(map2)

map3 <- map2 + geom_polygon(data = usa.cont, fill = "black",
                            aes(x = long, y = lat, group = group,
                                alpha = electoral.votes)) +
               scale_alpha(range = c(0.4, 0)) +
               guides(alpha = guide_legend("Elektorski glasovi"))
print(map3)

map4 <- map3 + geom_polygon(data = usa.cont, alpha = 0, color = "gray",
                            aes(x = long, y = lat, group = group))
print(map4)

map5 <- map4 + geom_point(data = capitals.cont, color = "green",
                          aes(x = long, y = lat,
                              shape = US.capital, size = US.capital)) +
               geom_text(data = capitals.cont,
                         aes(x = long, y = lat, label = capital,
                             vjust = US.capital, size = US.capital)) +
               scale_shape_manual(values = c(20, 15), guide = FALSE) +
               scale_size_manual(values = c(3, 5), guide = FALSE) +
               discrete_scale(aesthetics = "vjust", scale_name = NULL,
                              palette = . %>% c(0, 2), guide = FALSE)
print(map5)


#This contains all of the functions used in the model

#Hardcode the corps names by class as generally accessible variables
WorldClass = c("The Academy","Blue Devils","Blue Knights","Blue Stars","Bluecoats","Boston Crusaders","The Cadets","Carolina Crown",
	"The Cavaliers","Colts","Crossmen","Genesis","Jersey Surf","Madison Scouts","Mandarins","Music City","Oregon Crusaders",
	"Pacific Crest","Phantom Regiment","Pioneer","Santa Clara Vanguard","Seattle Cascades","Spirit of Atlanta","Troopers"
)
OpenClass = c("7th Regiment","The Battalion","Blue Devils B","Blue Devils C","Colt Cadets","Columbians","Encorps","Gold","Golden Empire",
	"Guardians","Heat Wave","Impulse","Incognito","Legends","Louisiana Stars","Raiders","River City Rhythm","Shadow",
	"Southwind","Spartans","Vanguard Cadets","Vessel","Watchmen"
)
OC_NotAttending = c("The Battalion","Blue Devils B","Blue Devils C","Columbians","Encorps","Impulse","Incognito",
	"Vanguard Cadets","Vessel","Watchmen"
)

ScoreParse <- function(filename, WorldNames=WorldClass, OpenNames=OpenClass) {
	#Start by loading the file
	BigTable = read.csv(filename, stringsAsFactors=F)

	#This function creates a data frame for a given corps
	FrameCreate <- function(CorpsName, Table) {
		#Start by finding all the rows which have data
		CorpsRows = which(Table$Corps == CorpsName)
		if (length(CorpsRows) == 0) {
			return(NULL)
		}

		#Get vectors for the scores and Day
		GEvec = Table[CorpsRows,"GE"]
		VisVec = Table[CorpsRows,"Visual"]
		MusVec = Table[CorpsRows,"Music"]
		DayVec = Table[CorpsRows,"Day"]

		#Now make the data frame
		OutFrame = data.frame(Day=DayVec, GE=GEvec, Vis=VisVec, Mus=MusVec)
		return(OutFrame)
	}

	#Now run the function on all the world class and open class corps
	WorldFrames = lapply(WorldNames, FrameCreate, Table=BigTable)
	OpenFrames = lapply(OpenNames, FrameCreate, Table=BigTable)
	#Combine them into a single frame
	AllFrames = c(WorldFrames, OpenFrames)

	#Add the corps names to the frames
	names(AllFrames) = c(WorldNames, OpenNames)
	return(AllFrames)
}

#Create a function that fits the exponential curve to a data frame
ExpFitter <- function(CorpsFrame, BaseDay, PrelimsDay=50) {
	#50 is the prelims day for 2019, which is why it's defaulted here

	#Start by checking the number of shows
	if (is.null(CorpsFrame)) { return(NULL) }
	if (nrow(CorpsFrame) < 6) { return(NULL) }

	#Order the frame by day
	CorpsFrame = CorpsFrame[order(CorpsFrame$Day),]

	#The weight vector reduces weights of recent scores, based on their correlation with finals week scores
	#The weight vector reduces weights of recent scores, based on their correlation with finals week scores
	DayVec = seq(from=0, to=PrelimsDay+2, by=1)
	WeightVec = 1 - (PrelimsDay-DayVec)*0.00224
	DiscountOrig = 0.25 + (0.75-0.25)/PrelimsDay * BaseDay
	DiscountVec = seq(from=1, to=DiscountOrig, length.out=6)

	#Create a vector for the corps-specific day weights
	ShowWeights = WeightVec[CorpsFrame$Day]
	#Now discount the most recent 5
	Nshow = length(ShowWeights)
	ShowWeights[(Nshow-5):Nshow] = ShowWeights[(Nshow-5):Nshow] * DiscountVec

	#Pull out the individual vectors to match nls input better
	N = sum(CorpsFrame$Day <= BaseDay)
	GE = CorpsFrame$GE[CorpsFrame$Day <= BaseDay]
	Vis = CorpsFrame$Vis[CorpsFrame$Day <= BaseDay]
	Mus = CorpsFrame$Mus[CorpsFrame$Day <= BaseDay]
	Day = CorpsFrame$Day[CorpsFrame$Day <= BaseDay]

	#Now fit the curve for each caption, wrapped in a try to avoid catastrophic errors
	#This tryCatch won't make the objects if we're not successful
	tryCatch({
		GEModel = nls(GE ~ a + Day^b, data=data.frame(GE, Day), start=list(a=GE[1], b=0.5),
			control=nls.control(warnOnly=TRUE), weights=ShowWeights)
		VisModel = nls(Vis ~ a + Day^b, data=data.frame(Vis, Day), start=list(a=Vis[1], b=0.5),
			control=nls.control(warnOnly=TRUE), weights=ShowWeights)
		MusModel = nls(Mus ~ a + Day^b, data=data.frame(Mus, Day), start=list(a=Mus[1], b=0.5),
			control=nls.control(warnOnly=TRUE), weights=ShowWeights)
	}, warning = function(w) { #This makes it so scenarios of non-convergence don't return bad coefficients
		#print("Can't run corps due to non-convergence")
	}, error = function(e) {
		#print("Can't run corps due to an error in curve fitting")
	})

	#Check to see how many of the 3 models exist
	ExistVec = c(exists('GEModel'), exists('VisModel'), exists('MusModel'))

	#Create a copy of CorpsFrame we can modify
	CorpsFrame2 = CorpsFrame
	TrimmedResult = NA #This tracks if we're successful in the if loop

	if (sum(ExistVec) < 3) { #This means we didn't get a good fit in at least 1 caption
		#print("Nonconvergence!")
		#Try removing the most recent scores until we get convergence or too small a sample
		CorpsFrame2 = CorpsFrame2[1:(nrow(CorpsFrame2)-1) ,]

		if (nrow(CorpsFrame) < 6) { #Check for sample size
			break
		} else {
			#Recursion!
			TrimmedResult = ExpFitter(CorpsFrame2, BaseDay)
			#No matter what, we can return TrimmedResult because this is the top level of the recursion
			return(TrimmedResult)
		}
	}

	#Pull out the summary of the models
	GEcoef = summary(GEModel)$coefficients
	Vcoef = summary(VisModel)$coefficients
	Mcoef = summary(MusModel)$coefficients

	#Now pull out the coefficients
	aVec = c(GEcoef[1,1], Vcoef[1,1], Mcoef[1,1])
	bVec = c(GEcoef[2,1], Vcoef[2,1], Mcoef[2,1])

	#And now pull out the standard errors
	aseVec = c(GEcoef[1,2], Vcoef[1,2], Mcoef[1,2])
	bseVec = c(GEcoef[2,2], Vcoef[2,2], Mcoef[2,2])

	#Put the coefficients and standard errors into a data frame
	OutFrame = data.frame(a=aVec, b=bVec, aSE=aseVec, bSE=bseVec, N=rep(N,3))
	row.names(OutFrame) = c('GE','Vis','Mus')
	#return the data frame
	return(OutFrame)
}

#Now make a function that predicts a day for all corps
Predictor <- function(CorpsList, PredictDay, Nmonte, RankDay) {
	#Start by making a function that predicts N scores based on the exponential uncertainty
	ExpPredict <- function(CorpsCoefList, PredictDay, Nmonte) {
		#Start by gathering basic information
		Ncorps = length(CorpsCoefList)

		#This function returns a list of N predictions
		ScoreList = vector(mode='list', length=Ncorps)

		#Loop through each corps and make the random vectors
		for (C in 1:Ncorps) {
			CorpsCoefs = CorpsCoefList[[C]]
			#Recall the exponential is of the form Score = a + Day^b

			#Make a vector of random a's for each caption
			GEa = rnorm(Nmonte, mean=CorpsCoefs["GE","a"], sd=CorpsCoefs["GE","aSE"])
			Va = rnorm(Nmonte, mean=CorpsCoefs["Vis","a"], sd=CorpsCoefs["Vis","aSE"])
			Ma = rnorm(Nmonte, mean=CorpsCoefs["Mus","a"], sd=CorpsCoefs["Mus","aSE"])
			#Make a vector of b's for each caption
			GEb = rnorm(Nmonte, mean=CorpsCoefs["GE","b"], sd=CorpsCoefs["GE","bSE"])
			Vb = rnorm(Nmonte, mean=CorpsCoefs["Vis","b"], sd=CorpsCoefs["Vis","bSE"])
			Mb = rnorm(Nmonte, mean=CorpsCoefs["Mus","b"], sd=CorpsCoefs["Mus","bSE"])

			#Now create the score for each caption
			GEscore = GEa + PredictDay ^ GEb
			Vscore = Va + PredictDay ^ Vb
			Mscore = Ma + PredictDay ^ Mb

			#Now correct each score to make sure they're actually possible
			GEscore[GEscore > 40] = 40
			Vscore[Vscore > 30] = 30
			Mscore[Mscore > 30] = 30

			#Now get the total score list
			ScoreList[[C]] = GEscore + Vscore + Mscore
		}

		#Convert each simulation score to gaps
		BaseScores = vector(mode='double', length=Nmonte)
		for (i in 1:Nmonte) {
			BaseScores[i] = max(sapply(ScoreList, '[[', i))
		}
		#Now loop through each corps and subtract the base score
		for (C in 1:length(ScoreList)) {
			ScoreList[[C]] = ScoreList[[C]] - BaseScores
		}
		return(ScoreList)
	}

	#Now create a function that predicts N scores based on the random error
	RandPredict <- function(CorpsCoefList, PredictDay, Nmonte, RankDay) {
		library(MASS)

		#Get the basic information
		Ncorps = length(CorpsCoefList)
		#The output will be the score list
		ScoreList = vector(mode='list', length=Ncorps)

		#Make a correlation matrix for the errors
		CorrMat = matrix(nrow=Ncorps, ncol=Ncorps)
		for (Row in 1:Ncorps) {
			for (Col in 1:Ncorps) {
				IndexDiff = abs(Row - Col)
				#Use IndexDiff to determine the correlation
				if (IndexDiff == 0) {
					#This is a diag
					CorrMat[Row,Col] = 1
				} else if (IndexDiff > 14) {
					#This is a background correlation
					CorrMat[Row,Col] = 0.263
				} else {
					#This is an off-diag
					CorrMat[Row,Col] = 0.513 - (IndexDiff-1)*(0.25/14)
				}
			}
		}
		#To account for the effect of doing caption specific correlations, we increase the correlation
		CorrMat = CorrMat * 1.25
		diag(CorrMat) = 1

		#Now multiply the correlation matrix by the variances for each captions
		#the historical noise magnitude is 4, so the captions are adjusted to add to that:
			# 40^2 * GEvar + 30^2 * Mvar + 30^2 Vvar = 4
			# 1600GEvar + 900Mvar + 900Vvar = 4
			# Mvar = Vvar = Cvar - assuming the music and visual errors are the same
			# 1600GEvar + 1800Cvar = 4
			# GEvar = 4/3 * Cvar - assuming error is scaled by total caption score
			# (4/3)1600Cvar + 1800Cvar = 4
			# with some rounding...
			# 3900Cvar = 4
			# Cvar = 4 / 3900
		# We now need to apply the variance to each individual caption
		# At some point the error needs to be scaled by total points, so we'll do it  here
		GEcov = CorrMat * 40 * sqrt(4/3900)
		CapCov = CorrMat * 30 * sqrt(4/3900)

		#Draw the random numbers using the covariance matrices,
		GErand = mvrnorm(Nmonte, mu=rep(0,Ncorps), Sigma=GEcov, empirical=F)
		Mrand = mvrnorm(Nmonte, mu=rep(0,Ncorps), Sigma=CapCov, empirical=F)
		Vrand = mvrnorm(Nmonte, mu=rep(0,Ncorps), Sigma=CapCov, empirical=F)

		#We choose the column of random numbers for each corps based on their rank
		# In 2018, we ranked by caption but now we use total score as it better indicates performance order
		RankScores = vector(mode='double', length=Ncorps)

		#We still need the caption scores to do the predictions
		GEscores = vector(mode='double', length=Ncorps)
		Vscores = vector(mode='double', length=Ncorps)
		Mscores = vector(mode='double', length=Ncorps)

		#Fill in the vectors
		for (C in 1:Ncorps) {
			GEscores[C] = CorpsCoefList[[C]]["GE","a"] + RankDay ^ CorpsCoefList[[C]]["GE","b"]
			Vscores[C] = CorpsCoefList[[C]]["Vis","a"] + RankDay ^ CorpsCoefList[[C]]["Vis","b"]
			Mscores[C] = CorpsCoefList[[C]]["Mus","a"] + RankDay ^ CorpsCoefList[[C]]["Mus","b"]
			RankScores = GEscores + Vscores + Mscores
		}

		#Convert these to gaps
		GEscores = GEscores - max(GEscores)
		Vscores = Vscores - max(Vscores)
		Mscores = Mscores - max(Mscores)
		RankScores = RankScores - max(RankScores)

		#Adjust the scores down of OC if we're late in the season
		# OC coprs need to be discounted because the scores get inflated late in the season
		if (RankDay >= 40 & PredictDay > 48) {
			needOCadjust = names(CorpsCoefList) %in% OpenClass
			GEscores[needOCadjust] = GEscores[needOCadjust] - (2 * 0.4)
			Vscores[needOCadjust] = Vscores[needOCadjust] - (2 * 0.3)
			Mscores[needOCadjust] = Mscores[needOCadjust] - (2 * 0.3)
			RankScores[needOCadjust] = RankScores[needOCadjust] - 2
		}

		#Get the rank vector
		CorpsRanks = match(RankScores, sort(RankScores, decreasing=T)) #Ranks from highest to lowest

		#Now loop through each corps and fill in ScoreList
		for (C in 1:Ncorps) {
			# In 2018 we had a damping effect to account for slotting, but that effect is now captured
			# 	by other parts in the model.
			GEvec = GEscores[C] + GErand[,CorpsRanks[C]]
			Mvec = Mscores[C] + Mrand[,CorpsRanks[C]]
			Vvec = Vscores[C] + Vrand[,CorpsRanks[C]]

			#Put the summed scores into the list
			ScoreList[[C]] = GEvec + Mvec + Vvec
		}

		return(ScoreList)
	}

	#Get the number of corps
	Ncorps = length(CorpsList)

	#Run both score predictors
	ExpScoreList = ExpPredict(CorpsList, PredictDay, Nmonte)
	RandScoreList = RandPredict(CorpsList, PredictDay, Nmonte, RankDay)
	#print(RandScoreList)

	#Now create the overall score and rank lists to return
	ScoreList = vector(mode='list', length=Ncorps)
	RankList = vector(mode='list', length=Ncorps)

	#Fill in the final ScoreList
	for (C in 1:Ncorps) {
		ScoreList[[C]] = 0.317*ExpScoreList[[C]] + 0.683*RandScoreList[[C]]
	}
	# vars = sapply(ScoreList, var); print(mean(vars)); print(vars) #debugging

	#Fill in RankList by sorting the scores
	for (n in 1:Nmonte) {
		#Get the scores and rank them
		scores = sapply(ScoreList, '[[', n)
		ranks = match(scores, sort(scores, decreasing=T))
		#Now put the ranks into the list
		for (C in 1:Ncorps) {
			RankList[[C]][n] = ranks[C]
		}
	}

	#Retain the names in the lists
	names(ScoreList) = names(CorpsList)
	names(RankList) = names(CorpsList)

	#return the lists
	return(list(ScoreList, RankList))
}

#this function returns a vector of information for each corps
	#mean score,percent odds of being in 1st, second, thrid, top12, and top25
PredictionReduce_WorldClass <- function(PredictionList) {
	ScoreList = PredictionList[[1]]
	RankList = PredictionList[[2]]

	#Get the simple information
	Ncorps = length(PredictionList[[1]])
	Nmonte = length(PredictionList[[1]][[1]])
	CorpsNames = names(PredictionList[[1]])

	#create a vector for each returned value
	MeanScores = vector(mode='double', length=Ncorps)
	PercGold = vector(mode='double', length=Ncorps)
	PercSilver = vector(mode='double', length=Ncorps)
	PercBronze = vector(mode='double', length=Ncorps)
	PercFinals = vector(mode='double', length=Ncorps)
	PercSemis = vector(mode='double', length=Ncorps)

	#Loop through each corps and fill the vectors in
	for (C in 1:Ncorps) {
		MeanScores[C] = mean(ScoreList[[C]])
		PercGold[C] = sum(RankList[[C]] == 1) / Nmonte
		PercSilver[C] = sum(RankList[[C]] == 2) / Nmonte
		PercBronze[C] = sum(RankList[[C]] == 3) / Nmonte
		PercFinals[C] = sum(RankList[[C]] <= 12) / Nmonte
		PercSemis[C] = sum(RankList[[C]] <= 25) / Nmonte
	}

	#Adjust the gaps to make sure 1st place is a 0
	MeanScores = MeanScores - max(MeanScores)

	#Now format these into a data frame
	OutFrame = data.frame(Mean=MeanScores, Gold=PercGold, Silver=PercSilver, Bronze=PercBronze, Finals=PercFinals, Semis=PercSemis)
	row.names(OutFrame) = CorpsNames

	#Sort the data frame by percent chance of gold
	OutFrame = OutFrame[order(OutFrame$Mean, decreasing=T),]

	#Now return the data frame
	return(OutFrame)
}

#This function returns a vector of information for each corps, based on open class
	#that's mean score, percent odds of being in 1st, 2nd, 3rd, and making OC Finals
PredictionReduce_OpenClass <- function(PredictionList) {
	ScoreList = PredictionList[[1]]
	RankList = PredictionList[[2]]

	#Get the simple information
	Ncorps = length(PredictionList[[1]])
	Nmonte = length(PredictionList[[1]][[1]])
	CorpsNames = names(PredictionList[[1]])

	#create a vector for each returned value
	MeanScores = vector(mode='double', length=Ncorps)
	PercGold = vector(mode='double', length=Ncorps)
	PercSilver = vector(mode='double', length=Ncorps)
	PercBronze = vector(mode='double', length=Ncorps)
	PercFinals = vector(mode='double', length=Ncorps)

	#Loop through each corps and fill the vectors in
	for (C in 1:Ncorps) {
		MeanScores[C] = mean(ScoreList[[C]])
		PercGold[C] = sum(RankList[[C]] == 1) / Nmonte
		PercSilver[C] = sum(RankList[[C]] == 2) / Nmonte
		PercBronze[C] = sum(RankList[[C]] == 3) / Nmonte
		PercFinals[C] = sum(RankList[[C]] <= 12) / Nmonte
	}

	#Make sure 1st place's gap is 0
	MeanScores = MeanScores - max(MeanScores)

	#Now format these into a data frame
	OutFrame = data.frame(Mean=MeanScores, Gold=PercGold, Silver=PercSilver, Bronze=PercBronze, Finals=PercFinals)
	row.names(OutFrame) = CorpsNames

	#Sort the data frame by percent chance of gold
	OutFrame = OutFrame[order(OutFrame$Mean, decreasing=T),]

	#Now return the data frame
	return(OutFrame)
}


library(SparkR)
sc <- sparkR.init(master="local[*]")

logFile <- file(Sys.getenv("R_LOG"), "w")

logInfo <- function(...){
  args <- list(...)
  line <- paste(args, collapse = ";")
  writeLines(line, logFile)
}

workers <- as.integer(Sys.getenv('WORKERS'))
numbersCount <- as.integer(Sys.getenv('NUMBERS_COUNT'))
textFile <- Sys.getenv('TEXT_FILE')

# =============================================================================
# Serialization
# =============================================================================

time <- proc.time()
rddNumbers <- parallelize(sc, as.numeric(seq(0, numbersCount)), workers)
time <- as.double(proc.time()-time)[3]

logInfo('NumbersSerialization', time)

# =============================================================================
# Computing
# =============================================================================

isPrime = function(x) {
  if(x < 2){
    c(x, FALSE)
  }
  else if(x == 2){
    c(x, TRUE)
  }
  else if(x %% 2 == 0){
    c(x, FALSE)
  }
  else{
    upper <- as.numeric(sqrt(as.double(x)))
    result <- TRUE

    i <- 3
    while(i <= upper){
      if(x %% i == 0){
        result = FALSE
        break
      }

      i <- i+2
    }

    c(x, result)
  }
}

time <- proc.time()
rdd <- map(rddNumbers, isPrime)
capture.output(collect(rdd), file='/dev/null')
time <- as.double(proc.time()-time)[3]

logInfo('IsPrime', time)

close(logFile)
sparkR.stop()


# GetRandomContrastData_quarterly.r

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

# G E T   D A T A
if (exists("results")) {rm(results)}
alldata.df <- fndfGetGiantDataRaw("")
newdat <- alldata.df %>%
group_by(copies, lifem, auditfrequency, audittype, auditsegments) %>%
summarize(mdmlosspct=round(midmean(lost/docstotal)*100.0, 2), n=n())

# Params today: quarterly auditing, five copies.
SEGMENTS <- 4
NCOPIES <- 5
results <- filter(newdat, auditsegments==SEGMENTS)
trows <- filter(results, copies==NCOPIES)

# P L O T   D A T A
library(ggplot2)
source("../common/PlotUtil.r")

gp <- ggplot(data=trows
            , aes(x=lifem,y=safe(mdmlosspct)
            , color=factor(audittype)
            , shape=factor(copies)
            , segs=factor(auditsegments)
                    )
            )

# Plots
gp <- fnPlotLogScales(gp, x="YES", y="YES"
                ,xbreaks=c(2,5,10,100,1000)
                ,ybreaks=c(0.01,0.10,1.00)
                )
gp <- gp + geom_line(
                  size=3
                , show.legend=TRUE
                )
gp <- gp + geom_point(data=trows
                , size=6
                , show.legend=TRUE
                , color="black"
                )

# Legends
gp <- gp + labs(color="Audit type"
                , shape="Copies"
                , segs="Audit segments\nper year"
                )
gp <- gp + theme(legend.position=c(0.8,0.7))
gp <- gp + theme(legend.background=element_rect(fill="lightgray",
                                  size=0.5, linetype="solid"))
gp <- gp + theme(legend.key.size=unit(0.3, "in"))
gp <- gp + theme(legend.key.width=unit(0.6, "in"))
gp <- gp + theme(legend.text=element_text(size=16))
gp <- gp + theme(legend.title=element_text(size=14))
gp <- gp + scale_color_discrete(labels=c("systematic","random"))

# Titles
gp <- fnPlotTitles(gp
            , titleline="Random auditing WITH replacement "
                %+% "misses many documents "
                %+% "that are then vulnerable to error, "
                %+% "\ncompared with auditing "
                %+% "WITHOUT replacement segmented at the same frequency "
                %+% "\n"
                %+% "\n(Uniform random vs total systematic auditing, quarterly, duration = 10 years)"
            , xlabel="1MB sector half-life (megahours)"
                %+% "                           (lower error rate =====>)"
            , ylabel="permanent document losses (%)"
        )

# Limit lines
# Label the percentage lines out on the right side.
xlabelposition <- log10(800)
gp <- fnPlotPercentLine(gp, xloc=xlabelposition)
gp <- fnPlotMilleLine(gp, xloc=xlabelposition)
gp <- fnPlotSubMilleLine(gp, xloc=xlabelposition)

plot(gp)
fnPlotMakeFile(gp, "randomcontrast_quarterly.png")

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


#!/usr/bin/env Rscript

library(lassosum)
library(data.table)
args = commandArgs(trailingOnly=TRUE)
setwd("/home/rmporsch/projects/ML_genetic_risk/results")

ref = args[1]
dev = args[2]
sumstat = args[3]
ld = args[4]
n = args[5]
phenotype = args[6]
pheno.name = args[7]

ld  <- fread(ld)
ss = fread(sumstat)
# ss$P = as.numeric(ss$P, digits=128)
ss$P[is.infinite(ss$P)] = 1e-128
print(min(ss$P))
cor = p2cor(p = as.numeric(ss$P), n=as.integer(n), sign=as.numeric(ss$BETA))
cor[is.na(cor)] = 0.999999

out <- lassosum.pipeline(cor=cor, chr=ss$CHR, pos=ss$BP,
                         A1=ss$A1,
                         ref.bfile=ref, test.bfile=dev,
                         LDblocks = ld)

dat = read.table(phenotype, head=T)
dev_fam = read.table(paste0(out$test.bfile, '.fam'))
names(dev_fam)[1:2] = c('FID', 'IID')
sub = merge(dev_fam, dat, by=c('FID', 'IID'))
ssub = sub[,c('FID', 'IID', pheno.name)]
ssub = dat[,c('FID', 'IID', pheno.name)]
v <- validate(out, pheno=ssub)
output = v$validation.table

output.name = paste(dev,'phenotype', 'lasso', sep='.')
write.table(output, output.name)


# plotrocfischer.r - plot ROCs for different method on Fischer and Nh3D data
#
# Alex Stivala, October 2008
#
# Plot ROC curves for different methods on the Fischer data set
# (Fischer et al 1996) and Nh3D data set (Thiruv et al 2005)
#  as used in Pelta et al 2008.
#
# Requires the ROCR package from CRAN (developed with version 1.0-2)
# (ROCR in turn requires gplots, gtools, gdata)
#
# Run this on the output of e.g. tsevalfn.py with the -l option,
# it is a table with one column of scores from classifier, and second
# column of true class label (0 or 1)
#
# The citation for the ROCR package is
#   Sing et al 2005 "ROCR: visualizing classifier performance in R"
#   Bioinformatics 21(20):3940-3941
#
#
# $Id: plotrocs_fischer_nh3d.r 2376 2009-05-14 01:40:32Z astivala $

library(ROCR)

#
# globals
#

colorvec=c('deepskyblue4','brown','red','turquoise','blue','purple','green','cyan','gray20','magenta','darkolivegreen2','midnightblue','magenta3','darkseagreen','violetred3','darkslategray3')
ltyvec=c(1,2,4,5,6,1,2,1,5,6,1,2,4,5,6,1,2)
namevec=c('MSVNS3 norm1','MSVNS3 norm2', 'MSVNS3 norm3', 'QP tableau search norm1', 'QP tableau search norm2', 'QP tableau search norm3')

fischer_fold_files=c('../maxcmo_results/fischer/norm1/fold.slrtab', '../maxcmo_results/fischer/norm2/fold.slrtab','../maxcmo_results/fischer/norm3/fold.slrtab','fischer/norm1/fold.slrtab','fischer/norm2/fold.slrtab','fischer/norm3/fold.slrtab')
fischer_class_files=c('../maxcmo_results/fischer/norm1/class.slrtab','../maxcmo_results/fischer/norm2/class.slrtab','../maxcmo_results/fischer/norm3/class.slrtab','fischer/norm1/class.slrtab','fischer/norm2/class.slrtab','fischer/norm3/class.slrtab')
nh3d_arch_files=c('../maxcmo_results/nh3d/norm1/arch.slrtab','../maxcmo_results/nh3d/norm2/arch.slrtab','../maxcmo_results/nh3d/norm3/arch.slrtab','nh3d/norm1/arch.slrtab','nh3d/norm2/arch.slrtab','nh3d/norm3/arch.slrtab')
nh3d_class_files=c('../maxcmo_results/nh3d/norm1/class.slrtab','../maxcmo_results/nh3d/norm2/class.slrtab','../maxcmo_results/nh3d/norm3/class.slrtab','nh3d/norm1/class.slrtab','nh3d/norm2/class.slrtab','nh3d/norm3/class.slrtab')

#
# functions
#

#
# Return the ROCR performance object for plotting ROC curve
#
# Parameters:
#   tab : data frame with score and label columns
#
# Return value:
#   ROCR performance object with FPR and TPR for plotting ROC curve
#
compute_perf <- function(tab)
{
    # tab is a data frame with score and label columns
    pred <- prediction(tab$score, tab$label)
    perfroc <- performance(pred, measure="tpr",x.measure="fpr")
    return(perfroc)
}

#
# main
#

# EPS suitable for inserting into LaTeX

postscript('rocs_fischer_fold.eps',
           onefile=FALSE,paper="special",horizontal=FALSE,
           width = 9, height = 6)
for (i in 1:length(fischer_fold_files)) {
    tab <- read.table(fischer_fold_files[i], header=TRUE)
    perfroc <- compute_perf(tab)
    plot(perfroc, lty=ltyvec[i], col=colorvec[i], add=(i>1),
         #main='Fischer data set at fold level' # remove title for paper
         )
}
legend('bottomright', col=colorvec, lty=ltyvec, legend=namevec)
#lines(c(0,1),c(0,1),type='l',lty=3)
dev.off()

postscript('rocs_fischer_class.eps',
           onefile=FALSE,paper="special",horizontal=FALSE,
           width = 9, height = 6)
for (i in 1:length(fischer_class_files)) {
    tab <- read.table(fischer_class_files[i], header=TRUE)
    perfroc <- compute_perf(tab)
    plot(perfroc, lty=ltyvec[i], col=colorvec[i], add=(i>1),
#         main='Fischer data set at class level'  # remove title for paper
         )
}
legend('bottomright', col=colorvec, lty=ltyvec, legend=namevec)
#lines(c(0,1),c(0,1),type='l',lty=3)
dev.off()

postscript('rocs_nh3d_arch.eps',
           onefile=FALSE,paper="special",horizontal=FALSE,
           width = 9, height = 6)
for (i in 1:length(nh3d_arch_files)) {
    tab <- read.table(nh3d_arch_files[i], header=TRUE)
    perfroc <- compute_perf(tab)
    plot(perfroc, lty=ltyvec[i], col=colorvec[i], add=(i>1),
         # main='Nh3D data set at architecture level' # remove title for paper
         )
}
legend('bottomright', col=colorvec, lty=ltyvec, legend=namevec)
#lines(c(0,1),c(0,1),type='l',lty=3)
dev.off()

postscript('rocs_nh3d_class.eps',
           onefile=FALSE,paper="special",horizontal=FALSE,
           width = 9, height = 6)
for (i in 1:length(nh3d_class_files)) {
    tab <- read.table(nh3d_class_files[i], header=TRUE)
    perfroc <- compute_perf(tab)
    plot(perfroc, lty=ltyvec[i], col=colorvec[i], add=(i>1),
         # main='Nh3D data set at class level' #  removed title for paper
         )

}
#lines(c(0,1),c(0,1),type='l',lty=3)
legend('bottomright', col=colorvec, lty=ltyvec, legend=namevec)
dev.off()


#Libraries to import
library(ggplot2)
library(reshape2)
library(cowplot)

#Import OTUs
otu6 <- read.table("otu_num_6.csv",sep=",",header=TRUE)
otu505 <- read.table("otu_num_505.csv",sep=",",header=TRUE)
tp <- read.table("otu_num_6.csv",sep=",")[1,6:ncol(otu6)]
#Import all data for proper normalization
all <- read.table("all_clusters-eps_0.16.csv",sep=",")
tp.totals <- colSums(all[,7:ncol(all)])
ntp <- length(6:ncol(otu6))
tscs <- c()
for (tsc in otu6$TimeClustNumber) {
    tscs <- c(tscs, rep(tsc,ntp))
}
#Encode the second OTU's -1 cluster as a different label to avoid them getting the same colour
for (tsc in otu505$TimeClustNumber) {
    if (tsc == -1) {tsc<--2}
    tscs <- c(tscs, rep(tsc,ntp))
}

#Melt the data
otu6 <- melt(t(otu6[,6:ncol(otu6)]))
otu6$value <- otu6$value/tp.totals
otu505 <- melt(t(otu505[,6:ncol(otu505)]))
otu505$value <- otu505$value/tp.totals
#Numbering starts at 1 for each cluster, so add the previous max
otu505$Var2 <- otu505$Var2 + max(otu6$Var2)

#Turn it into a data frame
clusters <- rbind(otu6,otu505)
df <- data.frame(TSC=as.factor(tscs),Sequence=clusters$Var2, Abundance=clusters$value, OTU=as.factor(c(rep(6,dim(otu6)[1]),rep(505,dim(otu505)[1]))), Time=rep(as.vector(t(tp)),dim(clusters)[1]/length(tp)))
levels(df$OTU) <- c("OTU 6", "OTU 505")

#Plot
p<-ggplot(df, aes(x=Time, y=Abundance, color=TSC, group=Sequence))+geom_line(alpha=0.7)
p<-p+xlab("Time (days)")+ylab("Sequence Relative Abundance")+theme(legend.position='none')+facet_grid(OTU~.,scales="free_y")

p

ggsave("Figure4.pdf",p,width=4,height=4)


source("split_samples_utils.r")
library(Seurat)
library(ggplot2)

files_lines=read.table(parSampleFile1, sep="\t")
files=split(files_lines$V1, files_lines$V2)

params_lines=read.table(parSampleFile3, sep="\t")
params=split(params_lines$V1, params_lines$V2)
params$hto_ignore_exists=ifelse(params$hto_ignore_exists=="0", FALSE, TRUE)

idx=3
for(idx in c(1:length(files))){
  fname=names(files)[idx]
  output_prefix = paste0(fname, ".HTO")
  output_file=paste0(output_prefix, ".csv")

  if(file.exists(output_file) & params$hto_ignore_exists){
    next
  }

  h5file=files[[idx]]
  cat(fname, ":", h5file, " ...\n")

  obj=read_hto(h5file, output_prefix)

  obj <- HTODemux(obj, assay = "HTO", positive.quantile = 0.99)

  obj$HTO_classification[obj$HTO_classification.global == "Doublet"] = "Doublet"

  output_post_classification(obj, output_prefix)
}


library(rstan)
library(data.table)
library(lubridate,warn.conflicts = FALSE)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats)

source("utils/arg-parser.r")
source("utils/read-interventions.r")
source("utils/process-covariates.r")
source("utils/process-covariates-region.r")
source("utils/ifr-tools.r")
source("utils/log-and-process.r")

VERSION="v5"

# Commandline options and parsing
parsedargs <- base_arg_parse()
DEBUG <- parsedargs[["DEBUG"]]
FULL <- parsedargs[["FULL"]]
StanModel <- parsedargs[["StanModel"]]
new_sub_folder <- parsedargs[["new_sub_folder"]]
max_date <- parsedargs[["max_date"]]
mobility_source <- parsedargs[["mobility_source"]]
formula_pooling <- parsedargs[["formula_pooling"]]
formula_partialpooling <- parsedargs[["formula_partialpooling"]]
zone_definition_file <- parsedargs[["activezones"]]
mobility_processing <- parsedargs[["mobilityprocessing"]]

run_name <- create_analysis_folder(FULL, DEBUG, StanModel)

region_to_country_map <- read_country_region_map(zone_definition_file)

## Reading data from region file and world data and trimming it to max_date
data_files <- c(
  "data/COVID-19-up-to-date.rds",
  "data/all-france.rds"
)
countries <- names(region_to_country_map)
d <- read_obs_data(countries, data_files, max_date)
# Trim countries and regions that fail the number of death test.
death_thresh_epi_start = 10

trimmed_map = trim_country_map(
  d, region_to_country_map, max_date, death_thresh_epi_start)
region_to_country_map <- trimmed_map$region_to_country_map
countries <- names(region_to_country_map)

# Modelling + Forecasting
min_forecast <- 14
min_N2 <- 130
N2 <- max((trimmed_map$max_epi_data + min_forecast), min_N2)

## get IFR and population from same file
ifr.by.country <- return_ifr()
interventions <- read_interventions('data/interventions.csv', max_date)
mobility <- read_mobility(mobility_source, zone_definition_file)

formula = as.formula(formula_pooling)
formula_partial = as.formula(formula_partialpooling)
processed_data <- process_covariates_regions(
  region_to_country_map = region_to_country_map,
  mobility = mobility,
  interventions = interventions,
  d = d,
  ifr.by.country = ifr.by.country,
  N2 = N2,
  formula = formula,
  formula_partial = formula_partial,
  death_thresh_epi_start=death_thresh_epi_start,
  mobility_processing=mobility_processing
)

stan_data <- processed_data$stan_data
dates <- processed_data$dates
reported_deaths <- processed_data$deaths_by_country
reported_cases <- processed_data$reported_cases
infection_to_onset = processed_data$infection_to_onset
onset_to_death = processed_data$onset_to_death
processed_mobility = processed_data$processed_mobility

log_simulation_inputs(run_name, region_to_country_map,  ifr.by.country,
    infection_to_onset, onset_to_death, VERSION, parsedargs, processed_mobility)
options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
m = stan_model(paste0('stan-models/',StanModel,'.stan'))

if(DEBUG) {
  fit = sampling(m,data=stan_data,iter=40,warmup=20,chains=2)
} else if (FULL) {
  fit = sampling(m,data=stan_data,iter=2000,warmup=1500,chains=4,thin=1,control = list(adapt_delta = 0.95, max_treedepth = 15))
} else {
  fit = sampling(m,data=stan_data,iter=600,warmup=300,chains=4,thin=1,control = list(adapt_delta = 0.95, max_treedepth = 10))
}

out = rstan::extract(fit)
estimated_cases_raw = out$prediction
estimated_deaths_raw = out$E_deaths
estimated_deaths_cf = out$E_deaths0

covariate_data = list(interventions, mobility)
save.image(paste0('results/',run_name,'.Rdata'))
save(
  fit, estimated_cases_raw, dates,reported_cases,reported_deaths,countries,
  region_to_country_map, estimated_deaths_raw, estimated_deaths_cf,
  out,interventions,covariate_data, infection_to_onset, onset_to_death, VERSION,
  formula_pooling, formula_partialpooling,
  file=paste0('results/',run_name,'-stanfit.Rdata'))

postprocess_simulation(run_name, out, countries, dates)


summary.MI <- function (object, subset = NULL, ...) {
  if (length(object) == 0) {
    stop('Invalid input for "subset"')
  } else {
    if (length(object) == 1) {
      return(summary(object[[1]]))
    }
  }

                                        # Roman: This function isn't fecthing coefficients robustly. Something goes wrong. Contact package author.
  getcoef <- function(obj) {
                                        # S4
    if (!isS4(obj)) {
      coef(obj)
    } else {
      if ("coef3" %in% slotNames(obj)) {
        obj@coef3
      } else {
        obj@coef
      }
    }
  }

                                        #
  res <- list()

                                        # Get indices
  subset <- if (is.null(subset)) {
    1:length(object)
  } else {
    c(subset)
  }

                                        # Compute the summary of all objects
  for (k in subset) {
    res[[k]] <- summary(object[[k]])
  }

                                        # Answer
  ans <- list(
    zelig = object[[1]]$name,
    call = object[[1]]$result@call,
    all = res
    )

                                        #
  coef1 <- se1 <- NULL

                                        #
  for (k in subset) {
                                        #       tmp <-  getcoef(res[[k]]) # Roman: I changed this to coef, not 100% sure if the output is the same
    tmp <- coef(res[[k]])
    coef1 <- cbind(coef1, tmp[, 1])
    se1 <- cbind(se1, tmp[, 2])
  }

  rows <- nrow(coef1)
  Q <- apply(coef1, 1, mean)
  U <- apply(se1^2, 1, mean)
  B <- apply((coef1-Q)^2, 1, sum)/(length(subset)-1)
  var <- U+(1+1/length(subset))*B
  nu <- (length(subset)-1)*(1+U/((1+1/length(subset))*B))^2

  coef.table <- matrix(NA, nrow = rows, ncol = 4)
  dimnames(coef.table) <- list(rownames(coef1),
                               c("Value", "Std. Error", "t-stat", "p-value"))
  coef.table[,1] <- Q
  coef.table[,2] <- sqrt(var)
  coef.table[,3] <- Q/sqrt(var)
  coef.table[,4] <- pt(abs(Q/sqrt(var)), df=nu, lower.tail=F)*2
  ans$coefficients <- coef.table
  ans$cov.scaled <- ans$cov.unscaled <- NULL

  for (i in 1:length(ans)) {
    if (is.numeric(ans[[i]]) && !names(ans)[i] %in% c("coefficients")) {
      tmp <- NULL
      for (j in subset) {
        r <- res[[j]]
        tmp <- cbind(tmp, r[[pmatch(names(ans)[i], names(res[[j]]))]])
      }
      ans[[i]] <- apply(tmp, 1, mean)
    }
  }

  class(ans) <- "summaryMI"
  ans
}


studyId = "999"
dataFile0 = "points0.data"
dataFile7 = "points7.data"
dataFile14 = "points14.data"
dataFile21 = "points21.data"

goal = 1000
bounds = c(0,321)

targets = c(42,84,126,182,224)
goals = rep(goal, length(targets))

previous_rate = 788/4073
#print(previous_rate)

args = commandArgs(TRUE)
if(length(args) == 3){
   studyId = args[[1]]
   dataFile = args[[2]]
   target = args[[3]]
}

data0  = read.csv(dataFile0 ,header=FALSE,sep=",",stringsAsFactors=TRUE)
data7  = read.csv(dataFile7 ,header=FALSE,sep=",",stringsAsFactors=TRUE)
data14 = read.csv(dataFile14,header=FALSE,sep=",",stringsAsFactors=TRUE)
data21 = read.csv(dataFile21,header=FALSE,sep=",",stringsAsFactors=TRUE)

#data = as.numeric(data)

#dataOrdered = data[order(data)]
#print(dataOrdered)

proportional_target = round(length(data0)*previous_rate)
#print(proportional_target)

counts = rep(0, length(targets))
for(i in 1:length(targets)){
	counts[i] = max(which(data0 > targets[i]))
}
#print(length(data0))
#print(counts)

plotCircle = function(x,y,text){
	for(i in length(x):1){
		points(x[i], y[i], pch=21, cex=3, lw=2, col="black", bg="white", type='p')
		text(x[i], y[i], text[i])
	}
}

barColor0 = rgb(0.0,0.5,1.0)
barColor7 = rgb(0.3,0.65,1.0) #rgb(0.0,0.5,1.0,0.7)
barColor14 = rgb(0.5,0.75,1.0) #rgb(0.0,0.5,1.0,0.5)
barColor21 = rgb(0.8,0.9,1.0) #rgb(0.0,0.5,1.0,0.2)

targetColor1 = rgb(1.0,0.2,0.2,0.3)
targetColor2 = rgb(1.0,0.2,0.2,0.7)
targetColor3 = rgb(1.0,0.2,0.2,1.0)

ymax = max(100,length(data0))
offset = 0.05*ymax

#fileName = paste(studyId,paste("points","pdf",sep="."),sep="_")
fileName = "points.pdf"
pdf(fileName, pointsize=16, width=12, height=8)
    par(mar=c(4.5,4.5,0.5,0.5))
	#main="Parts Completed by Students"
	plot(c(bounds[1]+17,bounds[2]-15), c(-offset,ymax), ylab="Total Number of Students", xlab="Points Awarded", main="", type='n')

	if(length(data0) < 100){
	    text((bounds[1]+bounds[2])/2, (0+ymax)/2, "Insufficient data to generate this plot.  Check back in a few days.")
	} else {
	    for(i in 1:length(targets)){
    		points(c(targets[i],targets[i]), c(counts[i],-500), type='l', lty=1, lw=3, col=rgb(0.0,0.0,0.0,0.2))
    		if(counts[i]<goal){
    		    #red line to target
    			#points(c(targets[i],targets[i]), c(goal,counts[i]), type='l', lw=3, col=targetColor2) #col=rgb(0.0,0.0,0.0,0.5)
    		}
    		#abline(v=targets[i], lw=1, col=targetColor1, lty=2)

    		#points(c(-500,targets[i]), c(counts[i],counts[i]), type='l', lw=3, col=rgb(0.0,0.0,0.0,1.0))
    	}
    	#points(targets, goals-offset, pch=21, cex=3, lw=2, col="black", bg="white", type='p')
    	#text(targets, goals-offset, 1:length(targets))

    	points(c(-100,tail(targets,1)), c(proportional_target,proportional_target), type='l', lw=3, col=rgb(0.0,0.0,0.0,1.0), lty=1)
    	#our dream
    	#points(c(-100,tail(targets,1)), c(goal,goal), type='l', lw=3, col=rgb(0.0,0.0,0.0,1.0), lty=1)
    	#points(c(tail(targets,1),tail(targets,1)), c(goal,-500), type='l', lw=3, col=targetColor3, lty=1)

    	points(data21, 1:length(data21), type='l', lw=4, col=barColor21)
        points(data14, 1:length(data14), type='l', lw=4, col=barColor14)
        points(data7, 1:length(data7), type='l', lw=4, col=barColor7)
    	points(data0, 1:length(data0), type='l', lw=4, col=barColor0)

    	plotCircle(targets, counts-offset, 1:length(targets))
    	#plotCircle(targets, rep(0, length(targets)), 1:length(targets))

    	#plotCircle(rep(0, length(targets)), counts, 1:length(targets))
	}

	legend("topright", c("Present", "1 Week Ago", "2 Weeks Ago", "3 Weeks Ago", "Last Session", "Assignment"), cex=1.0, pch=c(-1,-1,-1,-1,-1, 21), lwd=c(4,4,4,4,3,2), lty=c(1,1,1,1,1,-1), col=c(barColor0,barColor7,barColor14,barColor21,"black","black"), bg="white");
dev.off()


sizeof (char) = 1
sizeof (signed char) = 1
sizeof (unsigned char) = 1
sizeof (short) = 2
sizeof (signed short) = 2
sizeof (unsigned short) = 2
sizeof (int) = 4
sizeof (signed int) = 4
sizeof (unsigned int) = 4
sizeof (long long) = 8
sizeof (signed long long) = 8
sizeof (unsigned long long) = 8
sizeof (float) = 4
sizeof (double) = 8


create_index_filename <- function(sinkdir, datecode, fresoutput){

  files <- dir(sinkdir)
  files <- files[grepl(paste('frescalo_',datecode,sep=''),files)]
  if(sum(grepl('\\(',files))>0){ # if we have indexed files already index the new file as max+1

    files <- gsub(".csv",'',gsub(paste('frescalo_',datecode,sep=''),'',files)) #remove text from file name
    files <- gsub("\\)",'',gsub("\\(",'',files)) # remove brackets
    max_index <- max(as.numeric(files),na.rm=TRUE) # find the highest index number
    new_index <- max_index + 1

  } else {

    new_index <- 1

  }

  fresoutput <- paste(fresoutput,'(',new_index,')',sep='')
  return(fresoutput)

}


# define radar coordinates
coord_radar <- function(theta = "x", start = 0, direction = 1)
{
  theta <- match.arg(theta, c("x", "y"))
  r <- if (theta == "x")
    "y"
  else "x"
  ggproto("CoordRadar", CoordPolar, theta = theta, r = r, start = start,
          direction = sign(direction),
          is_linear = function(coord) TRUE)
}


# Test anova= in ggplot
require(rms)
set.seed(1)
x1 <- runif(100)
x2 <- runif(100)
x3 <- sample(c('a','b'), 100, TRUE)
x4 <- sample(c('k','l','m'), 100, TRUE)
y <- runif(100)
dd <- datadist(x1, x2, x3, x4); options(datadist='dd')
f <- ols(y ~ x1 + x2 + x3 + x4)

a <- anova(f)
ggplot(Predict(f), anova=a)   # ok
ggplot(Predict(f), anova=a, sepdiscrete='vertical')


library(sjPlot)
load(file='wdBlk_models.rds')
tab_model(fe_b, fe_b_onlywdBlk, fe_w, fe_w_onlywdBlk, fe_wb, fe_wb_onlywdBlk, lme_b_i, lme_b_i_onlywdBlk, lme_w_i, lme_w_i_onlywdBlk, lme_wb_i, lme_wb_i_onlywdBlk, lme_wb_is_sing, lme_wb_is_onlywdBlk_sing, show.aic=TRUE, show.re.var=FALSE, show.ci=FALSE, show.icc=FALSE, dv.labels=c('fe_b', 'fe_b_onlywdBlk', 'fe_w', 'fe_w_onlywdBlk', 'fe_wb', 'fe_wb_onlywdBlk', 'lme_b_i', 'lme_b_i_onlywdBlk', 'lme_w_i', 'lme_w_i_onlywdBlk', 'lme_wb_i', 'lme_wb_i_onlywdBlk', 'lme_wb_is_sing', 'lme_wb_is_onlywdBlk_sing'), file='Results/models/wdBlk_silence.html')


library(stringr)
library(rvest)
library(dplyr)

EU.clanice <- read_html("podatki/oznake_drzav.html") %>%
  html_nodes(xpath="//table[@class='tdcontent']") %>% .[[1]] %>%
  html_table() %>% select(3, 5) %>% head(27)

colnames(EU.clanice) <- c("Država", "Oznaka.države")

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

poraba.elektrike <- read.csv("podatki/Proizvodnja_elektrike_EU_mesecno.csv") %>%
  select(siec, geo, TIME_PERIOD, OBS_VALUE) %>% filter(siec != "CF")

colnames(poraba.elektrike) <- c("Vir", "Oznaka.države", "Datum", "Količina")

poraba.elektrike$Leto <- sapply(strsplit(poraba.elektrike$Datum, "-"), "[", 1) %>% as.integer()
poraba.elektrike$Mesec <- sapply(strsplit(poraba.elektrike$Datum, "-"), "[", 2) %>% as.integer()
poraba.elektrike$Datum <- NULL

viri <- tibble(Vir=c("premog", "zemeljski.plin", "olje.nafta", "hidro", "geotermalna",
                     "veter", "sonce", "drugi.obnovljivi.viri", "nuklearna", "druga.goriva"),
               Oznaka=c("C0000", "G3000", "O4000XBIO", "RA100", "RA200", "RA300", "RA400",
                        "RA500_5160", "N9000", "X9900"))

poraba.elektrike$Vir <- viri$Vir[match(poraba.elektrike$Vir, viri$Oznaka)]

poraba.elektrike <- poraba.elektrike %>% filter(Oznaka.države %in% EU.clanice$Oznaka.države)

poraba.elektrike <- poraba.elektrike[, c("Oznaka.države", "Leto", "Mesec", "Vir", "Količina")]

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

BDP <- read.csv("podatki/BDP_EU_cetrtletje.csv") %>%
  select(geo, TIME_PERIOD, OBS_VALUE) %>% filter(geo %in% EU.clanice$Oznaka.države)

colnames(BDP) <- c("Oznaka.države", "Datum", "BDP")

BDP$Leto <- sapply(strsplit(BDP$Datum, "-Q"), "[", 1) %>% as.integer()
BDP$Četrtletje <- sapply(strsplit(BDP$Datum, "-Q"), "[", 2) %>% as.integer()
BDP$Datum <- NULL

BDP <- BDP[, c("Oznaka.države", "Leto", "Četrtletje", "BDP")]


context("Facetting (layout)")

a <- data.frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1))
b <- data.frame(a = 3)
c <- data.frame(b = 3)
empty <- data.frame()

test_that("grid: single row and single col equivalent", {
  row <- facet_grid(a~.)$train(list(a))
  col <- facet_grid(.~a)$train(list(a))

  expect_equal(row$ROW, 1:2)
  expect_equal(row$ROW, col$COL)
  expect_equal(row[c("PANEL", "a")], col[c("PANEL", "a")])

  row <- facet_grid(a~.)$train(list(a, b))
  col <- facet_grid(.~a)$train(list(a, b))

  expect_equal(row$ROW, 1:3)
  expect_equal(row$ROW, col$COL)
  expect_equal(row[c("PANEL", "a")], col[c("PANEL", "a")])
})

test_that("grid: includes all combinations", {
  d <- data.frame(a = c(1, 2), b = c(2, 1))
  all <- facet_grid(a~b)$train(list(d))

  expect_equal(nrow(all), 4)
})

test_that("wrap and grid equivalent for 1d data", {
  rowg <- facet_grid(a~.)$train(list(a))
  roww <- facet_wrap(~a, ncol = 1)$train(list(a))
  expect_equal(roww, rowg)

  colg <- facet_grid(.~a)$train(list(a))
  colw <- facet_wrap(~a, nrow = 1)$train(list(a))
  expect_equal(colw, colg)
})

test_that("grid: crossed rows/cols create no more combinations than necessary", {
  facet <- facet_grid(a~b)
  facet$params$plot_env <- emptyenv()
  one <- facet$train(list(a))
  expect_equal(nrow(one), 4)

  one_a <- facet$train(list(a, empty))
  expect_equal(nrow(one_a), 4)

  two <- facet$train(list(a, b))
  expect_equal(nrow(two), 4 + 2)

  three <- facet$train(list(a, b, c))
  expect_equal(nrow(three), 9)

  four <- facet$train(list(b, c))
  expect_equal(nrow(four), 1)
})

test_that("grid: nested rows/cols create no more combinations than necessary", {
  one <- facet_grid(drv+cyl~.)$train(list(mpg))
  expect_equal(one$PANEL, factor(1:9))
  expect_equal(one$ROW, 1:9)
})

test_that("grid: margins add correct combinations", {
  one <- facet_grid(a~b, margins = TRUE)$train(list(a))
  expect_equal(nrow(one), 4 + 2 + 2 + 1)
})

test_that("wrap: as.table reverses rows", {
  one <- facet_wrap(~a, ncol = 1, as.table = FALSE)$train(list(a))
  expect_equal(one$ROW, c(2, 1))

  two <- facet_wrap(~a, nrow = 1, as.table = FALSE)$train(list(a))
  expect_equal(two$ROW, c(1, 1))
})

test_that("grid: as.table reverses rows", {
  one <- facet_grid(a~., as.table = FALSE)$train(list(a))
  expect_equal(as.character(one$a), c("2", "1"))

  two <- facet_grid(a~., as.table = TRUE)$train(list(a))
  expect_equal(as.character(two$a), c("1", "2"))
})

# Drop behaviour -------------------------------------------------------------

a2 <- data.frame(
  a = factor(1:3, levels = 1:4),
  b = factor(1:3, levels = 4:1)
)

test_that("wrap: drop = FALSE preserves unused levels", {
  wrap_a <- facet_wrap(~a, drop = FALSE)$train(list(a2))
  expect_equal(nrow(wrap_a), 4)
  expect_equal(as.character(wrap_a$a), as.character(1:4))

  wrap_b <- facet_wrap(~b, drop = FALSE)$train(list(a2))
  expect_equal(nrow(wrap_b), 4)
  expect_equal(as.character(wrap_b$b), as.character(4:1))

})

test_that("grid: drop = FALSE preserves unused levels", {
  grid_a <- facet_grid(a~., drop = FALSE)$train(list(a2))
  expect_equal(nrow(grid_a), 4)
  expect_equal(as.character(grid_a$a), as.character(1:4))

  grid_b <- facet_grid(b~., drop = FALSE)$train(list(a2))
  expect_equal(nrow(grid_b), 4)
  expect_equal(as.character(grid_b$b), as.character(4:1))

  grid_ab <- facet_grid(a~b, drop = FALSE)$train(list(a2))
  expect_equal(nrow(grid_ab), 16)
  expect_equal(as.character(grid_ab$a), as.character(rep(1:4, each = 4)))
  expect_equal(as.character(grid_ab$b), as.character(rep(4:1, 4)))

})

# Missing behaviour ----------------------------------------------------------

a3 <- data.frame(
  a = c(1:3, NA),
  b = factor(c(1:3, NA)),
  c = factor(c(1:3, NA), exclude = NULL)
)

test_that("missing values get a panel", {
  wrap_a <- facet_wrap(~a)$train(list(a3))
  wrap_b <- facet_wrap(~b)$train(list(a3))
  wrap_c <- facet_wrap(~c)$train(list(a3))
  grid_a <- facet_grid(a~.)$train(list(a3))
  grid_b <- facet_grid(b~.)$train(list(a3))
  grid_c <- facet_grid(c~.)$train(list(a3))

  expect_equal(nrow(wrap_a), 4)
  expect_equal(nrow(wrap_b), 4)
  expect_equal(nrow(wrap_c), 4)
  expect_equal(nrow(grid_a), 4)
  expect_equal(nrow(grid_b), 4)
  expect_equal(nrow(grid_c), 4)
})


#' Plot fleet selectivities
#'
#' Line plots of selectivities by block.
#' @param asap name of the variable that read in the asap.rdat file
#' @param fleet.names names of fleets
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @export

PlotFleetSelBlocks <- function(asap,fleet.names,save.plots,od,plotf,liz.palette){
  par(mfrow=c(1,1) )
  cc=0
  years <- 1:asap$parms$nyears
  for (i in 1:asap$parms$nfleets) {
    a1 <- asap$fleet.sel.start.age[i]
    a2 <- asap$fleet.sel.end.age[i]
    blocks <- unique(asap$fleet.sel.blocks[i,])
    n.blocks <- length(blocks)
    sel.mat <- as.data.frame(asap$fleet.sel.mats[i])
    sel <- matrix(0, nrow=n.blocks, ncol=(a2 - a1 + 1))
    yr <- rep(NA, n.blocks)
    my.col <- rep(NA, n.blocks)
    for (j in 1:n.blocks){
      cc=cc+1
      my.col[j] <- liz.palette[cc]
      yr[j] <- min(years[asap$fleet.sel.blocks[i,]==blocks[j]])
      sel[j,] <- as.numeric(sel.mat[yr[j],a1:a2])
      if (j==1){
        plot(a1:a2, sel[j,], type='l', col=my.col[j],
             xlim=c(0,asap$parms$nages+3), ylim=c(0,1.1),
             xlab="Age", ylab="Selectivity at Age", lwd=2)
      }
      if (j>1){
        lines(a1:a2, sel[j,], type='l', col=my.col[j], lwd=2)
      }
    }
    title(paste0("Fleet ",i," (",fleet.names[i],")"))
    legend("topright", col=my.col, legend=asap$parms$styr+yr-1, lwd=2)
    if (save.plots) savePlot(paste0(od, "Catch.Sel.Blocks.Fleet.",i,".",plotf), type=plotf)
  }
  return()
}


library(pheatmap)
library(gplots)

pdfSize <- 15

# Read data
d <- read.table('heatMap.txt', sep='\t', header=TRUE)
dm <- as.matrix(d)

# Replace NA by 0, otherwise R stops
dm[ is.na(dm) ] <- 0

# PDF output
pdf( width=pdfSize, height=pdfSize, "heatMap_small.pdf")
pheatmap(dm) # Create heatmap
dev.off()

ratio <- dim(dm)[2] / dim(dm)[1]
pdfSizeX <- ratio * pdfSize
pdf( width=pdfSizeX, height=pdfSize, "heatMap_large.pdf")
pheatmap(dm) # Create heatmap
dev.off()


plot.hmac.out <- function(x){

levels <- length(x$membership)

image.array <- array(NA,c(640,480,levels))
for (i in 1:levels){
img <- matrix(as.matrix(x$membership[[i]]),480,640)
img <- t(img[nrow(img):1,])
image.array[,,i] <- img

}

par(mar=c(1,1,1,1))
par(mfrow=c(3,3))
for (i in 1:9){
image(image.array[,,i],col=rainbow(30),xaxt='n',yaxt='n')

}

}


# packages ----
library(knitr)
library(lubridate)
library(progress)
library(tidyverse)
library(xml2)

# functions ----
source("get_xml.r")
source("extract_overview.r")
source("extract_historic.r")
source("extract_dividends.r")
source("clean_overview.r")
source("clean_price.r")
source("clean_dividends.r")
source("download_ishares.r")

# parameters ----
dir_ishares <- "/path/to/folder"
dir_overview <- file.path(dir_ishares, "ishares_overview")
dir_price <- file.path(dir_ishares, "ishares_price")
dir_dividends <- file.path(dir_ishares, "ishares_dividends")

data_etf <- read_tsv(file.path(dir_ishares, "data_ishares_url.tsv"))

# get xml data ----
data_xml <- get_xml(data_etf$url[1])

# extract and clean data ----
map2(data_etf$name, data_etf$url, download_ishares)

# get exchange rate data ----
file_zip <- tempfile()
download.file("https://www.ecb.europa.eu/stats/eurofxref/eurofxref-hist.zip", file_zip)
data_fx <- read_csv(unz(file_zip, "eurofxref-hist.csv")) %>%
  select(date = Date, usd_rate = USD, gbp_rate = GBP)

# aggregate data ----
ishares_data <- map(data_etf$name, ~{

  # load files
  overview <- read_tsv(file.path(dir_overview, str_c(.x, "_overview.tsv")))
  price <- read_tsv(file.path(dir_price, str_c(.x, "_price.tsv")))
  dividends <- read_tsv(file.path(dir_dividends, str_c(.x, "_dividends.tsv")))

  # get metadata
  name <- .x
  isin <- overview$value[overview$parameter == "ISIN"]

  # combine data
  out <- tibble(name, isin) %>%
    mutate(id = TRUE) %>%
    left_join(mutate(price, id = TRUE), by = "id") %>%
    select(-id)

  # dividends
  if(dim(dividends)[1] > 0) {
    out <- out %>%
      left_join(dividends, by = "date") %>%
      mutate(dividend = coalesce(dividend * 0.725, 0)) %>%
      mutate(dividend = cumsum(dividend))
  } else {
    out$dividend <- 0
  }

  out <- out %>%
    mutate(price = price + dividend) %>%
    select(-dividend)

  return(out)
}) %>% bind_rows() %>%
  filter(!is.na(date))

# convert to Euro returns ----
ishares_data <- ishares_data %>%
  left_join(data_fx, by = "date") %>%
  mutate(price = case_when(currency == "USD" ~ price / usd_rate,
                           currency == "GBP" ~ price / gbp_rate,
                           TRUE ~ price)) %>%
  select(-currency, -usd_rate, -gbp_rate)

# trailing monthly returns ----
dates <- tibble(date = seq(from = min(ishares_data$date), to = max(ishares_data$date), by = 1))
dates$i <- rep(1:28, ceiling(nrow(dates) / 28))[seq(nrow(dates))]

data_returns <- map(unique(ishares_data$name), ~{
  xprices <- ishares_data %>%
    filter(name == .x) %>%
    right_join(dates, by = "date") %>%
    fill(name) %>%
    filter(!is.na(name))

  xreturns <- map(1:28, ~{
    out <- xprices %>%
      filter(i == .x) %>%
      mutate(start_px = lag(price)) %>%
      mutate(diff_px = price - start_px) %>%
      mutate(return = diff_px / start_px) %>%
      select(isin, name, date, return)
    return(out)
  }) %>%
    bind_rows() %>%
    arrange(date) %>%
    filter(!is.na(return))
  return(xreturns)
}) %>%   bind_rows()

# average returns, variance, & Sharpe ratio ----

kpi <- data_returns %>%
  group_by(isin, name) %>%
  summarise(risk = var(return),
            returns = mean(return)) %>%
  ungroup() %>%
  mutate(sharpe = (returns / risk) * sqrt(365 / 28)) %>%
  mutate(risk = risk * sqrt(365 / 28) * 100,
        returns = returns * (365 / 28) * 100)

kpi %>%
  arrange(desc(sharpe)) %>%
  select(ISIN = isin, Name = name, Return = returns, Risk = risk, Sharpe = sharpe) %>%
  head(10) %>%
  kable(digits = 2)

kpi %>%
  select(Return = returns, Risk = risk, Sharpe = sharpe) %>%
  ggplot() +
  geom_abline(aes(intercept = 0, slope = 1)) +
  geom_abline(aes(intercept = 0, slope = max(kpi$sharpe)), colour = "darkgreen") +
  geom_point(aes(x = Risk, y = Return, colour = Sharpe))

# share of months with positive returns ----

data_returns %>%
  mutate(return = return > 0) %>%
  group_by(isin, name) %>%
  summarise(week_pos = sum(return),
            week_tot = n()) %>%
  mutate(share_pos = week_pos / week_tot * 100) %>%
  arrange(desc(share_pos)) %>%
  select(ISIN = isin, Name = name, Share_Positives = share_pos, Weeks_Positive = week_pos, Weeks_Total = week_tot) %>%
  head(10) %>%
  kable(digits = 2)


####by Heather E. Wheeler 20150202####
##see runscripts/run_01_imputedDGN-WB_CV_elasticNet_chr*sh and qsub.txt for tarbell job submission scripts
date <- Sys.Date()
args <- commandArgs(trailingOnly=T)
#args <- c('22','1')
"%&%" = function(a,b) paste(a,b,sep="")

###############################################
### Directories & Variables
#pre <- "/Users/heather/Dropbox/elasticNet_testing"
pre <- ""

my.dir <- pre %&% "/group/im-lab/nas40t2/hwheeler/PrediXcan_CV/"
ct.dir <- pre %&% "/group/im-lab/nas40t2/hwheeler/PrediXcan_CV/cis.v.trans.prediction/"
gt.dir <- pre %&% "/group/im-lab/nas40t2/hwheeler/PrediXcan_CV/GTEx_2014-06013_release/transfers/PrediXmod/DGN-WB/DGN-imputation/DGN-imputed-for-PrediXcan/"
en.dir <- pre %&% "/group/im-lab/nas40t2/hwheeler/PrediXcan_CV/GTEx_2014-06013_release/transfers/PrediXmod/DGN-WB/DGN-calc-weights/DGN-WB_weights/"

#snpset <- ".hapmapSnpsCEU" ##2015-02-02 results
#snpset <- ".wtcccGenotypedSNPs" ##2015-03-12 results
snpset <- "_1000G"

k <- 10 ### k-fold CV
tis <- "DGN-WB"
chrom <- as.numeric(args[1])
chrname <- "chr" %&% chrom

##alpha = The elasticnet mixing parameter, with 0≤α≤ 1. The penalty is defined as
#(1-α)/2||β||_2^2+α||β||_1.
#alpha=1 is the lasso penalty, and alpha=0 the ridge penalty.

alpha <- as.numeric(args[2]) #alpha to test in CV

################################################
### Functions & Libraries

library(glmnet)
#library(doMC) ##slower on tarbell than using 1 core, not sure why
#registerDoMC(10)
#getDoParWorkers()

################################################
rpkmid <- ct.dir %&% tis %&% ".exp.ID.list"
expid <- scan(rpkmid,"character")
rpkmgene <- ct.dir %&% tis %&% ".exp.GENE.list"
geneid <- scan(rpkmgene,"character")
rpkmfile <- ct.dir %&% tis %&% ".exp.IDxGENE"
expdata <- scan(rpkmfile)
expdata <- matrix(expdata, ncol = length(geneid), byrow=TRUE)
rownames(expdata) <- expid
colnames(expdata) <- geneid

t.expdata <- expdata #don't need to transpose DGN

gencodefile <- my.dir %&% 'gencode.v12.V1.summary.protein.nodup.genenames'
gencode <- read.table(gencodefile)
rownames(gencode) <- gencode[,6]
gencode <- gencode[gencode[,1]==chrname,] ##pull genes on chr of interest
t.expdata <- t.expdata[,intersect(colnames(t.expdata),rownames(gencode))] ###pull gene expression data w/gene info

expsamplelist <- rownames(t.expdata) ###samples with exp data###

#bimfile <- gt.dir %&% "DGN.imputed_maf0.05_R20.8" %&% snpset %&% ".chr" %&% chrom %&% ".bim" ###get SNP position information###
#bim <- read.table(bimfile)
bimfile <- gt.dir %&% "DGN.imputed_maf0.05_R20.8" %&% snpset %&% ".chr" %&% chrom %&% ".bim.rds" ###get SNP position information###
bim <- readRDS(bimfile)
rownames(bim) <- bim$V2

famfile <- gt.dir %&% "DGN.imputed_maf0.05_R20.8" %&% snpset %&% ".ID.list" ###samples with imputed gt data###
fam <- scan(famfile,"character")
samplelist <- intersect(fam,expsamplelist)

exp.w.geno <- t.expdata[samplelist,] ###get expression of samples with genotypes###
explist <- colnames(exp.w.geno)

#gtfile <- gt.dir %&% "DGN.imputed_maf0.05_R20.8" %&% snpset %&% ".chr" %&% chrom %&% ".SNPxID"
#gtX <- scan(gtfile)
gtfile <- gt.dir %&% "DGN.imputed_maf0.05_R20.8" %&% snpset %&% ".chr" %&% chrom %&% ".SNPxID.rds" #smaller file format, faster readin
gtX <-readRDS(gtfile)
gtX <- matrix(gtX, ncol = length(fam), byrow=TRUE)
colnames(gtX) <- fam
rownames(gtX) <- bim$V2
X <- gtX[,samplelist]

X <- t(X) #transpose to match code below (one ID per row)

resultsarray <- array(0,c(length(explist),8))
dimnames(resultsarray)[[1]] <- explist
resultscol <- c("gene","alpha","cvm","lambda.iteration","lambda.min","n.snps","R2","pval")
dimnames(resultsarray)[[2]] <- resultscol
workingbest <- "working_" %&% tis %&% "_exp_" %&% k %&% "-foldCV_elasticNet_alpha" %&% alpha %&% "_" %&% snpset %&% "_chr" %&% chrom %&% "_" %&% date %&% ".txt"
write(resultscol,file=workingbest,ncolumns=8,sep="\t")

weightcol = c("gene","SNP","refAllele","effectAllele","beta")
workingweight <- en.dir %&% tis %&% "_elasticNet_alpha" %&% alpha %&% "_" %&% snpset %&% "_weights_chr" %&% chrom %&% "_" %&% date %&% ".txt"
write(weightcol,file=workingweight,ncol=5,sep="\t")

set.seed(1001) ##forgot to include in 2/2/15 run, should I re-run?

for(i in 1:length(explist)){
  cat(i,"/",length(explist),"\n")
  gene <- explist[i]
  geneinfo <- gencode[gene,]
  chr <- geneinfo[1]
  c <- substr(chr$V1,4,5)
  start <- geneinfo$V3 - 1e6 ### 1Mb lower bound for cis-eQTLS
  end <- geneinfo$V4 + 1e6 ### 1Mb upper bound for cis-eQTLs
  chrsnps <- subset(bim,bim[,1]==c) ### pull snps on same chr
  cissnps <- subset(chrsnps,chrsnps[,4]>=start & chrsnps[,4]<=end) ### pull cis-SNP info
  cisgenos <- X[,intersect(colnames(X),cissnps[,2])] ### pull cis-SNP genotypes
  if(is.null(dim(cisgenos))){
    bestbetas <- data.frame() ###effectively skips genes with <2 cis-SNPs
  }else{
    minorsnps <- subset(colMeans(cisgenos), colMeans(cisgenos,na.rm=TRUE)>0) ###pull snps with at least 1 minor allele###
    minorsnps <- names(minorsnps)
    cisgenos <- cisgenos[,minorsnps]
    ##cisgenos <- scale(cisgenos, center=T, scale=T)
    ##cisgenos[is.na(cisgenos)] <- 0
    if(is.null(dim(cisgenos)) | dim(cisgenos)[2] == 0){###effectively skips genes with <2 cis-SNPs
      bestbetas <- data.frame() ###effectively skips genes with <2 cis-SNPs
    }else{

      exppheno <- exp.w.geno[,gene] ### pull expression data for gene
      exppheno <- scale(exppheno, center=T, scale=T)  ###need to scale for fastLmPure to work properly
      exppheno[is.na(exppheno)] <- 0
      rownames(exppheno) <- rownames(exp.w.geno)

      ##run Cross-Validation over alphalist
      fit <- cv.glmnet(cisgenos,exppheno,nfolds=k,alpha=alpha,keep=T,parallel=F) ##parallel=T is slower on tarbell, not sure why

      fit.df <- data.frame(fit$cvm,fit$lambda,1:length(fit$cvm)) ##pull info to find best lambda
      best.lam <- fit.df[which.min(fit.df[,1]),] # needs to be min or max depending on cv measure (MSE min, AUC max, ...)
      cvm.best = best.lam[,1]
      lambda.best = best.lam[,2]
      nrow.best = best.lam[,3] ##position of best lambda in cv.glmnet output

      ret <- as.data.frame(fit$glmnet.fit$beta[,nrow.best]) # get betas from best lambda
      ret[ret == 0.0] <- NA
      bestbetas = as.vector(ret[which(!is.na(ret)),]) # vector of non-zero betas
      names(bestbetas) = rownames(ret)[which(!is.na(ret))]

      pred.mat <- fit$fit.preval[,nrow.best] # pull out predictions at best lambda

    }
  }
  if(length(bestbetas) > 0){
    res <- summary(lm(exppheno~pred.mat))
    genename <- as.character(gencode[gene,6])
    rsq <- res$r.squared
    pval <- res$coef[2,4]

    resultsarray[gene,] <- c(genename, alpha, cvm.best, nrow.best, lambda.best, length(bestbetas), rsq, pval)

    ### output best shrunken betas for PrediXcan
    bestbetalist <- names(bestbetas)
    bestbetainfo <- bim[bestbetalist,]
    betatable<-as.matrix(cbind(bestbetainfo,bestbetas))
    betafile<-cbind(genename,betatable[,2],betatable[,5],betatable[,6],betatable[,7]) ##output "gene","SNP","refAllele","effectAllele","beta"
    write(t(betafile),file=workingweight,ncolumns=5,append=T,sep="\t") # t() necessary for correct output from write() function

  }else{
    genename <- as.character(gencode[gene,6])
    resultsarray[gene,1] <- genename
    resultsarray[gene,2:8] <- c(NA,NA,NA,NA,0,NA,NA)

  }
  write(resultsarray[gene,],file=workingbest,ncolumns=8,append=T,sep="\t")
}

write.table(resultsarray,file=tis %&% "_exp_" %&% k %&% "-foldCV_elasticNet_alpha" %&% alpha %&% "_" %&% snpset %&% "_chr" %&% chrom %&% "_" %&% date %&% ".txt",quote=F,row.names=F,sep="\t")


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(ggplot2)
library(plyr)
library(dplyr)
library(tidyr)
library(readr)
source('./_function_task_expand_name.r')
source('./_function_task_table.r')
source('./_compute_summary.r')

best.range = 5000

best.model.step.fn = function (errors) {
  best.step = max(length(errors) - best.range, 0) + which.min(tail(errors, best.range))
  if (length(best.step) == 0) {
    return(length(errors))
  } else {
    return(best.step)
  }
}

first.solved.step = function (steps, errors, threshold) {
  index = first(which(errors < threshold))
  if (is.na(index)) {
    return(NA)
  } else {
    return(steps[index])
  }
}

eps = read_csv('../results/function_task_static_mse_expectation.csv') %>%
  filter(simple == FALSE & parameter == 'default') %>%
  mutate(
    operation = revalue(operation, operation.full.to.short)
  ) %>%
  select(operation, input.size, overlap.ratio, subset.ratio, extrapolation.range, threshold)

name.input = '../results/function_task_static_nalu.csv'
name.output.pdf = '../paper/results/function_task_static_nalu.pdf'
name.output.tex = '../paper/results/function_task_static_nalu.tex'

dat = expand.name(read_csv(name.input)) %>%
  merge(eps) %>%
  rename(
    gate = network.layer_2.nalu.gate.mean
  ) %>%
  mutate(
    model = as.factor(ifelse(model == 'NALU', 'NALU (shared)', as.character(model)))
  )

dat.last = dat %>%
  group_by(name) %>%
  summarise(
    threshold = last(threshold),
    best.model.step = best.model.step.fn(metric.valid.interpolation),
    interpolation.last = metric.valid.interpolation[best.model.step],
    extrapolation.last = metric.test.extrapolation[best.model.step],
    interpolation.step.solved = first.solved.step(step, metric.valid.interpolation, threshold),
    extrapolation.step.solved = first.solved.step(step, metric.test.extrapolation, threshold),
    sparse.error.max = sparse.error.max[best.model.step],
    solved = replace_na(metric.test.extrapolation[best.model.step] < threshold, FALSE),
    model = last(model),
    operation = last(operation),
    seed = last(seed),
    size = n(),

    gate.last = gate[best.model.step]
  )

dat.last.rate = dat.last %>%
  group_by(model, operation) %>%
  group_modify(compute.summary) %>%
  ungroup()

save.table(
  dat.last.rate,
  "simple-function-static-nalu-gate-table",
  "Shows the success-rate, when the model converged, and the sparsity error for all weight matrices, with 95\\% confidence interval. Each value is a summary of 100 different seeds.",
  name.output.tex
)

p = ggplot(dat.last, aes(x = gate.last, fill=solved)) +
  geom_histogram(position = "dodge", bins=25) +
  scale_x_continuous(name = 'Gate', labels = function (x.value) {
    return(ifelse(x.value == 1,
                  'add',
                  ifelse(x.value == 0,
                         'mul',
                         sprintf('%.2f', x.value))))
  }) +
  facet_grid(operation ~ model, labeller = labeller(
    model = c(
      'NALU (seperate)' = "Seperate",
      'NALU (shared)' = "Shared"
    ),
    operation = c(
      '$\\bm{\\times}$' = "Multiplication",
      '$\\bm{+}$' = "Addition"
    )
  )) +
  theme(legend.position="right") +
  theme(plot.margin=unit(c(5.5, 10.5, 5.5, 5.5), "points"))
print(p)
ggsave(name.output.pdf, p, device="pdf", width = 11, height = 7, scale=1.4, units = "cm")