#!/usr/local/bin/Rscript
library(psycho)  # used for SDT analysis
library(ggplot2)
library(lmerTest)
library(plyr)
library(dplyr)

source('summary.r')

default_filename <- 'data/cat_20190205_flower_E6.csv'

# accept a filename as an optional command-line argument
args <- commandArgs(trailingOnly=T)
if (length(args) < 1) {
    args <- c(default_filename)
}

# estimates SDT measures of sensitivity & bias for each subject/condition
runSDT <- function(data) {
    # count the number of correct/incorrect trials for each condition
    nIncorrect <- aggregate(wasCorrect ~ subject+isInstructed+isPracticed+isTarget+isFoil+isOld,
                            data, function(x) sum(x==0))$wasCorrect
    data <- aggregate(wasCorrect ~ subject+isInstructed+isPracticed+isTarget+isFoil+isOld, data, sum)
    data$nCorrect <- data$wasCorrect
    data$nIncorrect <- nIncorrect

    # group the old/new stimuli by subject and condition
    data <- merge(subset(data, isOld==1), subset(data, isOld==0), sort=F,
                  by=c('subject', 'isInstructed', 'isPracticed', 'isTarget', 'isFoil'),
                  suffixes=c('.old', '.new'))

    # get sensitivty & bias for each subject on each condition
    indices <- psycho::dprime(data$nCorrect.old, data$nIncorrect.new,
                              data$nIncorrect.old, data$nCorrect.new)
    sdtData <- cbind(data, indices)

    # analyze sensitivity (dprime)
    writeLines('\n\nSensitivity (dprime)')
    #print(summary(lmer(dprime ~ isInstructed*isPracticed*isTarget*isFoil + (1|subject),
    #                   contrasts=list(isPracticed=contr.sum, isInstructed=contr.sum,
    #                                  isTarget=contr.sum, isFoil=contr.sum),
    #                   data=sdtData)))

    # analyze bias (c)
    writeLines('\n\nBias (C)')
    #print(summary(lmer(c ~ isInstructed*isPracticed*isTarget*isFoil + (1|subject),
    #                   contrasts=list(isPracticed=contr.sum, isInstructed=contr.sum,
    #                          isTarget=contr.sum, isFoil=contr.sum),
    #                   data=sdtData)))

    return(sdtData)
}

analyze <- function(data) {
    # Run the LME as 2x2x2x2 (isLearnedxisFoilxIsPracticedxisInstructed)
    m <- glmer(wasCorrect ~ isPracticed*isInstructed*isTarget*isFoil
               + (1|subject), data=data,
               contrasts=list(isPracticed=contr.sum, isInstructed=contr.sum,
                              isTarget=contr.sum, isFoil=contr.sum),
               family=binomial(link='logit'))
    print(summary(m))
    writeLines('Odds Ratios: ')
    print(exp(fixef(m)))
}

# analyze data from each file
for (i in 1:length(args)) {
    filename <- args[i]
    writeLines(filename)

    memData <- subset(read.csv(filename, header=T), task=='test')
    memData$response <- ifelse(memData$wasCorrect, memData$isOld, 1 - memData$isOld)
    memData$RT <- memData$RT / 1000
    memData$isPracticed <- as.factor(memData$isPracticed)
    memData$isInstructed <- as.factor(memData$isInstructed)
    memData$isTarget <- as.factor(memData$isTarget)
    memData$isFoil <- as.factor(memData$isFoil)
    memData$isOld <- as.factor(memData$isOld)

    writeLines(sprintf('Total number of subjects: %d', length(unique(memData$subject))))

    ## exclude subjects with or low learning accuracy
    learnData <- subset(read.csv(filename, header=T), task=='learn' & isPracticed==1)
    endAcc <- aggregate(wasCorrect~subject, learnData, function (trials) mean(tail(trials, 20)))
    excluded = endAcc$subject[endAcc$wasCorrect < 0.85]
    memData <- memData[!(memData$subject %in% excluded),]
    learnData <- learnData[!(learnData$subject %in% excluded),]
    writeLines(sprintf('After exclusion: %d', length(unique(memData$subject))))

    ## exclude trials with high RT
    print(nrow(memData))
    rt.mad <- mad(memData$RT)
    writeLines(sprintf('Median RT+3MAD: %f', mean(memData$RT) + 3*rt.mad))
    memData <- memData[memData$RT >= median(memData$RT) - 3*rt.mad &
                       memData$RT <= median(memData$RT) + 3*rt.mad,]
    print(nrow(memData))

    startAcc <- aggregate(wasCorrect~subject+isInstructed, learnData,
                          function (trials) mean(head(trials, 10)))
    endAcc <- aggregate(wasCorrect~subject+isInstructed, learnData,
                        function (trials) mean(tail(trials, 10)))
    writeLines(sprintf('Instructed: %f %f -> %f %f',
                       mean(subset(startAcc, isInstructed==1)$wasCorrect) * 100,
                       sd(subset(startAcc, isInstructed==1)$wasCorrect) * 100,
                       mean(subset(endAcc, isInstructed==1)$wasCorrect) * 100,
                       sd(subset(endAcc, isInstructed==1)$wasCorrect) * 100))
    writeLines(sprintf('Not Instructed: %f %f -> %f %f',
                       mean(subset(startAcc, isInstructed==0)$wasCorrect) * 100,
                       sd(subset(startAcc, isInstructed==0)$wasCorrect) * 100,
                       mean(subset(endAcc, isInstructed==0)$wasCorrect) * 100,
                       sd(subset(endAcc, isInstructed==0)$wasCorrect) * 100))

    print(aggregate(subject~isPracticed+isInstructed, memData, function (s) length(unique(s))))
    ##print(aggregate(subject~featureLearned+valueLearned+featureFoil+valueFoil, memData, function (s) length(unique(s))))

    writeLines('\n\nRT')

    png('E6_RT2.png', height=500, width=1000)
    print(ggplot(memData) +
          aes(x=interaction(isFoil, isTarget, isPracticed, isInstructed), y=RT,
              color=interaction(isFoil, isTarget, isPracticed, isInstructed),
              group=interaction(isFoil, isTarget, isPracticed, isInstructed)) +
          geom_violin() +
          theme_classic() + ylab('Reaction Time') + ylim(0, 5) +
          #scale_x_discrete(labels=c('Neither', 'Not Learned', 'Learned', 'Both')) +
          theme(axis.text=element_text(size=20),
                axis.title.x=element_blank(),
                axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
                legend.title=element_blank(),
                legend.text=element_text(size=20),
                plot.margin=margin(t=1, b=1, unit='cm')))
    dev.off()

    print(summary(lmer(RT ~ isPracticed*isInstructed*isTarget*isFoil*isOld
                       + (1+isTarget*isOld|subject), data=memData,
                       contrasts=list(isPracticed=contr.sum, isInstructed=contr.sum,
                                      isTarget=contr.sum, isFoil=contr.sum),)))
    quit()

    hits <- subset(memData, isOld==1)
    FAs  <- subset(memData, isOld==0)
    FAs$wasCorrect <- 1-FAs$wasCorrect

    writeLines('\n\nHits')
    #analyze(hits)

    writeLines('\n\nFAs')
    #analyze(FAs)

    sdtData <- runSDT(memData)
    #writeLines('\n\n\n\n\n')
    #write.csv(sdtData, 'sdt.csv')

    # remove individual differences (for repeated measures)
    normRT <- summarySEwithin(memData, 'RT', betweenvars=c('isPracticed', 'isInstructed'),
                              withinvars=c('isTarget', 'isFoil'), idvar='subject')
    normRT$RT_norm <- NULL
    names(normRT) <- c('Practice', 'Instruction', 'Learned', 'NotLearned',
                       'nRT', 'RT', 'sdRT', 'seRT', 'ciRT')
    print(normRT)

    normHits <- summarySEwithin(hits, 'wasCorrect', betweenvars=c('isPracticed', 'isInstructed'),
                                withinvars=c('isTarget', 'isFoil'), idvar='subject')
    normHits$wasCorrect_norm <- NULL
    names(normHits) <- c('Practice', 'Instruction', 'Learned', 'NotLearned',
                         'nHits', 'Hits', 'sdHits', 'seHits', 'ciHits')
    print(normHits)

    normFAs <- summarySEwithin(FAs, 'wasCorrect', betweenvars=c('isPracticed', 'isInstructed'),
                               withinvars=c('isTarget', 'isFoil'), idvar='subject')
    normFAs$wasCorrect_norm <- NULL
    names(normFAs) <- c('Practice', 'Instruction', 'Learned', 'NotLearned',
                        'nFAs', 'FAs', 'sdFAs', 'seFAs', 'ciFAs')
    print(normFAs)

    normDPrime <- summarySEwithin(sdtData, 'dprime', betweenvars=c('isPracticed', 'isInstructed'),
                                  withinvars=c('isTarget', 'isFoil'), idvar='subject')
    normDPrime$dprime_norm <- NULL
    names(normDPrime) <- c('Practice', 'Instruction', 'Learned', 'NotLearned',
                           'nDPrime', 'DPrime', 'sdDPrime', 'seDPrime', 'ciDPrime')
    print(normDPrime)

    normC <- summarySEwithin(sdtData, 'c', betweenvars=c('isPracticed', 'isInstructed'),
                             withinvars=c('isTarget', 'isFoil'), idvar='subject')
    normC$c_norm <- NULL
    names(normC) <- c('Practice', 'Instruction', 'Learned', 'NotLearned',
                      'nC', 'C', 'sdC', 'seC', 'ciC')
    print(normC)

    normedData <- merge(merge(merge(merge(normRT, normHits), normFAs), normDPrime), normC)
    write.csv(normedData, "summary.csv")

    ## plot interaction plots
    png('E6_RT.png', height=500, width=1000)
    print(ggplot(normedData) +
          aes(x=interaction(NotLearned, Learned), y=RT,
              color=interaction(Practice, Instruction),
              group=interaction(Practice, Instruction)) +
          geom_errorbar(aes(ymin=RT - ciRT, ymax=RT + ciRT), width=.2,
                        position=position_dodge(width=.5)) +
          geom_point(size=5, position=position_dodge(width=.5)) +
          theme_classic() + ylab('Reaction Time') +
          scale_x_discrete(labels=c('Neither', 'Not Learned', 'Learned', 'Both')) +
          scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
          theme(axis.text=element_text(size=20),
                axis.title.x=element_blank(),
                axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
                legend.title=element_blank(),
                legend.text=element_text(size=20),
                plot.margin=margin(t=1, b=1, unit='cm')))
    dev.off()

    png('E6_hits.png', height=500, width=1000)
    print(ggplot(normedData) +
          aes(x=interaction(NotLearned, Learned), y=Hits,
              color=interaction(Practice, Instruction),
              group=interaction(Practice, Instruction)) +
          geom_errorbar(aes(ymin=Hits - ciHits, ymax=Hits + ciHits), width=.2,
                        position=position_dodge(width=.5)) +
          geom_point(size=5, position=position_dodge(width=.5))
          + theme_classic() + ylab('Hit Rate') +
          scale_x_discrete(labels=c('Neither', 'Not Learned', 'Learned', 'Both')) +
          scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
          theme(axis.text=element_text(size=20),
                axis.title.x=element_blank(),
                axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
                legend.title=element_blank(),
                legend.text=element_text(size=20),
                plot.margin=margin(t=1, b=1, unit='cm')))
    dev.off()

    png('E6_FAs.png', height=500, width=1000)
    print(ggplot(normedData) +
          aes(x=interaction(NotLearned, Learned), y=FAs,
              color=interaction(Practice, Instruction),
              group=interaction(Practice, Instruction)) +
          geom_errorbar(aes(ymin=FAs - ciFAs, ymax=FAs + ciFAs), width=.2,
                        position=position_dodge(width=.5)) +
          geom_point(size=5, position=position_dodge(width=.5)) +
          theme_classic() + ylab('FA Rate') +
          scale_x_discrete(labels=c('Neither', 'Not Learned', 'Learned', 'Both')) +
          scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
          theme(axis.text=element_text(size=20),
                axis.title.x=element_blank(),
                axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
                legend.title=element_blank(),
                legend.text=element_text(size=20),
                plot.margin=margin(t=1, b=1, unit='cm')))
    dev.off()

    png('E6_sensitivity.png', height=500, width=1000)
    print(ggplot(normedData) +
          aes(x=interaction(NotLearned, Learned), y=DPrime,
              color=interaction(Practice, Instruction),
              group=interaction(Practice, Instruction)) +
          geom_errorbar(aes(ymin=DPrime - ciDPrime, ymax=DPrime + ciDPrime), width=.2,
                        position=position_dodge(width=.5)) +
          geom_point(size=5, position=position_dodge(width=.5)) +
          theme_classic() + ylab(expression(paste('Sensitivity (', d*minute, ')'))) +
          scale_x_discrete(labels=c('Neither', 'Not Learned', 'Learned', 'Both')) +
          scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
          theme(axis.text=element_text(size=20),
                axis.title.x=element_blank(),
                axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
                legend.title=element_blank(),
                legend.text=element_text(size=20),
                plot.margin=margin(t=1, b=1, unit='cm')))
    dev.off()

    png('E6_bias.png', height=500, width=1000)
    print(ggplot(normedData) +
          aes(x=interaction(NotLearned, Learned), y=C,
              color=interaction(Practice, Instruction),
              group=interaction(Practice, Instruction)) +
          geom_errorbar(aes(ymin=C - ciC, ymax=C + ciC), width=.2,
                        position=position_dodge(width=.5)) +
          geom_point(size=5, position=position_dodge(width=.5)) +
          theme_classic() + ylab('Bias (C)') +
          scale_x_discrete(labels=c('Neither', 'Not Learned', 'Learned', 'Both')) +
          scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
          theme(axis.text=element_text(size=20),
                axis.title.x=element_blank(),
                axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
                legend.title=element_blank(),
                legend.text=element_text(size=20),
                plot.margin=margin(t=1, b=1, unit='cm')))
    dev.off()
}


###########################################################
#  from consensus matrix, get PAC index
###########################################################

# Ref: Critical limitations of consensus clustering in class discovery
# Yasin Senbabaoglu, George Michailidis & Jun Z. Li
# Scientific Reports 4, Article number: 6207 (2014)
# doi:10.1038/srep06207

# "the "proportion of ambigous clustering" (PAC),
# defined as the fraction of sample pairs with
# consensus index values falloing in the intermediate
# sub-interval (x1, x2), element of [0, 1]. A low value
# of PAC indicates a flat middle segment, allowing inference
# of the optimal K by the lowest PAC"

setwd(dir="github/stratipy/simulation/r_analysis/")
# install.packages("R.matlab")
library(R.matlab)
# install.packages("diceR")
library(diceR)

# PAC threashold
x1 <- 0.05
x2 <- 0.95
###########################################################

#  to change!
sub_nb <- 10
pat_nb <- 300

subset_name <- paste0(sub_nb, "sub_", pat_nb, "pat")
plot_title <- paste0(sub_nb, " sub-networks with ", pat_nb, " patients")
output_dir <- paste0(subset_name, "/plot")
dir.create(subset_name)
dir.create(output_dir)
base_file <- paste0("../output/nbs_", subset_name, "/consensus_clustering")

mut_type <- c("raw", "diff", "mean_qn", "median_qn")
nmf_type <- c("nmf", "gnmf")
influence_weight <- "min"
simplification <- "True"
alpha <- c(0, 0.7)
tol <- 10e-3
keep_singletons <- "False"
ngh_max <- c(5, 10)
min_mutation <- 0
max_mutation <- 100
n_components <- 2:12
n_permutations <- 1000
lambd <- c(0, 200)
tol_nmf <- 1e-3

a_greek <- intToUtf8(0x03B1)
l_greek <- intToUtf8(0x03BB)

df <- data.frame(type=character(),
                 mut_type=character(),
                 nmf_type=character(),
                 influence_weight=character(),
                 simplification=logical(),
                 alpha=numeric(),
                 tol=numeric(),
                 keep_singletons=logical(),
                 ngh_max=integer(),
                 min_mutation=integer(),
                 max_mutation=integer(),
                 n_components=integer(),
                 n_permutations=integer(),
                 lambd=integer(),
                 tol_nmf=numeric(),
                 pac=numeric(),
                 stringsAsFactors = FALSE)

# iterate all consensus matrix file names
for (i0 in mut_type){
  f0 <- paste(base_file, i0, sep="/")

  for (i1 in nmf_type){
    f1 <- paste(f0, i1, sep='/')

    for (i2 in influence_weight){
      f2 <- paste(f1, i2, sep='/consensus_weight=')

      for (i3 in simplification){
        f3 <- paste(f2, i3, sep="_simp=")

        for (i4 in alpha){
          if(i0!="raw" & i4==0) next
          if(i0=="raw" & i4!=0) next
          f4 <- paste(f3, i4, sep="_alpha=")

          for (i5 in tol){
            f5 <- paste(f4, i5, sep="_tol=")

            for (i6 in keep_singletons){
              f6 <- paste(f5, i6, sep="_singletons=")

              for (i7 in ngh_max){
                f7 <- paste(f6, i7, sep="_ngh=")

                for (i8 in min_mutation){
                  f8 <- paste(f7, i8, sep="_minMut=")

                  for (i9 in max_mutation){
                    f9 <- paste(f8, i9, sep="_maxMut=")

                    for (i10 in n_components){
                      f10 <- paste(f9, i10, sep="_comp=")

                      for (i11 in n_permutations){
                        f11 <- paste(f10, i11, sep="_permut=")

                        for (i12 in lambd){
                          if(i1=="nmf" & i12!=0) next
                          if(i1=="gnmf" & i12==0) next
                          f12 <- paste(f11, i12, sep="_lambd=")

                          for (i13 in tol_nmf){
                            f13 <- paste(f12, i13, sep="_tolNMF=")
                            filename <- paste(f13, ".mat", sep="")

                            if (file.exists(filename)){
                              ia <- paste0(a_greek, "=", i4)
                              il <- paste0(l_greek, "=", i12)
                              ingh <- paste0(i7, "ngh")
                              type_name <- paste(toupper(i1), i0, ia, il, ingh)

                              # PCA function and save as a file
                              data <- readMat(filename)
                              cons_mat <- data$distance.patients
                              pac <- PAC(cons_mat, lower=x1, upper=x2)

                              # add all values to data frame
                              df[nrow(df)+1,] = c(type_name, i0,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12,i13,pac)
                            }
                            else print(paste0("No such file: ", filename))
                          }
                        }
                      }
                    }
                  }
                }
              }
            }
          }
        }
      }
    }
  }
}

# convert some colums' mode (because all mode is character)
logic_col <- c("simplification","keep_singletons")
numeric_col <- c("alpha","tol","tol_nmf","pac")
int_col <- c("ngh_max","min_mutation","max_mutation","n_components","n_permutations","lambd")

for (i in logic_col) df[, i] <- as.logical(df[, i])
for (i in numeric_col) df[, i] <- as.numeric(df[, i])
for (i in int_col) df[, i] <- as.integer(df[, i])

# save data frame as csv file
write.table(df, file=paste0(subset_name, "/all_param_pca.csv"), row.names=FALSE, sep="\t")
# a <- read.csv(file="test.csv")
# b <- df[, c("n_components", "pac")]

###########################################################
library(ggplot2)
# install.packages('svglite')
# require("ggplot2")
# plot saving function
# savePlot <- function(myPlot) {
#   pdf("myPlot.pdf")
#   print(myPlot)
#   dev.off()
# }

# global plot
ggplot(data=df, aes(x=n_components, y=pac, group=type)) +
  geom_line(aes(color=type)) +
  geom_point(aes(color=type)) +
  scale_x_continuous(breaks=n_components) +
  labs(x="Component number", y="PAC") +
  ylim(0, 1) +
  ggtitle(plot_title) +
  theme_bw() +
  theme(legend.title=element_blank(), panel.grid.minor.x = element_blank())

ggsave("all_data.png", plot = last_plot(), path = output_dir,
       width = 7, height = 6, dpi = 300)

# get some rows for plot

# select_rows <- function(data, x1, x2, x3, x4, x5){
#   subset(data,
#          mut_type==x1 &
#            nmf_type==x2 &
#            alpha==x3 &
#            ngh_max==x4 &
#            lambd==x5)
# }
#
# nmf_raw <- select_rows(df, "raw", "nmf", alpha[1], ngh_max, lambd[1])
# nmf_diff <- select_rows(df, "diff", "nmf", alpha[2], ngh_max, lambd[1])
# nmf_mean <- select_rows(df, "mean_qn", "nmf", alpha[2], ngh_max, lambd[1])
# nmf_median <- select_rows(df, "median_qn", "nmf", alpha[2], ngh_max, lambd[1])

nmf_df <- subset(df, nmf_type=="nmf")
gnmf200_df <- subset(df, nmf_type=="gnmf" & lambd==200)
# gnmf1800_df <- subset(df, nmf_type=="gnmf"& lambd==1800)

# NMF plot
ggplot(data=nmf_df, aes(x=n_components, y=pac, group=type)) +
  geom_line(aes(color=type)) +
  geom_point(aes(color=type)) +
  scale_x_continuous(breaks=n_components) +
  labs(x="Component number", y="PAC") +
  ylim(0, 1) +
  ggtitle(plot_title) +
  theme_bw() +
  theme(legend.title=element_blank(), panel.grid.minor.x = element_blank())

ggsave("nmf.png", plot = last_plot(), path = output_dir,
       width = 7, height = 6, dpi = 300)

# GNMF (lambd=200) plot
ggplot(data=gnmf200_df, aes(x=n_components, y=pac, group=type)) +
  geom_line(aes(color=type)) +
  geom_point(aes(color=type)) +
  scale_x_continuous(breaks=n_components) +
  labs(x="Component number", y="PAC") +
  ylim(0, 1) +
  ggtitle(plot_title) +
  theme_bw() +
  theme(legend.title=element_blank(), panel.grid.minor.x = element_blank())

ggsave("gnmf_200.png", plot = last_plot(), path = output_dir,
       width = 7, height = 6, dpi = 300)

# GNMF (lambd=1800) plot
# ggplot(data=gnmf1800_df, aes(x=n_components, y=pac, group=type)) +
#   geom_line(aes(color=type)) +
#   geom_point(aes(color=type)) +
#   scale_x_continuous(breaks=n_components) +
#   labs(x="Component number", y="PAC") +
#   ylim(0, 1) +
#   ggtitle(plot_title) +
#   theme_bw() +
#   theme(legend.title=element_blank(), panel.grid.minor.x = element_blank())
#
# ggsave("gnmf_1800.png", plot = last_plot(), path = output_dir,
#        width = 7, height = 6, dpi = 300)

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


library(nlme)
library(ipw)
library(tidyverse)

#Multilevel panel regression with cross-lagged effects will examine the associations among psychological and behavioral factors and health outcomes over time for HIV positive patients with and without diabetes.

load('data/cleanedData.RData')

table(duplicated(dat[,c('StudyId','time')]))

## do people switch sites?
dat%>%group_by(StudyId)%>%summarize(nsite=n_distinct(Site,na.rm=TRUE))%>%xtabs(~nsite,.)

site <- dat%>%group_by(StudyId)%>%summarize(Site=na.omit(Site)[1])
## function to combine records from the same day
comb <- function(x){
  if(all(is.na(x))) return(NA)
  x <- na.omit(x)
  if(length(x)==1) return(x)
  if(n_distinct(x)==1) return(x[1])
  if(!is.numeric(x)) return(x[1])
  mean(x)
}

dat <- dat%>%filter(!is.na(Date))%>%select(-Date,-BirthYear,-Site)%>%group_by(StudyId,time)%>%summarize_all(comb)

#### effect of dep on adhere controlling for previous cd4, substance abuse, dep
dat$cd4Sqrt <- sqrt(dat$cd4)


library(parallel)
library(foreach)
library(doParallel)
library(ICDMM,
    help,
    pos = 2, lib.loc = NULL
)
library(tidyverse)
library(ggplot2)
library(gdata)
library("gridExtra")
library("scales")
library("here")

source(here("mbench", "scripts", "set_env.R"))
source(here("mbench", "scripts", "get_hut_trail_outcome_by_resistance.R"))
source(here("mbench", "scripts", "get_prevalence_by_eir.R"))

rows <- 1:1
prevalences <- c(0.03, 0.05, 0.10, 0.20, 0.30, 0.5)
itn_covs <- c(0.6, 0.8)

plot_export_path <- here("Results", "ITNs_different_levels_of_prevalence")

cases_reduction_with_net <- c()

output_detail <- foreach(row = rows, .combine = "rbind") %:%
  foreach(prevalence = prevalences, .combine = "rbind") %:%
  foreach(itn_cov = itn_covs, .combine = "rbind") %dopar% {
    eta <- gha_params[row, "eta"]
    rho <- gha_params[row, "rho"]
    eir <- get_eir_by_prevalence(prevalence)
    province <- gha_params[row, "adm1"]
    old_province <- gha_params[row, "old_district_name"]
    itn_cov <- itn_cov
    treatment_seeking <-
      gha_params[row, "treatment_seeking"]
    total_population <-
      gha_params[row, "total_population"]
    llins_distributed <-
      gha_params[row, "llins_distributed"]
    resistance <- 1 - gha_params[row, "MORTALITY_ADJUSTED"] / 100

    hut_trail_outcomes <- get_hut_trail_outcome_by_resistance(resistance)
    d_itn <- hut_trail_outcomes$d_itn
    d_pbo <- hut_trail_outcomes$d_pbo
    r_itn <- hut_trail_outcomes$r_itn
    r_pbo <- hut_trail_outcomes$r_pbo
    h_itn <- hut_trail_outcomes$h_itn
    h_pbo <- hut_trail_outcomes$h_pbo

    output_with_itn <- run_model(
      init_EIR = eir,
      country = "Ghana",
      admin2 = old_province,
      time = 365 * 5,
      num_int = 3,
      itn_cov = itn_cov,
      d_ITN0 = d_itn,
      r_ITN0 = r_itn,
      itn_half_life = h_itn,
      ITN_IRS_on = 1,
      ITN_interval = 3 * 365,
      init_ft = treatment_seeking
    )

    return(data.frame(
      adm1 = province,
      date = output_with_itn$t,
      prevalence = output_with_itn$prev,
      initial_prevalence = prevalence,
      itn_coverage = itn_cov,
      total_population = total_population
    ))
  }
write.csv(
  output_detail,
  here("Results", "ITN_with_different_prevalence_level_detail_0321.csv")
)

library(reshape2)
output_detail_short <- output_detail[
  c("date", "prevalence", "initial_prevalence", "itn_coverage")
]
output_detail_wide <- dcast(
  output_detail_short,
  date + itn_coverage ~ initial_prevalence,
  value.var = "prevalence"
)
colnames(output_detail_wide) <- c(
  "date",
  "itn_coverage",
  "p03", "p05", "p10", "p20", "p30", "p50"
)
scaler <- head(subset(output_detail_wide, date == 0), 1)
scaler_03 <- as.numeric(scaler["p03"])
scaler_05 <- as.numeric(scaler["p05"])
scaler_10 <- as.numeric(scaler["p10"])
scaler_20 <- as.numeric(scaler["p20"])
scaler_30 <- as.numeric(scaler["p30"])
scaler_50 <- as.numeric(scaler["p50"])

ggplot(
  data = output_detail_wide,
  aes(x = date / 365)
) +
  geom_line(
    aes(
      y = p03 / scaler_03 * 0.03,
      color = "0.03"
    ),
  ) +
  geom_line(
    aes(
      y = p05 / scaler_05 * 0.05,
      color = "0.05"
    ),
  ) +
  geom_line(
    aes(
      y = p10 / scaler_10 * 0.10,
      color = "0.1"
    ),
  ) +
  geom_line(
    aes(
      y = p20 / scaler_20 * 0.20,
      color = "0.2"
    ),
  ) +
  geom_line(
    aes(
      y = p30 / scaler_30 * 0.30,
      color = "0.3"
    ),
  ) +
  geom_line(
    aes(
      y = p50 / scaler_50 * 0.50,
      color = "0.5"
    ),
  ) +
  ylab("Prevalence") +
  xlab("Year") +
  ggtitle(
    "Prevalences Differences between 60% ITN coverage with 80% ITN coverage"
  ) +
  scale_color_manual(
    name = "Initial Prevalence",
    values = c(
      "0.05" = "darkred",
      "0.03" = "steelblue",
      "0.1" = "#46b462",
      "0.2" = "#b46046",
      "0.3" = "#050505",
      "0.5" = "#b44683"
    )
  ) +
  facet_wrap(.~itn_coverage, ncol=2) +
  theme(legend.title = element_text(angle = -90))

ggsave(
  here("Results",
   "IM_prevalence_ratio_between_itn_60_with_itn_80_detail_prevalence_0321.png"),
  width = 9.22,
  height = 7.12,
  dpi = 600
)


## create summary of cohort that passed DNAm QC

args<-commandArgs(trailingOnly = TRUE)
source(args[1])

library(bigmelon)

setwd(dataDir)

load(normData)

## filter samples
QCSum<-read.csv(paste0(qcOutFolder,"PassQCStatusAllSamples.csv"), stringsAsFactors = FALSE, row.names = 1)
passQC<-rownames(QCSum)[which(QCSum$predLabelledCellType == "TRUE")]
pheno<-pheno[match(passQC, pheno$Basename),]

cellTypes<-unique(pheno$Cell.type)
cellTypes<-cellTypes[!is.na(cellTypes)]
## sort so colours lines up correctly
cellTypes<-sort(cellTypes)
cellCols<-c("darkgreen", "darkblue", "darkmagenta", "deeppink", "darkgray") ## assumes celltypes are order alphabetically
names(cellCols)<-cellTypes

## create dataframe with unique entry for each individual
uniqueIDs<-unique(pheno[,c("Indidivual.ID", "Sex", "Age", "Phenotype", "Tissue.Centre")])

## age distributions
par(mfrow = c(2,3))
age_lim<-range(uniqueIDs$Age,na.rm = TRUE)
hist_breaks<-seq(age_lim[1],age_lim[2], length.out = 25)
hist(pheno$Age, hist_breaks, ylab = "nIndividuals",xlab = "Age",main = "All")
for(each in cellTypes){
	index<-which(pheno$Cell.type == each)
	hist(pheno$Age[index], hist_breaks, col = cellCols[each], ylab = "nIndividuals",xlab = "Age",main = each)
}

## sex distribution
table(pheno$Cell.type, pheno$Sex)

## brain bank distribution
table(pheno$Cell.type, pheno$Tissue.Centre)

## schizophrenia status distribution
table(pheno$Cell.type, pheno$Phenotype)

## compare age prediction by cell type
par(mfrow = c(2,3))
for(each in cellTypes){
	index<-which(pheno$Cell.type == each)
	model<-lm(pheno$Age~pheno$DNAmAge, subset = index)
	plot(pheno$DNAmAge[index], pheno$Age[index], xlab = "Horvath Clock", ylab = "Reported", main=each, pch=16, col=cellCols[each])
	title(main = paste("r = ", signif(cor(pheno$DNAmAge[index], pheno$Age[index], use = "pairwise.complete.obs"),3)), line = 0.5, adj = 1)
	title(main = paste("RMSE = ", signif(sqrt(median(abs(pheno$DNAmAge[index]-pheno$Age[index])^2, na.rm = TRUE)),3)), line = 2, adj = 1)
	abline(model, lty = 2)
	abline(a = 0, b = 1)
}

for(each in cellTypes){
	index<-which(pheno$Cell.type == each)

	model<-lm(pheno$Age~pheno$CCDNAmAge, subset = index)
	plot(pheno$CCDNAmAge[index], pheno$Age[index], xlab = "Cortical Clock", ylab = "Reported", main=each, pch=16, col=cellCols[each])
	title(main = paste("r = ", signif(cor(pheno$CCDNAmAge[index], pheno$Age[index], use = "pairwise.complete.obs"),3)), line = 0.5, adj = 1)
	title(main = paste("RMSE = ", signif(sqrt(median(abs(pheno$CCDNAmAge[index]-pheno$Age[index])^2, na.rm = TRUE)),3)), line = 2, adj = 1)
	abline(model, lty = 2)
	abline(a = 0, b = 1)
}


lengthexpression_Percentile_distribution_of_identified_small_RNA_loci_across_different_lengths<-function(fprefix='input',wdir=".") {

start_time <- proc.time()
cat("Percentile distribution across all characterized and uncharacterized loci (M3.06) start", date(), "\n")

# Plots for Module 3 Analysis and visualization of SPAR output
# Session: Expression characteristics

# Module_3_Figure_6(Figure 3.06)
# Description: Percentile distribution across all characterized and uncharacterized loci
# input: input_annot.with_conservation.xls, input.unannot.final.with_conservation.xls
# output: Percentile_distribution_of_identified_small_RNA_loci_across_different_lengths.png
# output: Percentile_distribution_of_identified_small_RNA_loci_across_different_lengths.pdf

# parameters for the plot
datafile1=paste(wdir, "/", fprefix, "_annot.with_conservation.xls", sep="")
datafile2=paste(wdir, "/", fprefix, "_unannot.with_conservation.xls", sep="")
BASENAME="Percentile_distribution_of_identified_small_RNA_loci_across_different_lengths"
PLOTTITLE="Percentile distribution of all loci \n(normalized by each sncRNA class)"
XTITLE="Peak_length(nt)"
YTITLE="sncRNA_classes"

# libraries needed
suppressPackageStartupMessages(library(reshape2))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(plyr))
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(RColorBrewer))

#args<-commandArgs(TRUE)
#datafile1=args[1] # input file 1
#datafile2=args[2] # input file 2
#wdir=args[3] # output / working directory
#if (length(args)<1) { stop("ERROR: No input! USAGE: script inputfile <output-dir>")}
#if (length(args)<2) { stop("ERROR: No input! USAGE: script inputfile <output-dir>")}
#if (length(args)<3) { wdir="." }
#use current dir if no
#working dir has been specified

# output image file
pngfile = paste(wdir, "/../figures/", paste(BASENAME,".png",sep=""), sep="")
#pdffile= paste(wdir, "/", paste(BASENAME,".pdf",sep=""), sep="")

# Read in data (both characterized and uncharacterized)
D = read.table(datafile1,sep='\t',header=T,comment.ch="")
E = read.table(datafile2,sep='\t',header=T,comment.ch="")
E$annotRNAclass = "unannot"
#DE = rbind(D[,c(1:20,25,29:31)],E)
DE = rbind(D,E)
DE$Peak_length_nt= DE$peakChrEnd-DE$peakChrStart
DEX = DE[,c("Peak_length_nt","peakExprPercentile","annotRNAclass")]

Z = ddply(DEX,Peak_length_nt~annotRNAclass,summarise,sum=sum(peakExprPercentile))

# Read in data (characterized only)
#D = read.table(datafile1,sep='\t',header=T,comment.ch="")
#DEX = D[,c("peakExprPercentile","annotRNAclass")]
#Z = ddply(DEX,Peak_length_nt~annotRNAclass,summarise,sum=sum(peakExprPercentile))

colnames(Z) = c(XTITLE,YTITLE,"sum_of_ranks")
Z = Z[which(Z[,XTITLE]<=44),]

zmelt = dcast(Z,Z[,2]~Z[,1])
zmelt[is.na(zmelt)] <- 0

# col normlization
#cs = colSums(zmelt[,-1])
#u_z = (t((t(zmelt[,-1])/cs)))*100

# row normalization
rs = rowSums(zmelt[,-1])
u_z = zmelt[,-1]/rs*100
u_z = data.frame(zmelt[,1],u_z)
colnames(u_z) = c(YTITLE,as.numeric(colnames(zmelt)[-1]))
final_count = melt(u_z,ID=1)
colnames(final_count)=c(YTITLE,XTITLE,"Norm_sum_of_rank")
final_count[,XTITLE]=as.factor(final_count[,XTITLE])
final_count$Norm_sum_of_rank=as.numeric(final_count$Norm_sum_of_rank)

levels(final_count[,1])[1] = paste(levels(final_count[,1])[1],"(",as.character(table(DEX$annotRNAclass)[1]),")")
levels(final_count[,1])[2] = paste(levels(final_count[,1])[2],"(",as.character(table(DEX$annotRNAclass)[2]),")")
levels(final_count[,1])[3] = paste(levels(final_count[,1])[3],"(",as.character(table(DEX$annotRNAclass)[3]),")")
levels(final_count[,1])[4] = paste(levels(final_count[,1])[4],"(",as.character(table(DEX$annotRNAclass)[4]),")")
levels(final_count[,1])[5] = paste(levels(final_count[,1])[5],"(",as.character(table(DEX$annotRNAclass)[5]),")")
levels(final_count[,1])[6] = paste(levels(final_count[,1])[6],"(",as.character(table(DEX$annotRNAclass)[6]),")")
levels(final_count[,1])[7] = paste(levels(final_count[,1])[7],"(",as.character(table(DEX$annotRNAclass)[7]),")")
levels(final_count[,1])[8] = paste(levels(final_count[,1])[8],"(",as.character(table(DEX$annotRNAclass)[8]),")")
levels(final_count[,1])[9] = paste(levels(final_count[,1])[9],"(",as.character(table(DEX$annotRNAclass)[9]),")")
levels(final_count[,1])[10] = paste(levels(final_count[,1])[10],"(",as.character(table(DEX$annotRNAclass)[10]),")")
levels(final_count[,1])[11] = paste(levels(final_count[,1])[11],"(",as.character(table(DEX$annotRNAclass)[11]),")")
levels(final_count[,1])[12] = paste(levels(final_count[,1])[12],"(",as.character(table(DEX$annotRNAclass)[12]),")")
levels(final_count[,1])[13] = paste(levels(final_count[,1])[13],"(",as.character(table(DEX$annotRNAclass)[13]),")")

# make plot
png(pngfile,width = 7, height = 7, units = 'in', res = 300, type="cairo")
print(	ggplot(final_count,aes(x = final_count[,XTITLE], y = final_count[,YTITLE], fill = Norm_sum_of_rank))+
		theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5))+
		geom_tile()+
		#scale_fill_gradientn(colours=brewer.pal(10,"Paired"),limits=c(0,100), breaks=seq(0,100,by=10),name = "Normalized RPM (%)")+
		scale_fill_gradientn(colours=c("#eff3ff","#c6dbef","#9ecae1","#6baed6","#3182bd","#08519c"),limits=c(0,100), breaks=seq(0,100,by=10),name = "Normalized RPM (%)")+
		ggtitle(PLOTTITLE) + xlab("Peak Length")+ylab(YTITLE) +
		theme(legend.position="bottom",legend.direction="horizontal",legend.text=element_text(size=6),
		axis.text = element_text(size = 14),axis.text.x = element_text(angle = 90, hjust = 1),
		axis.title = element_text(size =18),plot.title = element_text(size = 18)))
dev.off()

cat("Total time for percentile distribution across all characterized and uncharacterized loci analysis (M3.06):", (proc.time() - start_time)[['elapsed']], "seconds (", date(), ")\n")
}

# lengthexpression_Percentile_distribution_of_identified_small_RNA_loci_across_different_lengths(fprefix=fprefix,wdir=wdir)


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " | ", fixed=TRUE), function(s) {
  a <- as.list(strsplit(s[1], " ")[[1]])
  m <- as.integer(s[2])
  while(length(a) > 1) {
    n <- m %% length(a)
    a[[ifelse(n > 0, n, length(a))]] <- NULL
  }
  a[[1]]
}), sep="\n")


sim_contrasts = function(n,var_prefix){(
	1:n
	%>% map(.f=function(x){
		factor(c('lo','hi'))
	})
	%>% (function(x){
		names(x) = paste0(var_prefix,1:length(x))
		return(x)
	})
	%>% cross_df()
	%>% (function(x){
		get_contrast_matrix(
			data = x
			, formula = as.formula(paste('~',paste0(var_prefix,1:ncol(x),collapse='*')))
			, contrast_kind = halfsum_contrasts
		)
	})
)}


library(ggplot2) # Import library
sal = read.csv("/Salaries.csv", header = TRUE) # Open CSV
#Parse in Data from CSV
ggplot(sal, aes(x = Position, y = Salary)) +
  geom_boxplot(outlier.colour = "blue", fill="grey85") +
  labs(title = "Impact on Salary based on Position")


################################################################################################
# Churn-Prediction Machine Learning Project
# Description: A paid project for a venture-backed startup, helping to predict the likeliest customers
# about to churn for a B2C subscription-based app. Here, I am going through a couple of popular
# ML algorithms for this binary classification problem to find baseline performance, and also
# trying out an ensemble method to see if performance improves.
# Date: 2018 Spring
# Author: Tony Tong
################################################################################################

library(caret)
library(dplyr)
library(pROC)
library(vtreat)
library(corrplot)

################################################################################################
# Parallel Processing (To speed up machine learning speeds)
################################################################################################

# Parallel Processing (Added by Tony. My Mac has an i5 processor, which has 4 cores)
library(doParallel)
cl <- makeCluster(detectCores())
registerDoParallel(cl)

# run when rounding up machine learning project to stop the parallel processing
# stopCluster(cl)

################################################################################################
# Obtaining and Pre-processing Data

# Essentially here, I am running the data through a dummy variable conversion (converting text to numerics/ factors)
# and vtreat, which is to standardise, normalise and deal with discrepancies like missing values in the data.

# Workflow: Data -> dummyVar() -> vtreat() -> scale() for both TRAINING and TEST data.
################################################################################################

# Connect to db
connection <- XXXXXXX::pgsql_connect("XXXXXXXXXXXXXXXXXXXXXXXXXXXX")

# Training data. Positive class is set as default to be 0, when there is no renewal.
train_data <- dbGetQuery(connection, "XXXXXXXXXXXXXXXXXXXXXXXXXXXX")

# Test data. Key difference is that there is an extra date filter, to those before 21st Feb as there was an engineering change before.
test_data <- dbGetQuery(connection,"XXXXXXXXXXXXXXXXXXXXXXXXXXXX")

# Dummy variable transformation
transform = dummyVars(" ~ .", data = train_data)
train_data_dummy = data.frame(predict(transform, newdata = train_data))
str(train_data_dummy)

# create a cross frame experiment (TRAINING data)
cross_frame_experiment <- mkCrossFrameCExperiment(train_data_dummy, colnames(train_data_dummy), 'renewed', 1)
plan <- cross_frame_experiment$treatments
performance_stats <- plan$scoreFrame
treated_train <- cross_frame_experiment$crossFrame

# treat TEST data based on the same treatment plan on training data
test_data_dummy = data.frame(predict(transform, newdata = test_data))
treated_test <- vtreat::prepare(plan, test_data_dummy, pruneSig = NULL)

# Scaling
treated_train[, 1:24] = scale(treated_train[, 1:24])
treated_test[, 1:24] = scale(treated_test[, 1:24])

# Converting to character as a downstream function does not work with numerics/ factors.
treated_train$renewed_char <- ifelse(treated_train$renewed == 1, "yes", "no")
treated_test$renewed_char <- ifelse(treated_test$renewed == 1, "yes", "no")

################################################################################################
# Measuring Correlation and picking top 20 variables
################################################################################################

correlation <- cor(treated_train)
corrplot(correlation, method = "circle", tl.cex = .5, tl.col = 'black')
vars = as.data.frame(correlation) %>% mutate(variable = colnames(correlation)) %>%
  select(variable, renewed) %>% arrange(desc(abs(renewed))) %>% dplyr::slice(2:21)

x_vars <- paste(unlist(vars[1:20,1]), collapse=' + ')
equation <- as.formula(paste("renewed_char", x_vars, sep = " ~ " ))

# str(treated_train)
# str(treated_test)

################################################################################################
# Creating a standard set of control parameters in train function

# Number and repeats are changable parameters
################################################################################################

myControl = trainControl(method = "cv", number = 3, repeats = 2, search = 'grid',
                         classProbs = TRUE, summaryFunction=twoClassSummary, verboseIter = TRUE)

################################################################################################
# Machine Learning

# Methods tried:
# Random Forest (rf)
# Logistic Regression (glm)
# Xgboost (xgb)
# Ada (Boosted Classification Tree)
# Naive Bayes (nb)
# Support Vector Machine (svm)

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

#################################
# Random Forest
#################################

rf_fit = train(equation, data = treated_train, method="rf", metric = 'ROC', trControl = myControl)
rf_fit

# testing data
rf_fit_prob <- predict(rf_fit, newdata = treated_test, type='prob')[,2]

roc(treated_test$renewed, rf_fit_prob) %>% auc

confusionMatrix(ifelse(rf_fit_prob>= 0.50, 1, 0), treated_test$renewed)

# Training Data
# ROC        Sens       Spec
# 0.8192454  0.8405315  0.6713205

# Testing Data
# ROC        Sens       Spec
# 0.72       0.6272     0.6926

#################################
# GLMNET (Logistic Regression)
#################################

glmnet_grid <- expand.grid(.alpha = c(0, 0.5, 1), .lambda=seq(0, 1, by=.01))
glmnet_fit <- train(equation, data = treated_train,
                    method='glmnet', tuneGrid=glmnet_grid, metric='ROC',
                    trControl= myControl)
glmnet_fit$results

# testing data

glmnet_fit_prob <- predict(glmnet_fit, newdata = treated_test, type='prob')[,2]

roc(treated_test$renewed, glmnet_fit_prob) %>% auc

confusionMatrix(ifelse(glmnet_fit_prob >= 0.50, 1, 0), treated_test$renewed)

# Training Data
# ROC        Sens       Spec
# 0.8186528  0.8968968  0.6185666

# Testing Data
# ROC        Sens       Spec
# 0.7778     0.7629     0.6667

####################################################
# XGBOOST - extreme gradient boosting (tree method)
####################################################

# xgboost tree (0.9605899  0.8795028  0.9524339)
xgb_grid <- expand.grid(nrounds = 50, #the maximum number of iterations
                        eta = c(0.01,0.1), # shrinkage
                        max_depth = c(2,6,10),
                        gamma = 0,               #default=0
                        colsample_bytree = 1,    #default=1
                        min_child_weight = 1,   #default=1
                        subsample = c(.05, 1))

xgb_fit <- train(equation, data = treated_train, method='xgbTree', tuneGrid=xgb_grid, metric='ROC',
                 trControl=myControl)

xgb_fit

xgb_fit_prob <- predict(xgb_fit, newdata = treated_test, type='prob')[,2]

roc(treated_test$renewed, xgb_fit_prob ) %>% auc

confusionMatrix(ifelse(xgb_fit_prob  >= 0.50, 1, 0), treated_test$renewed)

# Training Data
# ROC        Sens       Spec
# 0.8192677  0.8593222  0.6636708

# Testing Data
# ROC        Sens       Spec
# 0.7864     0.6681     0.7305

################################################################################################
# SVM Modelling
################################################################################################

svm_fit <- train(equation, data = treated_train,
                    method='svmLinear2', metric='ROC',
                    trControl=myControl)
svm_fit

svm_fit_prob <- predict(svm_fit, newdata = treated_test, type='prob')[,2]

roc(treated_test$renewed, svm_fit_prob ) %>% auc

confusionMatrix(ifelse(svm_fit_prob >= 0.50, 1, 0), treated_test$renewed)

# Training Data
# ROC        Sens       Spec
# 0.8079858  0.9309330  0.5743828

# Testing Data
# ROC        Sens       Spec
# 0.7191     0.7694     0.6527

################################################################################################
# NB Modelling
################################################################################################

nb_fit <- train(equation, data = treated_train,
                 method='nb', metric='ROC',
                 trControl=myControl)
nb_fit

nb_fit_prob <- predict(nb_fit, newdata = treated_test, type='prob')[,2]

roc(treated_test$renewed, nb_fit_prob ) %>% auc

confusionMatrix(ifelse(nb_fit_prob >= 0.50, 1, 0), treated_test$renewed)

# Training Data
# ROC        Sens       Spec
# 0.7977393  0.9090973  0.5955845

# Testing Data
# ROC        Sens       Spec
# 0.755      0.7543     0.6527

################################################################################################
# Boosted Classification Trees
################################################################################################

ada_fit <- train(equation, data = treated_train,
                method='ada', metric='ROC',
                trControl=myControl)
ada_fit

ada_fit_prob <- predict(ada_fit, newdata = treated_test, type='prob')[,2]

roc(treated_test$renewed, ada_fit_prob) %>% auc

confusionMatrix(ifelse(ada_fit_prob >= 0.50, 1, 0), treated_test$renewed)

# Training Data
# ROC        Sens       Spec
# 0.8219956  0.8313704  0.6812450

# Testing Data
# ROC        Sens       Spec
# 0.7841     0.7651     0.6567

################################################################################################
# Seeing results on training data (during resampling) to approximate performace of alogrithms
################################################################################################

# Based on a subset training data (sample bags)
results = resamples(list(ada = ada_fit, nb = nb_fit, svm = svm_fit,
                         xgb = xgb_fit, rf = rf_fit, glmnet = glmnet_fit))

summary(results)
bwplot(results)
dotplot(results)
# dev.off() #if plot does not show

################################################################################################
# Ensemble Modelling
################################################################################################

# Adding all 6 to build an ensemble model

treated_train$ada_fit_prob = predict(ada_fit, newdata = treated_train, type='prob')[2] %>% unlist()
treated_train$nb_fit_prob = predict(nb_fit, newdata = treated_train, type='prob')[2] %>% unlist()
treated_train$svm_fit_prob = predict(svm_fit, newdata = treated_train, type='prob')[2] %>% unlist()
treated_train$rf_fit_prob = predict(rf_fit, newdata = treated_train, type='prob')[2] %>% unlist()
treated_train$glmnet_fit_prob = predict(glmnet_fit, newdata = treated_train, type='prob')[2] %>% unlist()
treated_train$xgb_fit_prob = predict(xgb_fit, newdata = treated_train, type='prob')[2] %>% unlist()

treated_test$ada_fit_prob = predict(ada_fit, newdata = treated_test, type='prob')[2] %>% unlist()
treated_test$nb_fit_prob = predict(nb_fit, newdata = treated_test, type='prob')[2] %>% unlist()
treated_test$svm_fit_prob = predict(svm_fit, newdata = treated_test, type='prob')[2] %>% unlist()
treated_test$rf_fit_prob = predict(rf_fit, newdata = treated_test, type='prob')[2] %>% unlist()
treated_test$glmnet_fit_prob = predict(glmnet_fit, newdata = treated_test, type='prob')[2] %>% unlist()
treated_test$xgb_fit_prob = predict(xgb_fit, newdata = treated_test, type='prob')[2] %>% unlist()

# Scaling the probabilities just like all the other data
treated_train[, 27:32] = scale(treated_train[, 27:32])
treated_test[, 27:32] = scale(treated_test[, 27:32])

equation_ensemble <- as.formula("XXXXXXXXXXXXXXXXXXXXXXXXXXXX")

#################################
# GLMNET (Logistic Regression)

# Reruning the machine learning
# using glmnet (arbitrary)
#################################

glmnet_fit_ensemble <- train(equation_ensemble, data = treated_train, method='glmnet',
                             tuneGrid=glmnet_grid, metric = 'ROC', trControl = myControl)

glmnet_fit_ensemble_prob <- predict(glmnet_fit_ensemble, newdata = treated_test , type='prob')[,2]

# KEEP POSITIVE CLASS AT 0! (Did not renew, which is the default in the confusion matrix function)
roc(treated_test$renewed, glmnet_fit_ensemble_prob) %>% auc
confusionMatrix(ifelse(glmnet_fit_ensemble_prob >= 0.50, 1, 0), treated_test$renewed)

####################################################
# XGBOOST - extreme gradient boosting (tree method)
####################################################

xgb_grid <- expand.grid(nrounds = 50, #the maximum number of iterations
                        eta = c(0.01,0.1), # shrinkage
                        max_depth = c(2,6,10),
                        gamma = 0,               #default=0
                        colsample_bytree = 1,    #default=1
                        min_child_weight = 1,   #default=1
                        subsample = c(.05, 1))

xgb_fit_ensemble <- train(equation_ensemble, data = treated_train, method='xgbTree',
                             tuneGrid=xgb_grid, metric = 'ROC', trControl = myControl)

xgb_fit_ensemble_prob <- predict(xgb_fit_ensemble, newdata = treated_test , type='prob')[,2]

# KEEP POSITIVE CLASS AT 0! (Did not renew, which is the default in the confusion matrix function)
roc(treated_test$renewed, xgb_fit_ensemble_prob) %>% auc

confusionMatrix(ifelse(xgb_fit_ensemble_prob >= 0.50, 1, 0), treated_test$renewed)

####################################################
# Conclusion
####################################################
# For single algorithm, having boosted classification trees gave the best performane ROC wise, so we can tell that tree-based
# algorithms seem to work well for this problem type.

# During the ensembling, there was severe overfitting on the training data, as the training accuracy went up to 99% but testing accuracy remained similar to baseline.

# This suggests that the main bottleneck is not from algorithms, perhaps we need more/ better data or fine-tuning hyperparameters.


  sum.data = function(x, factors=c("trip", "set"), variable) {

    if (variable=="number") x[,variable] = 1  # create a dummy variable to allow counting of numbers
    m = as.data.frame.table(
          tapply( X=x[,variable],
                  INDEX=x[,factors],
                  FUN=sum,
                  simplify=T,
                  na.rm=T ) )
    names(m) = c(factors, paste(variable,"tot",sep="."))
    m = factor2character(m, factors)

    return(m)
  }


toPlot <- tbl_df(read.table("../processed/summarized_first_mutations.txt", stringsAsFactors = FALSE, header = TRUE))

ListMutRates <- read.table(file = "../processed/ListMutRatesPerDrug.csv", stringsAsFactors = FALSE, header = TRUE, sep = ",")

#Treatments to test
treatsToTest <- toPlot %>%
    filter(regCats == "M184VI-NRTI-PI"  | regCats == "M184VI-NNRTI-NRTI") %>%
    filter(Reg != "3TC+ABC+AZT+EFV") %>% arrange(Reg)

PIRegs <- treatsToTest %>% filter(regCats == "M184VI-NRTI-PI") %>%
    summarize(Reg = unique(Reg))

NNRTIRegs <- treatsToTest %>% filter(regCats == "M184VI-NNRTI-NRTI") %>%
    summarize(Reg = unique(Reg))

PI.pvals <- foreach(PI = PIRegs$Reg, .combine = "rbind")%do%{

    #For PIs, we're testing the hypothesis - M184V happens first
    checkReg <- treatsToTest  %>% filter(Reg == PI) %>%
        group_by(M184V = drugtype == "M184VI") %>%
        summarize(count = sum(count), .groups = "drop") %>% arrange(M184V)

    splitPIName <- strsplit(PI, split = "\\+")[[1]]
    #sum the mutation rates of the non-3TC/FTC drugs

    namesToMerge = tbl_df(splitPIName)
    names(namesToMerge) <- c("ListDrugs")

    relMuts <- left_join(namesToMerge, ListMutRates, by = "ListDrugs") %>%
        mutate(M184V = grepl("TC", ListDrugs)) %>%
        group_by(M184V) %>%
        summarize(relMuts = sum(ListMutTargetRate), .groups = "drop") %>%
        mutate(relMuts = relMuts/sum(relMuts))

    bt = binom.test((checkReg %>% filter(M184V == TRUE))$count,
               sum(checkReg$count),
               p = (relMuts %>% filter(M184V == TRUE))$relMuts, alternative = "greater")

    c(PI, "3TC/FTC first", bt$statistic, bt$parameter,  round(bt$null.value, 3), signif(bt$p.value, 3))

}

colnames(PI.pvals)[c(1, 2, 6)] <- c("reg", "category", "pval")
PI.pvals <- tbl_df(PI.pvals) %>%
    mutate(pval = as.numeric(pval)) #%>%
#        filter(!grepl("ABC", reg))
#Here, I exclude ABC regimens because it's not clear what the hypothesis here
#should be

PI.toprint <- PI.pvals %>%
    arrange(pval) %>% mutate(rank = 1:n()) %>%
    mutate(BHval = rank/n() * 0.05) %>%
    mutate(sig = pval < BHval)

NNRTI.pvals <- foreach(NNRTI = NNRTIRegs$Reg, .combine = "rbind")%do%{

    #For NNRTIs, we're testing the hypothesis - NNRTI happens first
    checkReg <- treatsToTest  %>% filter(Reg == NNRTI) %>%
        group_by(NNRTI = drugtype == "NNRTI") %>%
        summarize(count = sum(count), .groups = "drop") %>% arrange(NNRTI)

    splitNNRTIName <- strsplit(NNRTI, split = "\\+")[[1]]
    #sum the mutation rates of the NNRTI drugs

    namesToMerge = tbl_df(splitNNRTIName)
    names(namesToMerge) <- c("ListDrugs")

    relMuts <- left_join(namesToMerge, ListMutRates, by = "ListDrugs") %>%
        mutate(NNRTI = is.element(ListDrugs, c("EFV", "NVP"))) %>%
        group_by(NNRTI) %>%
        summarize(relMuts = sum(ListMutTargetRate), .groups = "drop") %>%
        mutate(relMuts = relMuts/sum(relMuts))

    bt = binom.test((checkReg %>% filter(NNRTI == TRUE))$count,
               sum(checkReg$count),
               p = (relMuts %>% filter(NNRTI == TRUE))$relMuts, alternative = "greater")

    c(NNRTI, "NNRTI first", bt$statistic, bt$parameter,  round(bt$null.value, 3), signif(bt$p.value, 3))
}

colnames(NNRTI.pvals)[c(1, 2, 6)] <- c("reg", "category", "pval")
NNRTI.pvals <- tbl_df(NNRTI.pvals) %>%
    mutate(pval = as.numeric(pval))
#Here, I do NOT exclude ABC regimens because both ABC and 3TC are being counted in the same
#category

NNRTI.toprint <- NNRTI.pvals %>%
    arrange(pval) %>% mutate(rank = 1:n()) %>%
    mutate(BHval = rank/n() * 0.05) %>%
    mutate(sig = pval < BHval)

write.csv(NNRTI.toprint, "../tables/NNRTI_pvals.csv")
write.csv(PI.toprint, "../tables/PI_pvals.csv")


#' Iterator that iterates through several iterables concurrently.
#'
#' The resulting iterator aggregates elements from each of the iterables into a
#' list from each iteration. Used for lock-step iteration over several iterables
#' at a time.
#'
#' Although similar to \code{\link[itertools2]{izip}}, missing values are
#' replaced with \code{fill} if the iterables are of uneven length, and
#' Iteration continues until the longest iterable is exhausted.
#'
#' @importFrom iterators iter nextElem
#' @export
#' @param ... multiple arguments to iterate through in sequence
#' @param fill the value used to replace missing values when the iterables in
#' \code{...} are of uneven length
#' @return iterator that iterates through each argument in sequence
#'
#' @examples
#' it <- izip_longest(x=1:3, y=4:6, z=7:9)
#' iterators::nextElem(it) # list(x=1, y=4, z=7)
#' iterators::nextElem(it) # list(x=2, y=5, z=8)
#' iterators::nextElem(it) # list(x=3, y=6, z=9)
#'
#' it2 <- izip_longest(1:3, 4:8)
#' iterators::nextElem(it2) # list(1, 4)
#' iterators::nextElem(it2) # list(2, 5)
#' iterators::nextElem(it2) # list(3, 6)
#' iterators::nextElem(it2) # list(NA, 7)
#' iterators::nextElem(it2) # list(NA, 8)
#'
#' it3 <- izip_longest(1:2, 4:7, levels(iris$Species), fill="w00t")
#' iterators::nextElem(it3) # list(1, 4, "setosa")
#' iterators::nextElem(it3) # list(2, 5, "versicolor")
#' iterators::nextElem(it3) # list("w00t", 6, "virginica")
#' iterators::nextElem(it3) # list("w00t", 7, "w00t")
izip_longest <- function(..., fill=NA) {
  iter_list <- lapply(list(...), iter)
  if (length(iter_list) == 0) {
    stop("At least one argument must be supplied.")
  }

  # TODO: Introduce iterators:::hasNext() to circumvent catching StopIteration?
  #       See the iterators vignette for details.
  nextElem <- function() {
    next_elem <- lapply(iter_list, function(x) {
      try(iterators::nextElem(x), silent=TRUE)
    })

    which_stopped <- sapply(next_elem, stop_iteration)
    all_stopped <- all(which_stopped)

    if (all_stopped) {
      stop("StopIteration", call.=FALSE)
    } else {
      next_elem[which_stopped] <- fill
    }
    next_elem
  }

  it <- list(nextElem=nextElem)
  class(it) <- c("abstractiter", "iter")
  it
}


library(raster)
library(sf)
options(gisBase = "/opt/local/lib/grass80", mc.cores = 4)
library(watershed)
outlet = c(4960487, 2318512)
dem = raster("data/dem.tif")
stream = delineate(dem, threshold = 3e6, outlet = outlet, reach_len = 500)
Tp = pixel_topology(stream)

writeRaster(stream, file="output/neretva.grd", overwrite = TRUE, gdal=c("COMPRESS=DEFLATE"))


# 4. faza: Napredna analiza podatkov

source("lib/libraries.r")

# ==============================================================================
# Uporabljene funkcije pri napredni analizi:
# ==============================================================================

# funkcije uporabljene pri razvrščanju v skupine:

hc.kolena = function(dendrogram, od = 1, do = NULL, eps = 0.5) {
  # število primerov in nastavitev parametra do
  n = length(dendrogram$height) + 1
  if (is.null(do)) {
    do = n - 1
  }
  # k.visina je tabela s štirimi stolpci
  # (1) k, število skupin
  # (2) višina združevanja
  # (3) sprememba višine pri združevanju
  # (4) koleno: ali je točka koleno?
  k.visina = tibble(
    k = as.ordered(od:do),
    visina = dendrogram$height[do:od]
  ) %>%
    # sprememba višine
    mutate(
      dvisina = visina - lag(visina)
    ) %>%
    # ali se je intenziteta spremembe dovolj spremenila?
    mutate(
      koleno = lead(dvisina) - dvisina > eps
    )
  k.visina
}

# iz tabele k.visina vrne seznam vrednosti k,
# pri katerih opazujemo koleno
hc.kolena.k = function(k.visina) {
  k.visina %>%
    filter(koleno) %>%
    dplyr::select(k) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

# narišemo diagram višin združevanja
diagram.kolena = function(k.visina) {
  k.visina %>% ggplot() +
    geom_point(
      mapping = aes(x = k, y = visina),
      color = "black"
    )+
    geom_line(
      mapping = aes(x = as.integer(k), y = visina),
      color = "black"
    )+
    geom_point(
      data = k.visina %>% filter(koleno),
      mapping = aes(x = k, y = visina),
      color = "red", size = 2.5
    )+
    ggtitle(paste("Kolena:", paste(hc.kolena.k(k.visina), collapse = ", "))) +
    xlab("število skupin (k)") +
    ylab("razdalja pri združevanju skupin") +
    theme_classic()
}

diagram.skupine = function(podatki, oznake, skupine, k) {
  podatki = podatki %>%
    bind_cols(skupine) %>%
    rename(skupina = ...4)
  d = podatki %>%
    ggplot(
      mapping = aes(
        x = x, y = y, color = skupina
      )
    ) +
    geom_point() +
    geom_label(label = oznake, size = 2) +
    scale_color_hue(h = c(180, 270)) +
    xlab("") +
    ylab("") +
    theme_classic()
  for (i in 1:k) {
    d = d + geom_encircle(
      data = podatki %>%
        filter(skupina == i)
    )
  }
  d
}

obrisi = function(podatki, hc = TRUE, od = 2, do = NULL) {
  n = nrow(podatki)
  if (is.null(do)) {
    do = n - 1
  }
  razdalje = dist(podatki)
  k.obrisi = tibble()
  for (k in od:do) {
    if (hc) {
      o.k = hclust(razdalje) %>%
        cutree(k) %>%
        silhouette(razdalje)
    } else {
      set.seed(42) # zato, da so rezultati ponovljivi
      o.k = kmeans(podatki, k)$cluster %>%
        silhouette(razdalje)
    }
    k.obrisi = k.obrisi %>% bind_rows(
      tibble(
        k = rep(k, n),
        obrisi = o.k[, "sil_width"]
      )
    )
  }
  k.obrisi$k = as.ordered(k.obrisi$k)
  k.obrisi
}

obrisi.povprecje = function(k.obrisi) {
  k.obrisi.povprecje = k.obrisi %>%
    group_by(k) %>%
    summarize(obrisi = mean(obrisi))
}

obrisi.k = function(k.obrisi) {
  obrisi.povprecje(k.obrisi) %>%
    filter(obrisi == max(obrisi)) %>%
    summarize(k = min(k)) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

diagram.obrisi = function(k.obrisi) {
  ggplot() +
    geom_boxplot(
      data = k.obrisi,
      mapping = aes(x = k, y = obrisi)
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = k, y = obrisi),
      color = "red"
    ) +
    geom_line(
      data = obrisi.povprecje(k.obrisi),
      mapping = aes(x = as.integer(k), y = obrisi),
      color = "red"
    ) +
    geom_point(
      data = obrisi.povprecje(k.obrisi) %>%
        filter(obrisi == max(obrisi)) %>%
        filter(k == min(k)),
      mapping = aes(x = k, y = obrisi),
      color = "blue"
    ) +
    xlab("število skupin (k)") +
    ylab("obrisi (povprečje obrisov)") +
    ggtitle(paste("Maksimalno povprečje obrisov pri k =", obrisi.k(k.obrisi))) +
    theme_classic()
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# funkcije za prečno preverjanje:

ucenje = function(podatki, formula, algoritem) {
  switch(
    algoritem,
    lin.reg = lm(formula, data = podatki),
    log.reg = glm(formula, data = podatki, family = "binomial"),
    ng = ranger(formula, data = podatki)
  )
}

napovedi = function(podatki, model, algoritem) {
  switch(
    algoritem,
    lin.reg = predict(model, podatki),
    log.reg = ifelse(
      predict(model, podatki, type = "response") >= 0.5,
      1, -1
    ),
    ng = predict(model, podatki)$predictions
  )
}

napaka_regresije = function(podatki, model, algoritem) {
  podatki %>%
    bind_cols(yn.hat = napovedi(podatki, model, algoritem)) %>%
    mutate(
      izguba = (yn - yn.hat) ^ 2
    ) %>%
    select(izguba) %>%
    unlist() %>%
    mean()
}

napaka_razvrscanja = function(podatki, model, algoritem) {
  podatki %>%
    bind_cols(yd.hat = napovedi(podatki, model, algoritem)) %>%
    mutate(
      izguba = (yd != yd.hat)
    ) %>%
    select(izguba) %>%
    unlist() %>%
    mean()
}

# Razreži vektor x na k enako velikih kosov
razbitje = function(x, k) {
  # Razreži indekse vektorja na k intervalov
  razrez = cut(seq_along(x), k, labels = FALSE)
  # Razbij vektor na k seznamov
  # na osnovi razreza intervalov
  split(x, razrez)
}

pp.razbitje = function(n, k = 5, stratifikacija = NULL, seme = NULL) {
  # najprej nastavimo seme za naključna števila, če je podano
  if (!is.null(seme)) {
    set.seed(seme)
  }
  # če ne opravljamo stratifikacije, potem vrnemo navadno razbitje
  # funkcijo sample uporabimo zato, da naključno premešamo primere
  if (is.null(stratifikacija)) {
    return(razbitje(sample(1:n), k))
  }
  # če pa opravljamo stratifikacijo, razbitje izvedemo za vsako
  # vrednost spremenljive stratifikacija posebej in nato
  # podmnožice združimo v skupno razbitje
  r = NULL
  for (v in levels(stratifikacija)) {
    # Če smo pri prvi vrednosti vzpostavimo razbitje
    if (is.null(r)) {
      # opravimo razbitje samo za primere z vrednostjo v
      r = razbitje(sample(which(stratifikacija == v)), k)
    } else {
      # opravimo razbitje za vrednost v
      # in podmnožice združimo s trenutnim razbitjem
      r.v = razbitje(sample(which(stratifikacija == v)), k)
      for (i in 1:k) {
        r[[i]] = c(r[[i]], r.v[[i]])
      }
    }
  }
  r
}

precno.preverjanje = function(podatki, razbitje, formula, algoritem, razvrscanje) {
  # pripravimo vektor za napovedi
  if (razvrscanje) {
    pp.napovedi = factor(rep(1, nrow(podatki)), levels = c(-1,1))
  } else {
    pp.napovedi = rep(0, nrow(podatki))
  }
  # gremo čez vse podmnožice Si razbitja S
  for (i in 1:length(razbitje)) {
    # naučimo se modela na množici S \ Si
    model = podatki[ -razbitje[[i]], ] %>% ucenje(formula, algoritem)
    # naučen model uporabimo za napovedi na Si
    pp.napovedi[ razbitje[[i]] ] = podatki[ razbitje[[i]], ] %>% napovedi(model, algoritem)
  }
  if (razvrscanje) {
    mean(pp.napovedi != podatki$pricak)
  } else {
    mean((pp.napovedi - podatki$pricak) ^ 2)
  }
}

# Funkciji Predictor$new moramo povedati kako napovedujemo z modelom naključnih gozdov
pfun = function(model, newdata) {
  predict(model, data = newdata, predict.all = FALSE)$predictions
}

# ==============================================================================
# RAZVRSTITEV V SKUPINE
# ==============================================================================

# 1) k-means

# koliko skupin naj izberem pri razdelitvi z metodo voditeljev:
r.hc = TURIZEM.EVROPA[, -1] %>% obrisi(hc = TRUE)
r.km = TURIZEM.EVROPA[, -1] %>% obrisi(hc = FALSE)

r.hc.plt <- diagram.obrisi(r.hc)
r.km.plt <- diagram.obrisi(r.km)
# oba predlagata dve skupini

# - - - - - - - - -

set.seed(42)

k = 3
skupine <- TURIZEM.EVROPA[,-1] %>%
  kmeans(centers = k) %>%
  getElement("cluster") %>%
  as.ordered()
# print(skupine)

tabela.skupine.k.means <- TURIZEM.EVROPA %>%
  mutate(Skupine = as.numeric(skupine))

# uvozim zemljevid, ki ga bom potrebovala tudi v nadaljevanju. Prikazala se bo samo Evropa
zemljevid <-
  uvozi.zemljevid(
    "http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip",
    "ne_50m_admin_0_countries",
    mapa = "zemljevidi",
    pot.zemljevida = "",
    encoding = "UTF-8"
  ) %>%
  fortify() %>%
  filter(CONTINENT %in% c("Europe"),
         long < 50 & long > -25 & lat > 35 & lat < 85)

names(tabela.skupine.k.means)[1] <- "ADMIN"

zemljevid.kmeans <- ggplot() +
  aes(x = long, y = lat, group = group, fill = factor(Skupine)) +
  geom_polygon(data = tabela.skupine.k.means %>%
                 right_join(zemljevid, by = "ADMIN"),
               color = "grey38", size = 0.2) +
  xlab("") +
  ylab("") +
  ggtitle("Razvrstitev Evropskih držav v tri skupine z metodo k-tih voditeljev") +
  coord_fixed(ratio = 1) +
  guides(fill=guide_legend(title="Skupina")) +
  theme_bw() +
  theme(plot.caption.position = "plot")  +
  scale_fill_brewer(palette = "YlGnBu",
                    na.translate = F,
                    na.value="white")

zemljevid.kmeans

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

set.seed(42)

k = 4
skupine4 <- TURIZEM.EVROPA[,-1] %>%
  kmeans(centers = k) %>%
  getElement("cluster") %>%
  as.ordered()
# print(skupine)

tabela.skupine.k.means4 <- TURIZEM.EVROPA %>%
  mutate(Skupine = as.numeric(skupine4))

# uvozim zemljevid, ki ga bom potrebovala tudi v nadaljevanju. Prikazala se bo samo Evropa
zemljevid <-
  uvozi.zemljevid(
    "http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/50m/cultural/ne_50m_admin_0_countries.zip",
    "ne_50m_admin_0_countries",
    mapa = "zemljevidi",
    pot.zemljevida = "",
    encoding = "UTF-8"
  ) %>%
  fortify() %>%
  filter(CONTINENT %in% c("Europe"),
         long < 50 & long > -25 & lat > 35 & lat < 85)

names(tabela.skupine.k.means4)[1] <- "ADMIN"

zemljevid.kmeans4 <- ggplot() +
  aes(x = long, y = lat, group = group, fill = factor(Skupine)) +
  geom_polygon(data = tabela.skupine.k.means4 %>%
                 right_join(zemljevid, by = "ADMIN"),
               color = "grey38", size = 0.2) +
  xlab("") +
  ylab("") +
  ggtitle("Razvrstitev Evropskih držav v štiri skupine z metodo k-tih voditeljev") +
  coord_fixed(ratio = 1) +
  guides(fill=guide_legend(title="Skupina")) +
  theme_bw() +
  theme(plot.caption.position = "plot")  +
  scale_fill_brewer(palette = "YlGnBu",
                    na.translate = F,
                    na.value="white")

zemljevid.kmeans4

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

# 2) HIERARHIČNO RAZVRŠČANJE

X <- TURIZEM.EVROPA[,-1] %>% as.matrix() %>% scale()
drzave <- TURIZEM.EVROPA[, 1] %>% unlist()
razdalje <- TURIZEM.EVROPA[, -1] %>% dist()
dendrogram  <- dist(X) %>% hclust(method = "ward.D")
# plot(dendrogram,
#      labels = TURIZEM.EVROPA$Drzava,
#      ylab = "višina",
#      main = NULL)

# izračun kolen:
r = hc.kolena(dendrogram)
diagram.kolena(r)

# za kolena predlaga: 2, 3, 4, 6

drzave.x.y <-
  as_tibble(razdalje %>% cmdscale(k = 2)) %>%
  bind_cols(drzave) %>%
  dplyr::select(drzava = ...3, x = V1, y = V2)

# izberem število skupin:
k = 4

skupine <- TURIZEM.EVROPA[, 2] %>%
  dist() %>%
  hclust(method = "ward.D") %>%
  cutree(k = k) %>%
  as.ordered()

tabela.skupine.hierarh <- TURIZEM.EVROPA %>%
  mutate(Skupine = as.numeric(skupine))

names(tabela.skupine.hierarh)[1] <- "ADMIN"

zemljevid.hierarh <- ggplot() +
  aes(x = long, y = lat, group = group, fill = factor(Skupine)) +
  geom_polygon(data = tabela.skupine.hierarh %>%
                 right_join(zemljevid, by = "ADMIN"),
               color = "grey38", size = 0.2) +
  xlab("") +
  ylab("") +
  ggtitle("Razvrstitev Evropskih držav v štiri skupine po Wardovi metodi") +
  coord_fixed(ratio = 1) +
  guides(fill=guide_legend(title="Skupina")) +
  theme_bw() +
  theme(plot.caption.position = "plot") +
  scale_fill_brewer(palette = "YlGnBu",
                    na.translate = F,
                    na.value="white")

zemljevid.hierarh

# v skupini s Slovenijo:
# tabela.skupine.hierarh[tabela.skupine.hierarh$Skupine == 1, 1]

# ==============================================================================
# NAPOVEDNI MODEL
# ==============================================================================

# priprava tabele:
slovenija.turizem <- read_csv("podatki/turizem_svetovno.csv",
                             skip = 4,
                             locale = locale(encoding = "Windows-1250"),
                             col_names=TRUE,
                             col_types = cols(.default = col_guess()))
slovenija.turizem <- slovenija.turizem[slovenija.turizem$`Country Name` == "Slovenia",-c(2:39)]
slovenija.turizem <- slovenija.turizem %>%
  pivot_longer(
    cols = colnames(slovenija.turizem)[-1],
    names_to = "Leto",
    values_to = "Stevilo"
  ) %>%
  na.omit() %>%
  dplyr::select(Leto, "Stevilo")
slovenija.turizem$Stevilo <- as.integer(slovenija.turizem$Stevilo)

# tabela in dva stolpca, prvi so leta, drugi pa število turističnih obiskov

zamakni <- function(x, n){c(rep(NA, n), x)[1:length(x)]}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# IZBIRA napovednega modela (z napako): med linearno regrasijo in naključnimi gozdovi
#   pogledala bom napake obeh modelov
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#     1) glede na pretekla 4 leta:
naredi.df.4 <- function(x){
  data.frame(pricak  = x,
             "Leto 2020"  = zamakni(x, 1),
             "Leto 2019" = zamakni(x, 2),
             "Leto 2018" = zamakni(x, 3),
             "Leto 2017" = zamakni(x, 4))
}

df.4 <- drop_na(naredi.df.4(slovenija.turizem$Stevilo))
ucni.4 = pp.razbitje(nrow(df.4))

#       - naključni gozdovi:
precno.preverjanje(df.4, ucni.4, pricak ~ ., "ng", FALSE)

#       - linearna regrasija:
precno.preverjanje(df.4, ucni.4, pricak ~ ., "lin.reg", FALSE)

# napaka z naključnimi gozdovi je manjša

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#     2) glede na pretekla 3 leta:
naredi.df.3 <- function(x){
  data.frame(pricak  = x,
             "Leto 2020"  = zamakni(x, 1),
             "Leto 2019" = zamakni(x, 2),
             "Leto 2018" = zamakni(x, 3))
}

df.3 <- drop_na(naredi.df.3(slovenija.turizem$Stevilo))
ucni.3 = pp.razbitje(nrow(df.4))

#       - naključni gozdovi:
precno.preverjanje(df.3, ucni.3, pricak ~ ., "ng", FALSE)

#       - linearna regrasija:
precno.preverjanje(df.3, ucni.3, pricak ~ ., "lin.reg", FALSE)

# napaka z naključnimi gozdovi je manjša

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# NAPOVEDOVANJE Z METODO NAKLJUČNIH GOZDOV

# napovedovanje:
zamakni <- function(x, n){c(rep(NA, n), x)[1:length(x)]}

# napovedovanje glede na prejšnja 4 leta:

naredi.df.4 <- function(x){
  data.frame(pricak  = x,
             "Leto 2020"  = zamakni(x, 1),
             "Leto 2019" = zamakni(x, 2),
             "Leto 2018" = zamakni(x, 3),
             "Leto 2017" = zamakni(x, 4))
}

df.4 <- naredi.df.4(slovenija.turizem$Stevilo)
model = ranger(formula = pricak ~ ., data = df.4 %>% drop_na())

n = nrow(df.4)

df.4.2 = df.4
for(i in 1:3){
  df.4.2 = naredi.df.4(c(df.4.2$pricak, NA))
  napoved = predict(model, data = df.4.2[n+i,])$predictions
  df.4.2[n+i, 1] = napoved
}

# napovedi za naslednja 3 leta:
napovedi = df.4.2[(n+1):(n+3),1]

# s temi podaki bom dopolnila tabelo slovenija.turizem
slovenija.turizem.z.napovednjo <- slovenija.turizem
slovenija.turizem.z.napovednjo$Leto <- as.integer(slovenija.turizem.z.napovednjo$Leto)
slovenija.turizem.z.napovednjo$Stevilo <- as.numeric(slovenija.turizem.z.napovednjo$Stevilo)
zadnje_leto <- 2020
for (i in 1:3) {
  novo_leto <- as.integer(zadnje_leto + i)
  nov_podatek <- as.integer(napovedi[i])
  slovenija.turizem.z.napovednjo[nrow(slovenija.turizem.z.napovednjo) + 1, ] <-
    list(novo_leto, nov_podatek)
}

Leto <- 1995:2023
napovedovanje.graf <- ggplot(slovenija.turizem.z.napovednjo,
                             aes(x = Leto, y = Stevilo)) +
  geom_line(color = "black") +
  slovenija.turizem.z.napovednjo %>%
  filter(Leto %in% c(2020:2023)) %>%
  geom_line(
    mapping = aes(x = Leto, y = Stevilo),
    color = "red"
  ) +
  labs(
    x = "Leto",
    y = "Stevilo turističnih obiskov",
    title = "Stevilo turističnih obiskov Slovenija ob leta 1995 do 2020 z napovedjo \nza leta 2021, 2022 in 2023 "
  ) +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5)) +
  scale_x_continuous("Leto", labels = as.character(Leto), breaks = Leto)

napovedovanje.graf # ni vključen v poročilo

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# prečno preverjanje napovedovanja glede na pretekla 4 leta:

# vrednosti NA motijo delovanje funckije

df.4 <- df.4 %>% drop_na()

ucni <- pp.razbitje(df.4, stratifikacija = df.4$pricak)

# Pripravimo le napovedne spremenljivke, ki jih rabi funkcija Predictor$new
X <- df.4[,-1]

# pripravimo najprej objekt razreda Prediktor
# prvi argument funkcije je model,
# drugi in tretji so podatki o napovednih
# in ciljni spremenljivki,
# zadnji pa funkcija za napovedovanje

reg.pred = Predictor$new(
  model,
  data = X, y = df.4$pricak,
  predict.fun = pfun
)

# na koncu uporabimo funkcijo FeatureImp$new
reg.moci = FeatureImp$new(reg.pred, loss = "mse")

reg.moci.4.plot <- plot(reg.moci) + theme_bw()
reg.moci.4.plot

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# napovedovanje glede na prejšnje 3 leta:

naredi.df.3 <- function(x){
  data.frame(pricak  = x,
             "Leto 2020"  = zamakni(x, 1),
             "Leto 2019" = zamakni(x, 2),
             "Leto 2018" = zamakni(x, 3))
}

df.3 <- naredi.df.3(slovenija.turizem$Stevilo)
model.3 = ranger(formula = pricak ~ ., data = df.3 %>% drop_na())

n = nrow(df.3)

df.3.2 = df.3
for(i in 1:3){
  df.3.2 = naredi.df.3(c(df.3.2$pricak, NA))
  napoved = predict(model.3, data = df.3.2[n+i,])$predictions
  df.3.2[n+i, 1] = napoved
}

# napovedi za naslednja 3 leta:
napovedi.3 = df.3.2[(n+1):(n+3),1]

# s temi podaki bom dopolnila tabelo slovenija.turizem
slovenija.turizem.z.napovednjo.3 <- slovenija.turizem
slovenija.turizem.z.napovednjo.3$Leto <- as.integer(slovenija.turizem.z.napovednjo.3$Leto)
slovenija.turizem.z.napovednjo.3$Stevilo <- as.integer(slovenija.turizem.z.napovednjo.3$Stevilo)
zadnje_leto <- 2020
for (i in 1:3) {
  novo_leto <- as.integer(zadnje_leto + i)
  nov_podatek <- as.integer(napovedi.3[i])
  slovenija.turizem.z.napovednjo.3[nrow(slovenija.turizem.z.napovednjo.3) + 1, ] <-
    list(novo_leto, nov_podatek)
}

Leto <- 1995:2023
napovedovanje.graf.3 <- ggplot(slovenija.turizem.z.napovednjo.3,
                             aes(x = Leto, y = Stevilo)) +
  geom_line(color = "black") +
  slovenija.turizem.z.napovednjo.3 %>%
  filter(Leto %in% c(2020:2023)) %>%
  geom_line(
    mapping = aes(x = Leto, y = Stevilo),
    color = "red"
  ) +
  labs(
    x = "Leto",
    y = "Stevilo turističnih obiskov",
    title = "Stevilo turističnih obiskov Slovenija ob leta 1995 do 2020 z napovedjo \nza leta 2021, 2022 in 2023 "
  ) +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5)) +
  scale_x_continuous("Leto", labels = as.character(Leto), breaks = Leto)

napovedovanje.graf.3 # ni vključen v poročilo

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# prečno preverjanje napovedovanja glede na pretekla 3 leta:

# vrednosti NA motijo delovanje funckije
df.3 <- df.3 %>% na.omit()

ucni.3 <- pp.razbitje(df.3, stratifikacija = df.3$pricak)

# Pripravimo le napovedne spremenljivke, ki jih rabi funkcija Predictor$new
X.3 <- df.3[,-1]

# pripravimo najprej objekt razreda Prediktor
# prvi argument funkcije je model,
# drugi in tretji so podatki o napovednih
# in ciljni spremenljivki,
# zadnji pa funkcija za napovedovanje

reg.pred.3 = Predictor$new(
  model.3,
  data = X.3, y = df.3$pricak,
  predict.fun = pfun
)

# na koncu uporabimo funkcijo FeatureImp$new
reg.moci.3 = FeatureImp$new(reg.pred.3, loss = "mse")

reg.moci.3.plot <- plot(reg.moci.3) + theme_bw()
reg.moci.3.plot

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

# skupni graf napovedovanja (za poročilo):
Leto <- 1995:2023
napovedovanje.graf.skupaj <- ggplot(slovenija.turizem.z.napovednjo,
                             aes(x = Leto, y = Stevilo)) +
  geom_line(color = "black") +
  slovenija.turizem.z.napovednjo %>%
  filter(Leto %in% c(2020:2023)) %>%
  geom_line(
    mapping = aes(x = Leto, y = Stevilo),
    color = "goldenrod1",
    size = 0.75
  ) +
  slovenija.turizem.z.napovednjo.3 %>%
  filter(Leto %in% c(2020:2023)) %>%
  geom_line(
    mapping = aes(x = Leto, y = Stevilo),
    color = "red",
    linetype = "dotdash",
    size = 0.75
  ) +
  labs(
    x = "Leto",
    y = "Število turističnih obiskov",
    title = "Število turističnih obiskov Slovenija ob leta 1995 do 2020 z napovedjo \nza leta 2021, 2022 in 2023 "
  ) +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5)) +
  scale_x_continuous("Leto", labels = as.character(Leto), breaks = Leto) +
  annotate(geom="text", x=2022, y=3000000, label="napoved glede \nna pretekla \n4 leta",
           color="goldenrod1", size = 2.5) +
  annotate(geom="text", x=2022.5, y=1900000, label="napoved \nglede na \npretekla \n3 leta",
           color="red", size = 2.5)

napovedovanje.graf.skupaj

# ==============================================================================
# LINEARNA REGRESIJA
# ==============================================================================

linearna.regrasija.graf <-
  ggplot(slovenci.prenocitve, aes(x = Leto, y = Stevilo)) +
  geom_point(stat='identity', position='identity', aes(colour=Stevilo),size=1.3) +
  scale_colour_gradient(low='yellow', high='#de2d26') +
  labs(
    x = "Leto",
    y = "Število prenočitev",
  ) +
  ggtitle("Število prenočitev Slovencev v Sloveniji od leta 2010 do leta 2022") +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5),
        legend.position="none") +
  geom_smooth(method = "lm", formula = y ~ x, colour="black", size=0.7)

linearna.regrasija.graf


# Goal: Associative arrays (as in awk) or hashes (as in perl).
#       Or, more generally, adventures in R addressing.

# Here's a plain R vector:
x <- c(2,3,7,9)
# But now I tag every elem with labels:
names(x) <- c("kal","sho","sad","aja")
# Associative array operations:
x["kal"] <- 12
# Pretty printing the entire associative array:
x

# This works for matrices too:
m <- matrix(runif(10), nrow=5)
rownames(m) <- c("violet","indigo","blue","green","yellow")
colnames(m) <- c("Asia","Africa")
# The full matrix --
m
# Or even better --
library(xtable)
xtable(m)

# Now address symbolically --
m[,"Africa"]
m["indigo",]
m["indigo","Africa"]

# The "in" operator, as in awk --
for (colour in c("yellow", "orange", "red")) {
  if (colour %in% rownames(m)) {
    cat("For Africa and ", colour, " we have ", m[colour, "Africa"], "\n")
  } else {
    cat("Colour ", colour, " does not exist in the hash.\n")
  }
}

# This works for data frames also --
D <- data.frame(m)
D
# Look closely at what happened --
str(D)                                  # The colours are the rownames(D).

# Operations --
D$Africa
D[,"Africa"]
D["yellow",]
# or
subset(D, rownames(D)=="yellow")

colnames(D) <- c("Antarctica","America")
D
D$America

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/b8.r


# https://github.com/mulargui/Kaggle---Walmart-forecast-challenge

#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

library("dplyr")

#load data
dftrain <- read.csv("train.csv", header=TRUE)
dftest <- read.csv("test.csv", header=TRUE)

#Add Seasonality Column based on factor of Date
dftrain[,"Seasonality"] <- (as.numeric(dftrain$Date) %% 52) + 1
dftest[,"Seasonality"] <- ((as.numeric(dftest$Date) + 143) %% 52) + 1

#avearage sales per week per dept
avg_sales <- dftrain %>%
  group_by(Store, Dept, Seasonality) %>%
  summarise(Weekly_Sales = mean(Weekly_Sales))

#predict based on average sales
dfresult <- merge(dftest, avg_sales, by = c("Store","Dept", "Seasonality"), all.x = TRUE)

#for depts with no data use 0
dfresult$Weekly_Sales[is.na(dfresult$Weekly_Sales)] <- 0

#preparing the submission file
#Adding a column with store_department_date
dfresult[,"Id"] <- paste(dfresult$Store, dfresult$Dept, format(as.Date(dfresult$Date), "%Y-%m-%d" ), sep = "_")

#save results in a csv file
write.csv(file = "Solution1.csv", x = subset(dfresult, select = c(Id, Weekly_Sales)), row.names=FALSE)


#!/usr/bin/Rscript

## Author: David Eccles (gringer), 2009 <programming@gringer.org>

## distvals.r -- generates a genotype distance matrix from genotype data

usage <- function(){
  cat("usage: ./distvals.r <file>\n");
}

if(length(commandArgs(TRUE)) < 1){
  cat("Error: No file specified on the command line");
  quit(save="no",status = 1);
}
a <- as.matrix(read.table(commandArgs(TRUE)[1], stringsAsFactors = FALSE,
                          row.names = 1));

a <- gsub(a,pattern = "G", replacement = "C", ignore.case = TRUE);
a <- gsub(a,pattern = "T", replacement = "A", ignore.case = TRUE);
a <- gsub(a,pattern = "CA", replacement = "AC", ignore.case = TRUE);
a <- gsub(a,pattern = "AA", replacement = "0", ignore.case = TRUE);
a <- gsub(a,pattern = "AC", replacement = "1", ignore.case = TRUE);
a <- gsub(a,pattern = "CC", replacement = "2", ignore.case = TRUE);
a <- gsub(a,pattern = "..", replacement = NA);
rnames <- rownames(a);
a <- matrix(as.numeric(a),dim(a)[1],dim(a)[2]);
rownames(a) <- rnames;

z <- dist(a);
write.table(sort(colMeans(as.matrix(dist(a)), na.rm = TRUE),
                 decreasing = TRUE), quote = FALSE, col.names = FALSE);


NA0 = function(A) {B=A;for(i in 1:length(A)) {if(is.na(A[i])) {B[i]=0;} else {B[i]=A[i];}}; return(B)}  #replaces NA by zero in a column

mydata=read.csv("..\\..\\MATRIX\\matrix.csv",header=TRUE,sep=";",dec=",",stringsAsFactors=FALSE); #reads the matrix of Y and X

myResult=NULL;
mydataG=mydata[mydata$Age=="0_100",]; #let us here work at an age-standardized level: age is not a parameter
for( myCancerNum in 8:40) #for each cancer type :40
  {
  mydataGC=mydataG[!is.na(mydataG[,myCancerNum]),]; #consider the lines with Y filled
  assign("lnY", log(as.numeric(mydataGC[,myCancerNum])+10) );
  myFormula="lnY ~ mydataGC$Gender";
  for(myXNum in c(4,7,78:ncol(mydata))) #for each X
     {
     myXName = names(mydata)[myXNum];
     a = as.numeric(mydataGC[,myXNum]); b = !is.na(a);
     assign(myXName, NA0(a));
     if(!anyNA(a)) myFormula=paste(myFormula," + ",myXName, sep=""); #add X if present in all lines
     #if the variable is sufficiently present add it to the regression
     if( anyNA(a) && sum(b) >49 && myXName!="hib_vacc" && myXName!="diphteria_vacc"  && myXName!="tetanus_vacc")
        {
        assign(paste("i_", myXName, sep=""), b);
              myFormula=paste(myFormula," + i_",myXName," + ",myXName, sep="");
              }
    } #X have been added
   # run the formula and append the new results to the existing ones
   cat(myFormula, "\n");
   tryCatch({
          mycoefs=lm( as.formula(myFormula))$coefficients},
       error=function(e){cat("ERROR :",conditionMessage(e), "\n")});
  if(myCancerNum==8) coefstruct=NA0(mycoefs);
  myNewResult = coefstruct; # initialize with 0
  for(k in 1:length(mycoefs)) myNewResult[names(mycoefs)[k]]=mycoefs[k];
  myResult = cbind(myResult, myNewResult);
  } #cancers have been listed
print(myResult);