require(ggplot2)
require(scales)
SL = 32
p = 3

f = function(x,k,l,SL) { 1 - (1 - (1 - x/SL)^k)^l }

K = function(l,p,alpha,L) {round(log(1-(1-alpha)^(1/l))/log(1-p/L));}

K(4,2,0.95,10)

alpha=0.95
ggplot(data.frame(x = c(1, 3*p)), aes(x)) + theme_classic()+
  mapply(function( L) {
    stat_function(fun = f, args = list(k = K(l=L,p=p,alpha=alpha,L=SL), l=L, SL=SL), aes(color=paste(L,K(l=L,p=p,alpha=alpha,L=SL),sep="/")))
  },L=c(7:14))+
  geom_vline(xintercept = p,color="black",linetype=2)+
  geom_hline(yintercept = alpha,color="black",linetype=2)+
  scale_color_brewer(palette = "Spectral",name="l/h")+ylab("probability of a match")+xlab("Hamming distance")+scale_linetype(name="l")
ggsave("clus-95.pdf",width=5,height = 4)

alpha=0.1
ggplot(data.frame(x = c(1, 3*p)), aes(x)) + theme_classic()+
  mapply(function( L) {
    stat_function(fun = f, args = list(k = K(l=L,p=p,alpha=alpha,L=SL), l=L, SL=SL), aes(color=paste(L,K(l=L,p=p,alpha=alpha,L=SL),sep="/")))
  },L=c(2:8))+
  geom_vline(xintercept = p,color="black",linetype=2)+
  geom_hline(yintercept = alpha,color="black",linetype=2)+
  scale_color_brewer(palette = "Spectral",name="l/h")+ylab("probability of a match")+xlab("Hamming distance")+scale_linetype(name="l")
ggsave("clus-10.pdf",width=5,height = 4)

alpha=0.1
ggplot(data.frame(x = c(1, 3*p)), aes(x)) + theme_classic()+
  mapply(function( L) {
    stat_function(fun = function(x,k,l,SL) (150-SL+1)*f(x,k,l,SL), args = list(k = K(l=L,p=p,alpha=alpha,L=SL), l=L, SL=SL), aes(color=paste(L,K(l=L,p=p,alpha=alpha,L=SL),sep="/")))
  },L=c(2:8))+
  geom_vline(xintercept = 4,color="black",linetype=2)+
  geom_hline(yintercept = 3,color="black",linetype=2)+
  scale_color_brewer(palette = "Dark2",name="l/k")+ylab("probability of a match")+xlab("distance")+scale_linetype(name="l")

alpha=0.1
ggplot(data.frame(x = c(1, 16)), aes(x)) + theme_classic()+
  mapply(FUN=function( L, K) {
    stat_function(fun = function(x,k,l,SL) (1+150-SL)*f(x,k,l,SL),
                  args = list(k = K, l=L, SL=SL),
                  aes(color=as.factor(K),linetype=as.factor(L)))
  },L=rep(c(2),each=5), K=c(14))+
  #geom_vline(xintercept = 3,color="black",linetype=2)+
  #geom_vline(xintercept = SL*0.4,color="black",linetype=2)+
  #geom_hline(yintercept = 90,color="black",linetype=2)+
  scale_y_continuous(lim=c(0.1,100))+
  scale_linetype_manual(values=c(1,2,3),name=expression(h))+
  scale_x_continuous(labels=function(x) paste(x,percent(x/SL),sep="\n"))+
  scale_color_manual(name="l",values = c("black","gray80"))+
  ylab("Expected number of kmer matches per 150bp read")+
  xlab("Hamming distance")+
  #stat_function(fun = function(x) (1+150-SL)*f(x,35-7,1,35)/2, color="blue",linetype=1)+
  geom_vline(xintercept = 3,color="red",linetype=3)+
  geom_vline(xintercept = 10,color="red",linetype=3)+
  #theme(legend.position = "none")+
ggsave("exp-def.pdf",width=5,height = 4)


cosineClusterDist <- function(X, w1, w2){

# calcultes cosine cluster distance in the format required by slingshot 1.0.0

library( matrixStats)

    mu1 <- colWeightedMeans(X, w = w1)
    mu2 <- colWeightedMeans(X, w = w2)
    cosDist = sqrt( 2*(1 - sum(mu1*mu2)/sqrt(sum(mu1^2)*sum(mu2^2))))
    return( cosDist)
}


#decision tree
#graph to reperesent choices and results in the form of tree
#the nodes in the graph represet an event or choice and the edges of the graph represent the decision rules or condtions
#e.g : predicting an email is spam or not

library(party)
data = readingSkills
data
plt=ctree(readingSkills$nativeSpeaker~readingSkills$age+readingSkills$shoeSize+readingSkills$score,data)
plot(plt)


# this script depends on data-raw/scripts/rt.r
# Packages ----------------------------------------------------------------
library(EpiNow2)
library(data.table)

# Load samples ------------------------------------------------------------
# load from disk
samples <- get_regional_results(results_dir = here("data-raw", "data", "rt", "samples"),
                                samples = TRUE)$estimates$samples
# filter for infection posteriors
samples <- samples[variable %in% "infections"][,.(county = region, date, sample, value, type)]

# Calculate prevalence ----------------------------------------------------
# order by county and date, then taking a rolling sum of the last 7 days excluding today
setorder(samples, county, date)
samples <- samples[, lag_inc := shift(value, 1, "lag"), by = county]
samples <- samples[, prev := frollsum(lag_inc, n = 6, align = "right"), by = county]

# extract dates of interest
samples <- samples[date == "2020-10-31" | date == "2020-11-07"]
samples <- samples[, .(county, date, sample, prev)]
prev <- dcast(samples, county + sample ~ date, value.var = "prev")

# make ratio
prev <- prev[, prev_ratio := `2020-10-31` / `2020-11-07`]

# Summarise and save prevalence ratio -------------------------------------
# summary measures and credible intervals
prev_summary <- calc_summary_measures(prev[, value := prev_ratio],
                                      summarise_by = "county",
                                      CrIs = seq(0.05, 0.95, 0.05))
# save with other EpiNow2 results
fwrite(prev, here("data-raw", "data", "rt", "prevalence-samples.csv"))
fwrite(prev_summary, here("data-raw", "data", "rt", "prevalence.csv"))


  matrix.form = function( x, type="number" ) {

   # rescale variables .. log transforms and express per km2 before ordinations
    # ...  large magnitude numbers are needed for ordinations

    # form datasets
    # numbers and weights have already been converted to per km2 and with vessel corrections

      k = 1e4         # a large constant number to make xtabs work
      if (type == "number") {
        o = which(is.finite(x$totno))
        m = xtabs( as.numeric(as.integer(totno*k)) ~ as.factor(id) + as.factor(spec), data=x[o,] ) / k
      }
      if (type == "biomass") {
        o = which(is.finite(x$totmass))
        m = xtabs(as.numeric( as.integer(totwgt*k)) ~ as.factor(id) + as.factor(spec), data=x[o,] ) / k
      }

      threshold= min( x$totno[ which(x$totno>0) ], na.rm=T ) / nrow( m )
      finished.j = finished.i = F
      while( !(finished.j & finished.i) ) {
        nr = nrow(m)
        nc = ncol(m)
        rowsm = rowSums(m)
        colsm = colSums(m)
        i = unique( c( which( rowsm/nr <= threshold ), which(rowsm==0 ) ))
        j = unique( c( which( colsm/nc <= threshold ), which(colsm==0 ) ))
        if (length(i) > 0 ) {
          m = m[ -i , ]
        } else {
          finished.i = T
        }
        if (length(j) > 0 ) {
          m = m[ , -j ]
        } else {
          finished.j = T
        }
      }

      n = array(m, dim=dim(m), dimnames(m))

      return(n)
    }


#*****************************************************************************************************
#*****************************************************************************************************
#  Last modified: 4/14/2009
#
#  Author: james robert white, whitej@umd.edu, Center for Bioinformatics and Computational Biology.
#  University of Maryland - College Park, MD 20740
#
#  This software is designed to identify differentially abundant features between two groups
#  Input is a matrix of frequency data. Several thresholding options are available.
#  See documentation for details.
#*****************************************************************************************************
#*****************************************************************************************************

#*****************************************************************************************************
#  detect_differentially_abundant_features:
#  the major function - inputs an R object "jobj" containing a list of feature names and the
#  corresponding frequency matrix, the argument g is the first column of the second group.
#
#  -> set the pflag to be TRUE or FALSE to threshold by p or q values, respectively
#  -> threshold is the significance level to reject hypotheses by.
#  -> B is the number of bootstrapping permutations to use in estimating the null t-stat distribution.
#*****************************************************************************************************
#*****************************************************************************************************
detect_differentially_abundant_features <- function(jobj, g, output, pflag = NULL, threshold = NULL, B = NULL){

#**********************************************************************************
# ************************ INITIALIZE COMMAND-LINE ********************************
# ************************        PARAMETERS       ********************************
#**********************************************************************************
qflag = FALSE;
if (is.null(B)){
  B = 1000;
}
if (is.null(threshold)){
  threshold = 0.05;
}
if (is.null(pflag)){
  pflag = TRUE;
  qflag = FALSE;
}
if (pflag == TRUE){
  qflag = FALSE;
}
if (pflag == FALSE){
  qflag = TRUE;
}

#********************************************************************************
# ************************ INITIALIZE PARAMETERS ********************************
#********************************************************************************

#*************************************
Fmatrix <- jobj$matrix;                   # the feature abundance matrix
taxa <- jobj$taxa;                        # the taxa/(feature) labels of the TAM
nrows = nrow(Fmatrix);
ncols = ncol(Fmatrix);
Pmatrix <- array(0, dim=c(nrows,ncols));  # the relative proportion matrix
C1 <- array(0, dim=c(nrows,3));           # statistic profiles for class1 and class 2
C2 <- array(0, dim=c(nrows,3));           # mean[1], variance[2], standard error[3]
T_statistics <- array(0, dim=c(nrows,1)); # a place to store the true t-statistics
pvalues <- array(0, dim=c(nrows,1));      # place to store pvalues
qvalues <- array(0, dim=c(nrows,1));      # stores qvalues
#*************************************

#*************************************
#  convert to proportions
#  generate Pmatrix
#*************************************
totals <- array(0, dim=c(ncol(Fmatrix)));
for (i in 1:ncol(Fmatrix)) {
  # sum the ith column
  totals[i] = sum(Fmatrix[,i]);
}

for (i in 1:ncols) {   # for each subject
  for (j in 1:nrows) { # for each row
    Pmatrix[j,i] = Fmatrix[j,i]/totals[i];
  }
}

#********************************************************************************
# ************************** STATISTICAL TESTING ********************************
#********************************************************************************

if (ncols == 2){  # then we have a two sample comparison
  #************************************************************
  #  generate p values using chisquared or fisher's exact test
  #************************************************************
  for (i in 1:nrows){           # for each feature
    f11 = sum(Fmatrix[i,1]);
    f12 = sum(Fmatrix[i,2]);
    f21 = totals[1] - f11;
    f22 = totals[2] - f12;
    C1[i,1] = f11/totals[1];                       # proportion estimate
    C1[i,2] = (C1[i,1]*(1-C1[i,1]))/(totals[1]-1); # sample variance
    C1[i,3] = sqrt(C1[i,2]);                       # sample standard error
    C2[i,1] = f12/totals[2];
    C2[i,2] = (C2[i,1]*(1-C2[i,1]))/(totals[2]-1);
    C2[i,3] = sqrt(C2[i,2]);

    #  f11  f12
    #  f21  f22  <- contigency table format
    contingencytable <- array(0, dim=c(2,2));
    contingencytable[1,1] = f11;
    contingencytable[1,2] = f12;
    contingencytable[2,1] = f21;
    contingencytable[2,2] = f22;

    if (f11 > 20 && f22 > 20){
      csqt <- chisq.test(contingencytable);
      pvalues[i] = csqt$p.value;
    }else{
      ft <- fisher.test(contingencytable, workspace = 8e6, alternative = "two.sided", conf.int = FALSE);
      pvalues[i] = ft$p.value;
    }

  }

  #*************************************
  #  calculate q values from p values
  #*************************************
  qvalues <- calc_qvalues(pvalues);

}else{ # we have multiple subjects per population

  #*************************************
  #  generate statistics mean, var, stderr
  #*************************************
  for (i in 1:nrows){ # for each taxa
    # find the mean of each group
    C1[i,1] = mean(Pmatrix[i, 1:g-1]);
    C1[i,2] = var(Pmatrix[i, 1:g-1]); # variance
    C1[i,3] = C1[i,2]/(g-1);    # std err^2 (will change to std err at end)

    C2[i,1] = mean(Pmatrix[i, g:ncols]);
    C2[i,2] = var(Pmatrix[i, g:ncols]);  # variance
    C2[i,3] = C2[i,2]/(ncols-g+1); # std err^2 (will change to std err at end)
  }

  #*************************************
  #  two sample t-statistics
  #*************************************
  for (i in 1:nrows){                   # for each taxa
    xbar_diff = C1[i,1] - C2[i,1];
    denom = sqrt(C1[i,3] + C2[i,3]);
    T_statistics[i] = xbar_diff/denom;  # calculate two sample t-statistic
  }

  #*************************************
  # generate initial permuted p-values
  #*************************************
  pvalues <- permuted_pvalues(Pmatrix, T_statistics, B, g, Fmatrix);

  #*************************************
  #  generate p values for sparse data
  #  using fisher's exact test
  #*************************************
  for (i in 1:nrows){                   # for each taxa
    if (sum(Fmatrix[i,1:(g-1)]) < (g-1) && sum(Fmatrix[i,g:ncols]) < (ncols-g+1)){
      # then this is a candidate for fisher's exact test
      f11 = sum(Fmatrix[i,1:(g-1)]);
      f12 = sum(Fmatrix[i,g:ncols]);
      f21 = sum(totals[1:(g-1)]) - f11;
      f22 = sum(totals[g:ncols]) - f12;
      #  f11  f12
      #  f21  f22  <- contigency table format
      contingencytable <- array(0, dim=c(2,2));
      contingencytable[1,1] = f11;
      contingencytable[1,2] = f12;
      contingencytable[2,1] = f21;
      contingencytable[2,2] = f22;
      ft <- fisher.test(contingencytable, workspace = 8e6, alternative = "two.sided", conf.int = FALSE);
      pvalues[i] = ft$p.value;
    }
  }

  #*************************************
  #  calculate q values from p values
  #*************************************
  qvalues <- calc_qvalues(pvalues);

  #*************************************
  #  convert stderr^2 to std error
  #*************************************
  for (i in 1:nrows){
    C1[i,3] = sqrt(C1[i,3]);
    C2[i,3] = sqrt(C2[i,3]);
  }
}

#*************************************
#  threshold sigvalues and print
#*************************************
sigvalues <- array(0, dim=c(nrows,1));
if (pflag == TRUE){  # which are you thresholding by?
  sigvalues <- pvalues;
}else{
  sigvalues <- qvalues;
}
s = sum(sigvalues <= threshold);
Differential_matrix <- array(0, dim=c(s,9));

dex = 1;
for (i in 1:nrows){
  if (sigvalues[i] <= threshold){
    Differential_matrix[dex,1]   = jobj$taxa[i];
    Differential_matrix[dex,2:4] = C1[i,];
    Differential_matrix[dex,5:7] = C2[i,];
    Differential_matrix[dex,8]   = pvalues[i];
    Differential_matrix[dex,9]   = qvalues[i];
    dex = dex+1;
  }
}

#show(Differential_matrix);

Total_matrix <- array(0, dim=c(nrows,9));
for (i in 1:nrows){
  Total_matrix[i,1]   = jobj$taxa[i];
  Total_matrix[i,2:4] = C1[i,];
  Total_matrix[i,5:7] = C2[i,];
  Total_matrix[i,8]   = pvalues[i];
  Total_matrix[i,9]   = qvalues[i];
}

write(t(Total_matrix), output, ncolumns = 9, sep = "\t");

}

#************************************************************************
# ************************** SUBROUTINES ********************************
#************************************************************************

#*****************************************************************************************************
#  calc two sample two statistics
#  g is the first column in the matrix representing the second condition
#*****************************************************************************************************
calc_twosample_ts <- function(Pmatrix, g, nrows, ncols)
{
C1 <- array(0, dim=c(nrows,3));  # statistic profiles
C2 <- array(0, dim=c(nrows,3));
Ts <- array(0, dim=c(nrows,1));

if (nrows == 1){
  C1[1,1] = mean(Pmatrix[1:g-1]);
  C1[1,2] = var(Pmatrix[1:g-1]); # variance
  C1[1,3] = C1[1,2]/(g-1);    # std err^2

  C2[1,1] = mean(Pmatrix[g:ncols]);
  C2[1,2] = var(Pmatrix[g:ncols]);  # variance
  C2[1,3] = C2[1,2]/(ncols-g+1); # std err^2
}else{
  # generate statistic profiles for both groups
  # mean, var, stderr
  for (i in 1:nrows){ # for each taxa
    # find the mean of each group
    C1[i,1] = mean(Pmatrix[i, 1:g-1]);
    C1[i,2] = var(Pmatrix[i, 1:g-1]); # variance
    C1[i,3] = C1[i,2]/(g-1);    # std err^2

    C2[i,1] = mean(Pmatrix[i, g:ncols]);
    C2[i,2] = var(Pmatrix[i, g:ncols]);  # variance
    C2[i,3] = C2[i,2]/(ncols-g+1); # std err^2
  }
}

# permutation based t-statistics
for (i in 1:nrows){ # for each taxa
  xbar_diff = C1[i,1] - C2[i,1];
  denom = sqrt(C1[i,3] + C2[i,3]);
  Ts[i] = xbar_diff/denom;  # calculate two sample t-statistic
}

return (Ts);

}

#*****************************************************************************************************
#  function to calculate qvalues.
#  takes an unordered set of pvalues corresponding the rows of the matrix
#*****************************************************************************************************
calc_qvalues <- function(pvalues)
{
nrows = length(pvalues);

# create lambda vector
lambdas <- seq(0,0.95,0.01);
pi0_hat <- array(0, dim=c(length(lambdas)));

# calculate pi0_hat
for (l in 1:length(lambdas)){ # for each lambda value
  count = 0;
  for (i in 1:nrows){ # for each p-value in order
    if (pvalues[i] > lambdas[l]){
	  count = count + 1;
    }
    pi0_hat[l] = count/(nrows*(1-lambdas[l]));
  }
}

f <- unclass(smooth.spline(lambdas,pi0_hat,df=3));
f_spline <- f$y;
pi0 = f_spline[length(lambdas)];   # this is the essential pi0_hat value

# order p-values
ordered_ps <- order(pvalues);
pvalues <- pvalues;
qvalues <- array(0, dim=c(nrows));
ordered_qs <- array(0, dim=c(nrows));

ordered_qs[nrows] <- min(pvalues[ordered_ps[nrows]]*pi0, 1);
for(i in (nrows-1):1) {
  p = pvalues[ordered_ps[i]];
  new = p*nrows*pi0/i;

  ordered_qs[i] <- min(new,ordered_qs[i+1],1);
}

# re-distribute calculated qvalues to appropriate rows
for (i in 1:nrows){
  qvalues[ordered_ps[i]] = ordered_qs[i];
}

################################
# plotting pi_hat vs. lambda
################################
# plot(lambdas,pi0_hat,xlab=expression(lambda),ylab=expression(hat(pi)[0](lambda)),type="p");
# lines(f);

return (qvalues);
}

#*****************************************************************************************************
#  function to calculate permuted pvalues from Storey and Tibshirani(2003)
#  B is the number of permutation cycles
#  g is the first column in the matrix of the second condition
#*****************************************************************************************************
permuted_pvalues <- function(Imatrix, tstats, B, g, Fmatrix)
{
# B is the number of permutations were going to use!
# g is the first column of the second sample
# matrix stores tstats for each taxa(row) for each permuted trial(column)

M = nrow(Imatrix);
ps <- array(0, dim=c(M)); # to store the pvalues
if (is.null(M) || M == 0){
  return (ps);
}
permuted_ttests <- array(0, dim=c(M, B));
ncols = ncol(Fmatrix);
# calculate null version of tstats using B permutations.
for (j in 1:B){
  trial_ts <- permute_and_calc_ts(Imatrix, sample(1:ncol(Imatrix)), g);
  permuted_ttests[,j] <- abs(trial_ts);
}

# calculate each pvalue using the null ts
if ((g-1) < 8 || (ncols-g+1) < 8){
  # then pool the t's together!
  # count how many high freq taxa there are
  hfc = 0;
  for (i in 1:M){                   # for each taxa
    if (sum(Fmatrix[i,1:(g-1)]) >= (g-1) || sum(Fmatrix[i,g:ncols]) >= (ncols-g+1)){
      hfc = hfc + 1;
    }
  }
  # the array pooling just the frequently observed ts
  cleanedpermuted_ttests <- array(0, dim=c(hfc,B));
  hfc = 1;
  for (i in 1:M){
    if (sum(Fmatrix[i,1:(g-1)]) >= (g-1) || sum(Fmatrix[i,g:ncols]) >= (ncols-g+1)){
      cleanedpermuted_ttests[hfc,] = permuted_ttests[i,];
      hfc = hfc + 1;
    }
  }
  #now for each taxa
  for (i in 1:M){
    ps[i] = (1/(B*hfc))*sum(cleanedpermuted_ttests > abs(tstats[i]));
  }
}else{
  for (i in 1:M){
    ps[i] = (1/(B+1))*(sum(permuted_ttests[i,] > abs(tstats[i]))+1);
  }
}

return (ps);
}

#*****************************************************************************************************
# takes a matrix, a permutation vector, and a group division g.
# returns a set of ts based on the permutation.
#*****************************************************************************************************
permute_and_calc_ts <- function(Imatrix, y, g)
{
nr = nrow(Imatrix);
nc = ncol(Imatrix);
# first permute the rows in the matrix
Pmatrix <- Imatrix[,y[1:length(y)]];
Ts <- calc_twosample_ts(Pmatrix, g, nr, nc);

return (Ts);
}

#*****************************************************************************************************
#  load up the frequency matrix from a file
#*****************************************************************************************************
load_frequency_matrix <- function(file)
{
  dat2 <- read.table(file,header=FALSE,sep="\t");
  # load names
  subjects <- array(0,dim=c(ncol(dat2)-1));
  for(i in 1:length(subjects)) {
    subjects[i] <- as.character(dat2[1,i+1]);
  }
  # load taxa
  taxa <- array(0,dim=c(nrow(dat2)-1));
  for(i in 1:length(taxa)) {
    taxa[i] <- as.character(dat2[i+1,1]);
  }

  dat2 <- read.table(file,header=TRUE,sep="\t");
  # load remaining counts
  matrix <- array(0, dim=c(length(taxa),length(subjects)));
  for(i in 1:length(taxa)){
    for(j in 1:length(subjects)){
      matrix[i,j] <- as.numeric(dat2[i,j+1]);
    }
  }

  jobj <- list(matrix=matrix, taxa=taxa)

  return(jobj);
}


#==============================================================================
#	Test for randomForest
#==============================================================================

source("tests.r")

test.data <- list(
	call = list(
		substitute(randomForest(Sepal.Length ~ ., data = iris)),
		substitute(randomForest(Species ~ ., data = iris))
	),
	formula = list(
		Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width + Species,
		Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
	),
	model.type = list("regression", "classification")
)

test.model.adapter("randomForest", iris, test.data)

rm(test.data)


library(sandwich)
library(sjPlot)
library(lmtest)
library(rstanarm)
options(mc.cores = parallel::detectCores())
source("ob_util.R")
source("formulas.r")

df <- load_ts_ds()

set.seed(123)

df <- prepare.df(df)
wiki.stats <- prepare.wikistats(df)

## drop 3 wikis that don't have any ns4 edits
wiki.stats <- wiki.stats[ns4.edits != 0]
df <- df[wiki.db %in% wiki.stats$wiki.db]

# the dv for model1 is ttr
## scale everything
## view count and active editors are super correlated with reverts

# 48 hours for non-reverted as a hueristic for "reverted_for_damage"

# add edits by bots to the treatment model

## scale the numeric variables
to.scale  <- which(sapply(wiki.stats,function(s) is.numeric(s)))
wiki.stats <- wiki.stats[,(to.scale) := lapply(.SD, scale), .SDcols=names(to.scale)]

treated.model.1 <- stan_glm(treatment.formula, family=binomial(link='logit'), data=as.data.frame(wiki.stats), na.action = na.fail)

wiki.stats[,treated.odds:=exp(predict(treated.model.1,wiki.stats))]
wiki.stats[,treated.probs:=treated.odds / (1 + treated.odds)]
wiki.stats[treated==T,ip.weight:= 1/ treated.probs]
wiki.stats[treated==F,ip.weight:= 1/ (1-treated.probs)]

## huston we have a problem with perfect seperation so we want to use the firth-penalized liklihood instead

# add the IP-weights to the df
df <- merge(df,wiki.stats,by=c("wiki.db"),how='left outer',suffixes=c('','.y'))

# let's check if excluding the wikis with the fewest reverts changes things
# df = df[N_reverts >= median(N_reverts)]

#for this test we'll use random cutoffs for each wiki

# we have clustered errors
# H1 geom_mean_ttr
# DID only

mod1_file <- "mod1_did_stanmod.RDS"
if(! file.exists(mod1_file)){
    mod1.did <- stan_glmer(m1.formula.stan,as.data.frame(df),family=gaussian(),QR=T,refresh=50)
    saveRDS(mod1.did, mod1_file)
}

# with IP weights
mod1.ip <- stan_glmer(m1.formula.stan, as.data.frame(df), family=gaussian(), QR=T, weights = df$ip.weight, refresh=50)
saveRDS(mod1.ip,"mod1_ip_stanmod.RDS")

coeftest(mod1.ip,vcov.ip)

# doubly robust
# we don't need sandwhich estimators when we have random effects
mod1.dr <- stan_glmer(m1.formula.dr.stan, as.data.frame(df), family=gaussian(), QR=T, weights=df$ip.weight, refresh=50)
saveRDS(mod1.dr,"mod1_dr_stanmod.RDS")
coeftest(mod1.dr,vcov.dr)

summary(mod1_ip)

summary(mod1_dr)

# H1a number of reverts
# DID only

mod2.did <- stan_glmer.nb(m2.formula.stan, as.data.frame(df), QR=T, refresh.50)

saveRDS(object=mod2.did,file = "ores_bias_data/mod2_did.RDS")

coeftest(mod2.did,vcov.dr)

mod2.ip <- stan_glmer.nb(m2.formula.stan, as.data.fram(df), QR=T, weights=df$ip.weight, refresh=50)
saveRDS(object=mod2.ip,file = "ores_bias_data/mod2_ip.RDS")

coeftest(mod2.ip,vcov.ip)

# doubly robust
mod2.dr <- stan_glmer.nb(m2.formula.dr.stan, as.data.frame(df), weights = df$ip.weight, QR=T, refresh=50)
saveRDS(object=mod2.dr,file = "ores.bias.data/mod2.dr.RDS")

# DID only
# df2 <- df[user.week.revert.cv != 0]

mod3.did <- stan_glm(m3.formula.stan,as.data.frame(df), family=gaussian(link='log'), QR=T, refresh=50)

saveRDS(object=mod3.did,file = "ores.bias.data/mod2.did.RDS")

coeftest(mod3.did,vcov.did)

# IP weights
mod3.ip <- stan_glm(m3.formula.stan, as.data.frame(df), weights = df2$ip.weight, family=gaussian(link='log'), QR=T,refresh=50)

saveRDS(object=mod3.ip,file = "ores.bias.data/mod2.ip.RDS")
coeftest(mod3.ip,vcov.did)

# doubly robust
mod3.dr <- stan_glm(formula=m3.formula.dr.stan, as.data.frame(df), weights = df2$ip.weight, family=gaussian(link='log'), QR=T, refresh=50)

saveRDS(object=mod3.dr,file = "ores.bias.data/mod2.dr.RDS")


library(oro.nifti)
library(fslr)
library(fdrtool)

results_folder_name <- 'RES_survival_stats_20200403_2134'
p_values_file_name <- 'p_values_corrected.nii.gz'
q_values_file_name <- 'q_values'

p_values_img <- readNIfTI( paste(results_folder_name, p_values_file_name, sep='/') )
img_dim <- p_values_img@dim
p_values <- p_values_img[p_values_img>0]

#fdr.estimate.eta0(p_values, method="smoother")
fdr <- fdrtool(p_values, statistic="pvalue")

q_values_array <- array(0, img_dim)
q_values_array[p_values_img>0] <- fdr$qval
q_values_img <- niftiarr(p_values_img, q_values_array)
writeNIfTI(q_values_img, filename=paste(results_folder_name, q_values_file_name, sep='/'))


#' @title
#' Select ranks with cross validation
#'
#' @description
#' This function selects the optimal ranks \code{(r, rx, ry)} using a cross
#' validation procedure. The blockwise coordinate descent algorithm is used to fit
#' the model with any combinations of \code{(r, rx, ry)}.
#'
#' @usage
#' NRRR.cv(Y, X, nfold = 10, norder = NULL, Ag0 = NULL, Bg0 = NULL,
#'         jx, jy, p, d, n, maxiter = 300, conv = 1e-4,
#'         method = c('RRR','RRS')[1], lambda=0,
#'         dimred = c(TRUE,TRUE,TRUE), rankfix = NULL, xrankfix = NULL,
#'         yrankfix = NULL, lang=c('R','Rcpp')[1])
#'
#' @param Y response matrix of dimension n-by-jy*d.
#' @param X design matrix of dimension n-by-jx*p.
#' @param nfold the number of folds used in cross validation. Default is 10.
#' @param norder a vector of length n that assigns samples to multiple folds for cross validation.
#' @param Ag0 an initial estimator of matrix U. If \code{Ag0 = NULL} then generate it
#'            by \code{\link{NRRR.ini}}. Default is NULL. If \code{lang = 'Rcpp'},
#'            then \code{Ag0} is automatically generated by \code{\link{NRRR.ini}}.
#' @param Bg0 an initial estimator of matrix V, if \code{Bg0 = NULL} then generate it
#'            by \code{\link{NRRR.ini}}. Default is NULL. If \code{lang = 'Rcpp'},
#'            then \code{Bg0} is automatically generated by \code{\link{NRRR.ini}}.
#' @param jx number of basis functions to expand the functional predictor.
#' @param jy number of basis functions to expand the functional response.
#' @param p number of predictors.
#' @param d number of responses.
#' @param n sample size.
#' @param maxiter the maximum iteration number of the
#'                blockwise coordinate descent algorithm. Default is 300.
#' @param conv the tolerance level used to control the convergence of the
#'             blockwise coordinate descent algorithm. Default is 1e-4.
# @param quietly a logical value with two options. FALSE (default): show the
#                rank selection process; TRUE: do not show the process.
#' @param method 'RRR' (default): no additional ridge penalty; 'RRS': add an
#'               additional ridge penalty.
#' @param lambda the tuning parameter to control the amount of ridge
#'               penalization. It is only used when \code{method = 'RRS'}.
#'               Default is 0.
# @param ic the user-specified information criterion. Four options are available,
#           including BIC, BICP, AIC, GCV.
#' @param dimred a vector of logical values to decide whether to use cross validation
#'               do rank selection on certain dimensions. TRUE means the rank is selected
#'               by cross validation.
#'               If \code{dimred[1] = FALSE}, r is provided by \code{rankfix}
#'               or \eqn{min(jy*d, rank(X))};
#'               If \code{dimred[2] = FALSE}, rx equals to \code{xrankfix} or p; If \code{dimred[3] = FALSE},
#'               ry equals to \code{yrankfix} or d. Default is \code{c(TRUE, TRUE, TRUE)}.
#' @param rankfix a user-provided value of r when \code{dimred[1] = FALSE}. Default is NULL
#'                which leads to \eqn{r = min(jy*d, rank(X))}.
#' @param xrankfix a user-provided value of rx when \code{dimred[2] = FALSE}. Default is NULL
#'                 which leads to \code{rx = p}.
#' @param yrankfix a user-provided value of ry when \code{dimred[3] = FALSE}. Default is NULL
#'                 which leads to \code{ry = d}.
#' @param lang 'R' (default): the R version function is used; 'Rcpp': the Rcpp
#'             version function is used.
#'
#'
#' @return The function returns a list:
#'   \item{Ag}{the estimated U.}
#'   \item{Bg}{the estimated V.}
#'   \item{Al}{the estimated A.}
#'   \item{Bl}{the estimated B.}
#'   \item{C}{the estimated coefficient matrix C.}
#'   \item{df}{the estimated degrees of freedom of the selected model.}
#'   \item{sse}{the sum of squared errors of the selected model.}
#'   \item{ic}{a vector containing values of BIC, BICP, AIC, GCV of the selected model.}
#'   \item{rx_path}{a matrix displays the path of selecting rx with cross validation.}
#'   \item{ry_path}{a matrix displays the path of selecting ry with cross validation.}
#'   \item{r_path}{a matrix displays the path of selecting r with cross validation.}
#   \item{r_fitseq}{a sequence of possible r values.}
#   \item{iter}{the number of iterations needed to converge in the selected model.}
#'   \item{rank}{the estimated r.}
#'   \item{rx}{the estimated rx.}
#'   \item{ry}{the estimated ry.}
#'
#' @details
#' A three-dimensional grid search procedure of the rank
#' values is performed, and the best model is chosen as the one with the
#' smallest prediction error. Instead of a nested rank selection method, we apply a
#' one-at-a-time selection approach. We first set \eqn{rx = p, ry = d}, and
#' select the best local rank \eqn{\hat r} among the models with
#' \eqn{1 \le r \le min(rank(X), jy*d)}. We then fix the local rank at
#' \eqn{\hat r} and repeat a similar procedure to determine \eqn{\hat rx}
#' and \eqn{\hat ry}, one at a time. Finally, with fixed \eqn{\hat rx} and \eqn{\hat ry},
#' we refine the estimation of r.
#'
#' @references Liu, X., Ma, S., & Chen, K. (2020).
#' Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
#'
# @importFrom rrpack cv.rrr
#' @export
#' @examples
#' library(NRRR)
#' set.seed(1)
#' # Simulation setting 1 in NRRR paper
#' simDat <- NRRR.sim(n = 100, ns = 60, nt = 60, r = 5, rx = 3, ry = 3,
#'                    jx = 8, jy = 8, p = 10, d = 10, s2n = 1,
#'                    rho_X = 0.5, rho_E = 0, Sigma = "CorrAR")
#' # using R function
#' fit_R <- with(simDat, NRRR.cv(Yest, Xest, nfold = 10, norder = NULL,
#'               Ag0 = NULL, Bg0 = NULL, jx = 8, jy = 8, p = 10, d = 10,
#'               n = 100, maxiter = 300, conv = 1e-4,
#'               method = c("RRR", "RRS")[1], lambda = 0,
#'               dimred = c(TRUE, TRUE, TRUE), rankfix = NULL,
#'               xrankfix = NULL, yrankfix = NULL, lang=c('R','Rcpp')[1]))
#' # using Rcpp function
#' fit_Rcpp <- with(simDat, NRRR.cv(Yest, Xest, nfold = 10, norder = NULL,
#'                  Ag0 = NULL, Bg0 = NULL, jx = 8, jy = 8, p = 10,
#'                  d = 10, n = 100, maxiter = 300, conv = 1e-4,
#'                  method = c("RRR", "RRS")[1], lambda = 0,
#'                  dimred = c(TRUE, TRUE, TRUE), rankfix = NULL,
#'                  xrankfix = NULL, yrankfix = NULL, lang=c('R','Rcpp')[2]))
NRRR.cv <- function(Y,X,nfold=10,norder=NULL,Ag0=NULL,Bg0=NULL,jx,jy,p,d,n,
                              maxiter=300,conv=1e-4,#quietly=FALSE,
                              method=c('RRR','RRS')[1],lambda=0,
                              dimred = c(TRUE,TRUE,TRUE),
                              rankfix=NULL,xrankfix=NULL,
                              yrankfix=NULL, lang=c('R','Rcpp')[1]
){
  #require(rrpack)
  if (method == "RRS" & lambda == 0) stop("A positive tuning parameter should be provided when 'RRS' is used.")
  if (!(lang %in% c('R','Rcpp'))) stop("Please choose from 'R' and 'Rcpp'")

  xr <- sum(svd(X)$d>1e-2)
  if (is.null(norder))
    norder <- sample(seq_len(n),n)

  # initialize r
  if(dimred[1]){
    fitRRR <- cv.rrr(Y,X,nfold=10,norder = norder)
    rest <- fitRRR$rank
    # If zero fit
    if(rest==0){
      fitRRR <- RRR(Y,X,nrank=1)
      rest <- fitRRR$rank
    }
    # if(!quietly) {
    #   cat("Initial r   = ",rest, "\n",sep="")
    # }
  }else{
    rest <- ifelse(is.null(rankfix),min(ncol(Y),ncol(X),xr),rankfix)
  }
  rfit <- rest

 if (lang == 'R') {
   # Select rx by cross validation
   rx_path <- matrix(ncol = nfold, nrow = p, NA)
   if (p == 1) {
     rxest <- p
   } else {
     if(dimred[2]){
       ndel <- round(n/nfold)
       for (f in seq_len(nfold)){
         if (f != nfold) {
           iddel <- norder[(1 + ndel * (f - 1)):(ndel * f)]
         }
         else {
           iddel <- norder[(1 + ndel * (f - 1)):n]
         }
         ndel <- length(iddel)
         nf <- n - ndel
         idkeep <- (seq_len(n))[-iddel]
         Xf <- X[-iddel, ]
         Xfdel <- X[iddel, ]
         Yf <- Y[-iddel, ]
         Yfdel <- Y[iddel, ]
         for (i in seq_len(p)){
           rxfit <- i
           ryfit <- d
           fit1 <- NRRR.est(Yf,Xf,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,p,
                            d,n=nf,maxiter=maxiter,conv=conv,#quietly=TRUE,
                            method=method,lambda=lambda)
           rx_path[i,f] <- sum((Yfdel-Xfdel%*%fit1$C)^2)
         }
       }
       index <- order(colSums(rx_path))
       crerr <- rowSums(rx_path[, index])/length(index) * nfold
       rxest <- which.min(crerr)
     } else {
       rxest <- ifelse(is.null(xrankfix),p,xrankfix)
     }
   }

   # if(!quietly) {
   #   cat("Selected rx = ",rxest, "\n",sep="")
   # }

   # Select ry by cross validation
   ry_path <- matrix(ncol = nfold, nrow = d, NA)
   if (d == 1) {
     ryest <- d
   } else {
     if(dimred[3]){
       ndel <- round(n/nfold)
       for (f in seq_len(nfold)){
         if (f != nfold) {
           iddel <- norder[(1 + ndel * (f - 1)):(ndel * f)]
         }
         else {
           iddel <- norder[(1 + ndel * (f - 1)):n]
         }
         ndel <- length(iddel)
         nf <- n - ndel
         idkeep <- (seq_len(n))[-iddel]
         Xf <- X[-iddel, ]
         Xfdel <- X[iddel, ]
         Yf <- Y[-iddel, ]
         Yfdel <- Y[iddel, ]
         for (i in seq_len(d)){
           rxfit <- rxest
           ryfit <- i
           fit1 <- NRRR.est(Yf,Xf,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,p,
                            d,n=nf,maxiter=maxiter,conv=conv,#quietly=TRUE,
                            method=method,lambda=lambda)
           ry_path[i,f] <- sum((Yfdel-Xfdel%*%fit1$C)^2)
         }
       }
       index <- order(colSums(ry_path))
       crerr <- rowSums(ry_path[, index])/length(index) * nfold
       ryest <- which.min(crerr)
     } else {
       ryest <- ifelse(is.null(yrankfix),d,yrankfix)
     }
   }

   # if(!quietly) {
   #   cat("Selected ry = ",ryest, "\n",sep="")
   # }

   # refine rank selection by cross validation
   rfitseq <- max(1,rest-5):min(rest+5,min(n,p*jx,d*jy))
   r_path <- matrix(ncol = nfold, nrow = length(rfitseq), NA)
   if(dimred[1]){
     rxfit <- rxest
     ryfit <- ryest

     ndel <- round(n/nfold)
     for (f in seq_len(nfold)){
       if (f != nfold) {
         iddel <- norder[(1 + ndel * (f - 1)):(ndel * f)]
       }
       else {
         iddel <- norder[(1 + ndel * (f - 1)):n]
       }
       ndel <- length(iddel)
       nf <- n - ndel
       idkeep <- (seq_len(n))[-iddel]
       Xf <- X[-iddel, ]
       Xfdel <- X[iddel, ]
       Yf <- Y[-iddel, ]
       Yfdel <- Y[iddel, ]
       for (i in 1:length(rfitseq)){
         rfit <- rfitseq[i]
         fit1 <- NRRR.est(Yf,Xf,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,p,
                          d,n=nf,maxiter=maxiter,conv=conv,#quietly=TRUE,
                          method=method,lambda=lambda)
         r_path[i,f] <- sum((Yfdel-Xfdel%*%fit1$C)^2)
       }
     }
     index <- order(colSums(r_path))
     crerr <- rowSums(r_path[, index])/length(index) * nfold
     rest <- rfitseq[which.min(crerr)]
     fit <- NRRR.est(Y,X,NULL,NULL,rini=rest,rest,rxfit,ryfit,jx,jy,p,
                     d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                     method=method,lambda=lambda)

   } else {
     rxfit <- rxest
     ryfit <- ryest
     fit <- NRRR.est(Y,X,NULL,NULL,rini=rest,rest,rxfit,ryfit,jx,jy,
                     p,d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                     method=method,lambda=lambda)

   }
   if (fit$iter == maxiter) stop("The algorithm reaches the maximum iteration.")

   return(list(Ag=fit$Ag,Bg=fit$Bg,Al=fit$Al,Bl=fit$Bl,C=fit$C,df=fit$df,
               sse=fit$sse,ic=fit$ic,#obj=fit$obj,
               rx_path=rx_path,ry_path=ry_path,
               r_path=r_path,#rfitseq=rfitseq,
               #iter=fit$iter,
               rank=rest,rx=rxest,ry=ryest))
 } else {
   method <- ifelse(method == 'RRR', 1, 2)

   dimred1 <- ifelse(dimred[1],1,0)
   dimred2 <- ifelse(dimred[2],1,0)
   dimred3 <- ifelse(dimred[3],1,0)

   xrankfix <- ifelse(is.null(xrankfix),0,xrankfix)
   yrankfix <- ifelse(is.null(yrankfix),0,yrankfix)

   norder <- norder - 1

   fit <- nrrr_cv_my(Y, X, norder, nfold, xr, rfit, xrankfix, yrankfix,
                     jx, jy, p, d, n, maxiter, method,
                     dimred1, dimred2, dimred3, conv, lambda)
   if( sum(fit$rxErrmat)>0 | sum(fit$ryErrmat)>0 | sum(fit$rErrmat)>0 ) stop('Error occurs or the algorithm reaches the maximum iteration')

   return(list(Ag=fit$Ag,Bg=fit$Bg,Al=fit$Al,Bl=fit$Bl,C=fit$C,df=fit$df,
               sse=fit$sse,ic=fit$ic,#obj=fit$obj,
               rx_path=fit$rx_path,ry_path=fit$ry_path,
               r_path=fit$r_path,
               rank=fit$rank,rx=fit$rx,ry=fit$ry
               #,rxErrmat=fit$rxErrmat,ryErrmat=fit$ryErrmat,rErrmat=fit$rErrmat
               ))
 }
}


# Simon attempt to add DEM data to DairyBase file using raster
# Note: raster package can work with data on disk (doesn't need to be in memory)

rm(list=ls()) # remove all variables

library(tidyverse)
library(cowplot) # applies to all plots
library(sf)
library(sp)
library(scales)
library(raster) # see http://neondataskills.org/R/Raster-Data-In-R/
library(elevatr) # access DEM data

# define coordinate systems
nztm2000string <- "+proj=tmerc +lat_0=0 +lon_0=173 +k=0.9996 +x_0=1600000 +y_0=10000000 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
wgs84string <- "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"

# ggplot coastline
# nz <- map_data("nz")

#### read dairybase data ####
file_name <- "DairyBaseForPowerBIsoils.csv"
data <- read_csv(file_name, na=c("","NaN","NA"), col_types=cols(Concatbest="c")) %>% # force "Concatbest" to chr
  mutate(slope=NA, aspect=NA, flowdir=NA, tpi=NA)
farms <- data %>% # get farm coordinates
  dplyr::select(DBID, long, lat) %>%
  distinct(DBID, .keep_all=TRUE) %>%
  arrange(DBID)
res <- 0.5 # group locations onto a grid of this resolution
minlong <- min(farms$long)
maxx <- max(floor((farms$long-minlong)/res))
minlat <- min(farms$lat)
maxy <- max(floor((farms$lat-minlat)/res))
farms <- farms %>%
  mutate(grid=floor((long-minlong)/res) + floor((lat-minlat)/res)*(maxx+1))
grids <- farms %>% # grid density
  group_by(grid) %>%
  summarise(count=n()) %>%
  arrange(desc(count))

# plot farms
farms_sf <- st_as_sf(farms, coords=c("long", "lat"), remove=FALSE, crs=wgs84string) # create sf dataframe
ggplot() + # check
  labs(title="Farms") +
  coord_sf() + # ensures consistent projection
  geom_sf(data=farms_sf, mapping=aes(colour=as.factor(grid)), size=0.1) # size < 1 doesn't work

# choose grid
agrid <- grids$grid[1]
print(paste('Not found =', sum(is.na(data$slope)))) # report progress
for (agrid in grids$grid){

# create SpatialPointsDataFrame
farms_sp <- as(filter(farms_sf, grid==agrid), "Spatial")
print(paste("Grid No.", agrid, " Farms =", nrow(farms_sp)))

# farms_sp <- SpatialPointsDataFrame(coords=cbind(farms$long, farms$lat),
#                                    data=data.frame(DBID=farms$DBID, grid=farms$grid),
#                                    proj4string=CRS(wgs84string))

# choose some farms and then get the relevant DEM data from Amazon
# https://cran.r-project.org/web/packages/elevatr/vignettes/introduction_to_elevatr.html
# https://mapzen.com/documentation/terrain-tiles/data-sources/#what-is-the-ground-resolution
dem <- get_elev_raster(farms_sp, z=10, src="aws", expand=res/10) # about 100 m resolution
plot(dem, main=paste("Elevation, Grid", agrid))
points(farms_sp)

# raster package for handling grided data
# aster_dem <- "dem\\ASTGTM2_S38E175\\ASTGTM2_S38E175_dem.tif" # Hamilton-Hauraki Area, 25Mb (WGS84 longlat)
# DEM <- raster(aster_dem)
# projection(DEM) # it's in wgs84 (longlat)
# plot(DEM, main="Hamilton-Hauraki DEM")

slope <- terrain(dem, opt="slope", unit="degrees") # can handle long-lat-metres
aspect <- terrain(dem, opt="aspect", unit="degrees") # can handle long-lat-metres
flowdir <- terrain(dem, opt="flowdir", unit="degrees") # can handle long-lat-metres
tpi <- terrain(dem, opt="TPI", unit="degrees") # can handle long-lat-metres

# extract data
farms_sp$slope  <- raster::extract(slope, farms_sp)
farms_sp$aspect <- raster::extract(aspect, farms_sp)
farms_sp$flowdir <- raster::extract(flowdir, farms_sp)
farms_sp$tpi <- raster::extract(tpi, farms_sp)

# write to data frame
i <- match(data$DBID, farms_sp$DBID)
data$slope <- ifelse(is.na(i), data$slope, farms_sp$slope[i])
data$aspect <- ifelse(is.na(i), data$aspect, farms_sp$aspect[i])
data$flowdir <- ifelse(is.na(i), data$flowdir, farms_sp$flowdir[i])
data$tpi <- ifelse(is.na(i), data$tpi, farms_sp$tpi[i])

print(paste('Not found =', sum(is.na(data$slope)))) # report progress

}

p <- ggplot() + # results
  labs(title="Slope") +
  scale_colour_distiller(palette="Spectral", direction=-1) +
  coord_fixed() +
  geom_point(data=data, mapping=aes(x=long, y=lat, colour=slope))
print(p)

file_name <- "DairyBaseForPowerBIdem.csv"
write_csv(data, file_name)


# 5. Write a function which takes in N (the number of users) and s_N (the state
#    probability for the last user in the chain) and returns the maximum likelihood estimate
#    of s_0 (rounded to 2 decimal places).

estimate_s_0 <- function(N, s_N){

  return(s_0_mle)

}


# Data Wrangling in R
# Social Security Disability Case Study

# Load the tidyverse
library(tidyverse)
library(lubridate)
library(stringr)

# Read in the coal dataset
ssa <- read_csv("http://594442.youcanlearnit.net/ssadisability.csv")

# Take a look at how this was imported
glimpse(ssa)

# Make the dataset long
ssa_long <- gather(ssa, month, applications, -Fiscal_Year)

# And what do we get?
print(ssa_long, n=20)

# Split the month and application type
ssa_long <- separate(ssa_long, month, c("month", "application_method"), sep="_")

# What does that look like?
print(ssa_long, n=20)

# What values do we have for months?
unique(ssa_long$month)

# Convert month to standard abbreviations
ssa_long$month <- substr(ssa_long$month,1,3)

# What values do we now have for months and years?
unique(ssa_long$month)
unique(ssa_long$Fiscal_Year)

# Convert Fiscal_Year from alphanumeric strings to actual years
ssa_long$Fiscal_Year <- str_replace(ssa_long$Fiscal_Year, "FY", "20")

# What values do we now have for months?
unique(ssa_long$Fiscal_Year)

# Build a date string using the first day of the month
paste('01', ssa_long$month, ssa_long$Fiscal_Year)

ssa_long$Date <- dmy(paste("01", ssa_long$month, ssa$Fiscal_Year))

# What do those look like?
unique(ssa_long$Date)

# Government fiscal years differ from calendar years in that they are named for the
# calendar year where they end.  The government fiscal year begins in October.
# So October 2016 is actually in FY17.
#
# We need to convert these to calendar dates before we try to plot them, so we
# need to find months >=10 and subtract one year from them

# Let's find the affected rows
advanced_dates <- which(month(ssa_long$Date)>=10)

# And then decerement the years by one
year(ssa_long$Date[advanced_dates]) <- year(ssa_long$Date[advanced_dates]) - 1

# Let's look at where we are
summary(ssa_long)

# Remove Fiscal_Year and month columns
ssa_long$Fiscal_Year <- NULL
ssa_long$month <- NULL

# Convert application_method to a factor
ssa_long$application_method <- as.factor(ssa_long$application_method)

# How does that look
summary(ssa_long)

# Widen the final dataset
ssa <- spread(ssa_long, application_method, applications)

# And take a look
print(ssa,n=20)

# Add a column for the percentage of applications that were online
ssa$online_percentage <- ssa$Internet/ssa$Total*100

# Plot the results
ggplot(data=ssa, mapping=aes(x=Date,y=online_percentage)) +
  geom_point()


	# Author: Aaron Zhu
	# step 1: join all the records from different zipcode together, compute unit price (total price / total living space)
	# step 2: For a given city, year and type (single house/condo/townhouse), compute their median price
	# step 3: For a given city and type, compute annual median price change
	# step 3: make graphs
	#************************************************************
	inpath <- ".../data/archive/"
	outpath <- ".../07_data_scraping/out/"
	#*************************************************************

	# import .csv data
	files <- list.files(inpath)
	files <- files[grepl("csv", files)]

	data <- read.csv(paste0(inpath, files[1]), sep = ",", header= TRUE, stringsAsFactors = F)

	for(i in 2:length(files)){
	tmp <- read.csv(paste0(inpath, files[i]), sep = ",", header= TRUE, stringsAsFactors = F)
	data <- rbind(data, tmp)
	}
	rm(tmp)

	names(data) <- gsub("URL.*","URL",names(data))
	names(data) <- tolower(names(data) )
	names(data) <- gsub("\\.","_",names(data))
	data <- filter(data, sale_type == "PAST SALE" )
	data$sold_date <- as.Date(data$sold_date, "%B-%d-%Y")

	data$pro_type <- ""
	data<- data %>%
			   mutate(pro_type = ifelse(property_type== "Condo/Co-op", "condo", pro_type),
						  pro_type = ifelse(grepl("Single Family", property_type), "single_family", pro_type),
						  pro_type = ifelse(property_type== "Townhouse", "townhouse", pro_type)
			   )

	data <- filter(data, !pro_type == "" )
	data$sale_type <- NULL
	data <- mutate(data, city = toupper(city))
	data <- mutate(data, city = ifelse(city == "RANCHO CALIFORNIA", "RANCHO CUCAMONGA",city))
	#*********

	data <- filter(data, !is.na(sold_date))
	data <- mutate(data, lot_price = price/lot_size ,
								   living_price = price/square_feet
				)
	data <- mutate(data, yr = year(sold_date))
	#data <- filter(data, yr >= 2000)

	data <- data %>%
				group_by(city, yr, pro_type) %>%
				mutate(lot_price_10 = quantile(lot_price, 0.1, na.rm = T),
						   lot_price_30 = quantile(lot_price, 0.3, na.rm = T),
						   lot_price_50 = quantile(lot_price, 0.5, na.rm = T),
						   lot_price_70 = quantile(lot_price, 0.7, na.rm = T),
						   lot_price_90 = quantile(lot_price, 0.9, na.rm = T),
						   living_price_10 = quantile(living_price, 0.1, na.rm = T),
						   living_price_30 = quantile(living_price, 0.3, na.rm = T),
						   living_price_50 = quantile(living_price, 0.5, na.rm = T),
						   living_price_70 = quantile(living_price, 0.7, na.rm = T),
						   living_price_90 = quantile(living_price, 0.9, na.rm = T),
						   n = sum(!is.na(living_price))
				)
	keep <- names(data)[grep("lot_price_", names(data) )	]
	keep <- c(keep , names(data)[grep("living_price_", names(data) )	])
	keep <- c("n","city", "yr", "pro_type", keep)
	data <- data[,keep]
	data <- data[!duplicated(data),]
	data <- arrange(data, city, pro_type, yr)

	keep <- names(data)[grep("living_price_", names(data) )	]
	keep <- c("n","city", "yr", "pro_type", keep)
	data <- data[,keep]
	data <- data%>%
				arrange(city, pro_type, yr) %>%
				group_by(city, pro_type) %>%
				mutate(living_p_r_10  = living_price_10/ lag(living_price_10) - 1 ,
						   living_p_r_30  = living_price_30/ lag(living_price_30) - 1 ,
						   living_p_r_50 = living_price_50/ lag(living_price_50) - 1 ,
						   living_p_r_70  = living_price_70/ lag(living_price_70) - 1 ,
						   living_p_r_90  = living_price_90/ lag(living_price_90) - 1
				)

	data <- filter(data,city == "WEST COVINA" |city == "ARCADIA" |city == "EL MONTE" |city == "SAN GABRIEL"  |city == "PASADENA" |city == "ALHAMBRA"
	 )

	#*************************************************************
	tiff(paste0(outpath, "sf_home_price.jpeg"), width=1500, height=1200)
	ggplot() +
	geom_line(data= data[data$pro_type == "single_family",], aes(x= yr, y = living_price_50, color = city), size =2 )  +
	scale_x_continuous(breaks=min(data$yr):max(data$yr)) +
	xlab("Year") +
	ylab("Dollars per Square Foot") +
	labs(title=paste0("Median Single-Family Home Price at San Gabriel Area"), caption = "Source: REDFIN.COM" )  +
	theme(legend.position = "bottom", plot.title = element_text(hjust = 0.5, size=46), plot.subtitle = element_text(hjust = 0.5, size=34), plot.caption = element_text(size=28), axis.text=element_text(size=24) , axis.title=element_text(size=30), legend.text = element_text(size=23), legend.title=element_blank()) +
	scale_y_continuous(labels =scales::dollar_format())
	dev.off()

	#*************************************************************

	tiff(paste0(outpath, "sf_home_price_change.jpeg"), width=1500, height=1200)
	ggplot() +
	geom_line(data= data[data$pro_type == "single_family",], aes(x= yr, y = living_p_r_50, color = city), size =2 )  +
	scale_x_continuous(breaks=min(data$yr):max(data$yr)) +
	xlab("Year") +
	ylab("Percentage Change") +
	labs(title=paste0("Annual Percentage Change for Median Single-Family Home Price \n at San Gabriel Area"), caption = "Source: REDFIN.COM" )  +
	theme(legend.position = "bottom", plot.title = element_text(hjust = 0.5, size=46), plot.subtitle = element_text(hjust = 0.5, size=34), plot.caption = element_text(size=28), axis.text=element_text(size=24) , axis.title=element_text(size=30), legend.text = element_text(size=23), legend.title=element_blank()) +
	scale_y_continuous(labels = scales::percent, breaks= seq(-0.25,0.5,0.1))
	dev.off()

	#*************************************************************
	tiff(paste0(outpath, "condo_home_price.jpeg"), width=1500, height=1200)
	ggplot() +
	geom_line(data= data[data$pro_type == "condo",], aes(x= yr, y = living_price_50, color = city), size =2 )  +
	scale_x_continuous(breaks=min(data$yr):max(data$yr))  +
	xlab("Year") +
	ylab("Dollars per Square Foot") +
	labs(title=paste0("Median Condo Price at San Gabriel Area"), caption = "Source: REDFIN.COM" )  +
	theme(legend.position = "bottom", plot.title = element_text(hjust = 0.5, size=46), plot.subtitle = element_text(hjust = 0.5, size=34), plot.caption = element_text(size=28), axis.text=element_text(size=24) , axis.title=element_text(size=30), legend.text = element_text(size=23), legend.title=element_blank()) +
	scale_y_continuous(labels =scales::dollar_format())
	dev.off()

	#*************************************************************
	tiff(paste0(outpath, "condo_home_price_change.jpeg"), width=1500, height=1200)
	ggplot() +
	geom_line(data= data[data$pro_type == "condo",], aes(x= yr, y = living_p_r_50, color = city), size =2 )  +
	scale_x_continuous(breaks=min(data$yr):max(data$yr))  +
	xlab("Year") +
	ylab("Percentage Change") +
	labs(title=paste0("Annual Percentage Change for Median Condo Price \n at San Gabriel Area"), caption = "Source: REDFIN.COM" )  +
	theme(legend.position = "bottom", plot.title = element_text(hjust = 0.5, size=46), plot.subtitle = element_text(hjust = 0.5, size=34), plot.caption = element_text(size=28), axis.text=element_text(size=24) , axis.title=element_text(size=30), legend.text = element_text(size=23), legend.title=element_blank()) +
	scale_y_continuous(labels = scales::percent, breaks= seq(-0.3,0.75,0.1))
	dev.off()


library(plotly, warn.conflicts = FALSE)

make_bin_bounds <- function(bins, axis_name) {
    bin_bounds <- get_bin_bounds(
        get_property_value(bins, axis_name)
    )

    names(bin_bounds)[1:2] <- c(
        paste(axis_name, "bin_left_bound", sep="_"),
        paste(axis_name, "bin_right_bound", sep="_")
    )

    return(bin_bounds)
}

sample_auxiliary_row <- function(x_bound, y_bound, z) {
    return(
        list(
            x_bin_left_bound=0.0, # Left boundaries are not used on the rendering step - they are used only for storing area boundaries in the main coprus fragment
            x_bin_right_bound=x_bound,
            y_bin_left_bound=0.0,
            y_bin_right_bound=y_bound,
            z=z
        )
    )
}

visualize_as_3d_histogram <- function(corpus, epsilon = 1e-14) {
    data <- corpus$data
    manifest <- corpus$manifest

    bins <- get_property_value(manifest, 'bins')
    grid_bins = merge(make_bin_bounds(bins, 'x'), make_bin_bounds(bins, 'y'))

    bin_counts = c()

    additional_points <- data.frame(
        x_bin_left_bound=double(),
        x_bin_right_bound=double(),
        y_bin_left_bound=double(),
        y_bin_right_bound=double(),
        z=integer()
    )

    for (i in 1:nrow(grid_bins)) {
        x_bin_left_boundary <- grid_bins[i, "x_bin_left_bound"]
        x_bin_right_boundary  <- grid_bins[i, "x_bin_right_bound"]

        y_bin_left_boundary <- grid_bins[i, "y_bin_left_bound"]
        y_bin_right_boundary  <- grid_bins[i, "y_bin_right_bound"]

        counts = nrow(
            data[
                which(
                    data$x > x_bin_left_boundary &
                    data$x <= x_bin_right_boundary &
                    data$y > y_bin_left_boundary &
                    data$y <= y_bin_right_boundary
                ),
            ]
        )

        additional_points = rbind(
            additional_points,
            sample_auxiliary_row(x_bin_left_boundary + epsilon, y_bin_left_boundary + epsilon, counts),
            sample_auxiliary_row(x_bin_left_boundary + epsilon, y_bin_right_boundary, counts),
            sample_auxiliary_row(x_bin_right_boundary, y_bin_left_boundary + epsilon, counts)
        )

        bin_counts[i] <- counts
    }

    grid_bins$z <- bin_counts
    grid_bins <- rbind(grid_bins, additional_points)

    color <- as.vector(col2rgb(get_property_value(manifest, 'color', "#e75874")))

    grid_bins %>% plot_ly(x = ~x_bin_right_bound, y = ~y_bin_right_bound, z = ~z, width = 1920, height = 1080, type="mesh3d",
         intensity=grid_bins$z, colorscale='Viridis'
    ) %>% layout(
        scene = list(
            xaxis = list(title = manifest['labels'][[1]]['x-axis'][[1]]),
            yaxis = list(title = manifest['labels'][[1]]['y-axis'][[1]]),
            zaxis = list(title = manifest['labels'][[1]]['z-axis'][[1]])
        )
    ) %>% return
}


###############################################################################
# NMDS
#------------------------------------------------------------------------------
# by Umer Zeeshan Ijaz (http://userweb.eng.gla.ac.uk/umer.ijaz)
#
###############################################################################

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(vegan) # Load vegan library
library(ggplot2) # Now do the actual plotting

#==============================================================================
# Let's rock'n'roll!
#==============================================================================

abund_table <- read.csv("SPE_pitlatrine.csv",row.names=1,check.names=FALSE)

# Transpose the data to have sample names on rows
abund_table <- t(abund_table)
meta_table <- read.csv("ENV_pitlatrine.csv",row.names=1,check.names=FALSE)

# Just a check to ensure that the samples in meta_table are in the same order as in abund_table
meta_table <- meta_table[rownames(abund_table),]

# Get grouping information
grouping_info <- data.frame(row.names=rownames(abund_table),t(as.data.frame(strsplit(rownames(abund_table),"_"))))

# Get MDS stats
sol <- metaMDS(abund_table,distance = "bray", k = 2, trymax = 50)

# Make a new data frame, and put country, latrine, and depth information there, to be useful for coloring, and shape of points
NMDS=data.frame(x=sol$point[,1],y=sol$point[,2],Country=as.factor(grouping_info[,1]),Latrine=as.factor(grouping_info[,2]),Depth=as.factor(grouping_info[,3]))

# Get spread of points based on countries
plot.new()
ord <- ordiellipse(sol, as.factor(grouping_info[,1]) ,display = "sites", kind ="sd", conf = 0.95, label = T)
dev.off()

# Reference: http://stackoverflow.com/questions/13794419/plotting-ordiellipse-function-from-vegan-package-onto-nmds-plot-created-in-ggplo
# Data frame df_ell contains values to show ellipses. It is calculated with function veganCovEllipse which is hidden in vegan package. This function is applied to each level of NMDS (group) and it uses also function cov.wt to calculate covariance matrix.
veganCovEllipse <- function (cov, center = c(0, 0), scale = 1, npoints = 100)
{
  theta <- (0:npoints) * 2 * pi/npoints
  Circle <- cbind(cos(theta), sin(theta))
  t(center + scale * t(Circle %*% chol(cov)))
}

# Generate ellipse points
df_ell <- data.frame()
for(g in levels(NMDS$Country)){
  if(g! = "" && (g %in% names(ord))){

    df_ell <- rbind(df_ell, cbind(as.data.frame(with(NMDS[NMDS$Country==g,],
                                                     veganCovEllipse(ord[[g]]$cov,ord[[g]]$center,ord[[g]]$scale)))
                                  ,Country=g))
  }
}

# Generate mean values from NMDS plot grouped on Countries
NMDS.mean = aggregate(NMDS[,1:2],list(group=NMDS$Country),mean)

#==============================================================================
# Plots
#==============================================================================
shape_values <- seq(1,11)

p <- ggplot(data=NMDS,aes(x,y,colour=Country))
p <- p + annotate("text",x=NMDS.mean$x,y=NMDS.mean$y,label=NMDS.mean$group,size=4)
p <- p + geom_path(data=df_ell, aes(x=NMDS1, y=NMDS2), size=1, linetype=2)
p <- p + geom_point(aes(shape=Depth))+scale_shape_manual(values=shape_values)+theme_bw()
pdf("NMDS.pdf")
print(p)
dev.off()


library(randomForest)
library(ROCR)
library(MLmetrics)
library(caret)
# read data
finalData <- read.csv(file = "./FinalData.csv", sep = ",", header = TRUE, stringsAsFactors = FALSE)
finalData$target_id <- as.character(finalData$target_id)
# drop possible all NA columns
finalData <- finalData[, !apply(is.na(finalData), 2, all)]
# keep way from training data with class = NA
classNaData <- finalData[which(is.na(finalData$DE)),]
# clear data - keep only ones with meaningful classes
finalData <- finalData[which(!is.na(finalData$DE)),]
# replace NAs with 0
finalData[is.na(finalData)] <- 0
# convert character columns to factors
finalData[sapply(finalData, is.character)] <- lapply(finalData[sapply(finalData, is.character)],as.factor)
# remove factors with many levels
finalData <- finalData[, which(lapply(X = finalData, FUN = nlevels) < 50)]
# convert boolean DE column to factor
finalData$DE <- as.factor(finalData$DE)
# set seed
set.seed(123)
# shuffle data
finalData <- finalData[sample(nrow(finalData)),]
# split to training and testing datasets
rndsplt <- sample(x = 2, size = nrow(finalData), replace = TRUE, prob = c(0.95,0.05))
trainingData <- finalData[rndsplt == 1, ]
testingData <- finalData[rndsplt == 2, ]
# create search grid
rfGrid <- expand.grid(ntreeArg = (1:5)*500,
                      replaceAge = c(TRUE, FALSE),
                      mtryArg = (round(sqrt(length(trainingData))) + (-2:2)),
                      sampsizeArg  = c(nrow(trainingData), round(nrow(trainingData)*.9), round(nrow(trainingData)*.8), round(nrow(trainingData)*.75)),
                      nodesize = c(1, 3, 5, 7)
)
colnames(rfGrid) <- c("ntree", "replace", "mtry", "sampsize", "nodesize")
numModels <- c(400, 300, 250, 200, 150, 100, 75, 50, 25, 12);
currParams <- as.data.frame(matrix(data = NA, nrow = 1, ncol = ncol(rfGrid) + 3))
colnames(currParams) <- c(colnames(rfGrid), "Accuracy", "AUC", "F1score")
bestGenModel <- currParams
# main loop and measure time
for (j in 1:length(numModels)){
  print(paste0("generating up to ", numModels[j], " models..."))
  start.time <- Sys.time()
  for (i in 1:numModels[j]){
    print(paste0("building model ", i))
    currParams[i,] <- rfGrid[sample(nrow(rfGrid), size = 1),] #sample random combination and train the forest
    # Train Model
    rfModel <- randomForest(x = trainingData[,-ncol(trainingData)], y = trainingData$DE,
                            ntree = currParams[i,'ntree'],
                            replace = currParams[i,'replace'],
                            mtry = currParams[i,'mtry'],
                            sampsize = currParams[i,'sampsize'],
                            nodesize = currParams[i,'nodesize'])
    # Predict
    pred <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'response')
    predprob <- predict(object = rfModel, testingData[,-ncol(testingData)], type = 'prob')
    # Evaluate model
    # Confusion Matrix
    # confusionMatrix(data = pred, reference = testingData$DE, positive = 'TRUE')
    # Accuracy
    currParams[i,'Accuracy'] <- Accuracy(y_pred = pred, y_true = testingData[,ncol(testingData)])
    pred_obj = prediction(predprob[,2], testingData[,ncol(testingData)], label.ordering = c("FALSE", "TRUE"))
    # AUC
    currParams[i,'AUC'] <- performance(prediction.obj = pred_obj, measure = "auc")@y.values
    # F1 score
    currParams[i,'F1score'] <- F1_Score(y_true = testingData$DE, y_pred = pred, positive = 'TRUE')
  }
  # best generated model among numModels[i] models
  bestModel <- currParams[which(currParams$Accuracy == max(currParams$Accuracy)),]
  bestModel <- bestModel[which(bestModel$AUC == max(bestModel$AUC)),]
  bestModel <- bestModel[which(bestModel$F1score == max(bestModel$F1score)),]
  bestGenModel[j,] <- bestModel[1,]
  end.time <- Sys.time()
  time.taken <- end.time - start.time
  saveRDS(object = data.frame(n = numModels[j], time.t = time.taken), file = paste0("./test/rf", numModels[j], ".rds"))
}


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
#install.packages("pmml")
#install.packages("gbm")
#install.packages("devtools")
#install.packages("rJava")
#install_github(repo = "jpmml/r2pmml")
#install.packages("caret")
#install.packages("ROCR")

# Load below packages
library(devtools)
library(gbm)
library(rJava)
library(r2pmml)
library(pmml)# This package is specifically loaded for Cars dataset shipped within it.
library(caret)
library(ROCR)

# Here we directly load the audit dataset installed with the "pmml" package.
data(audit, package="pmml")

# rename column names for audit dataset from pmml package
auditOriginal <- setNames(audit, c("ID", "Age", "Employment", "Education", "Marital", "Occupation", "Income", "Sex", "Deductions", "Hours",
"Accounts", "Adjustment", "Adjusted"))

# Omit rows with missing values
auditOriginal = na.omit(auditOriginal)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# audit= read.csv("Audit.csv")

# Divide dataset for training and test
trainData= auditOriginal[1:1309,]
testData= auditOriginal[1310:1859,]

# Applying Genenalized Boosting Model - bernoulli distribution to predict Adjusted
auditFormula = formula(Adjusted ~ .)
audit_GBM = gbm(auditFormula, data=trainData, distribution="bernoulli",cv.folds=5,verbose=FALSE)

# Display the predicted results and create cross table to check on accuracy
# Predict "Adjusted" column probability for test data set
auditTestProbabilities = predict.gbm(audit_GBM, newdata=testData, n.trees=100,type="response")
# Display predicted probabilities
auditTestProbabilities

# Generate ROC curve and calculate AUC value to predict the accuracy for Audit test dataset

# To create visualizations - ROC curve with "ROCR" package two vectors of data are needed,
# The first vector must contain the class values - Adjusted column and
# The second vector must contain the estimated probability of the positive class(AuditHighriskProbability)
pred <- prediction(labels = testData$Adjusted, predictions = auditTestProbabilities)

# Using the perf performance object, we can visualize the ROC curve with R's plot() function
perf <- performance(pred, measure = "tpr", x.measure = "fpr")

# Plot the ROC curve for the visualization
plot(perf, main = "ROC curve for Audit Test Dataset", col = "blue", lwd = 3)

# To indicate reference line in the ROC plot
abline(a = 0, b = 1, lwd = 2, lty = 2)

# We can use the ROCR package to calculate the AUC(Area under the ROC Curve)
# To do so, we first need to create another performance object and specify measure = "auc", as shown in the following code:
perf.auc <- performance(pred, measure = "auc")

# perf.auc is an object (specifically known as an S4 object) we need to use a special type of notation to access the values stored within.
# S4 objects hold information in positions known as slots
# The str() function can be used to see all slots for an object
str(perf.auc)

# To access the AUC value, which is stored as a list in the y.values slot, we can use the @ notation along with the unlist() function, which simplifies lists to a vector of numeric values
# Below AUC value is under the "outstanding" category
unlist(perf.auc@y.values)

# PMML generation
r2pmml(audit_GBM ,"Audit.pmml")

# The code below is used for evaluation purpose.
# The model is applied for original audit data set and predicted results are saved in "ROutput.csv"
# "ROutput.csv" file used for comparing the R results with PMML Evaluation engine results

# Applying GBM model to entire dataset and save the results in a CSV file
auditEntireProbabilities = predict.gbm(audit_GBM, type = "response",auditOriginal)
auditEntirePrediction = predict.gbm(audit_GBM, type = "link",auditOriginal)

# Save predicted value in a data frame
auditProbabilities = cbind(1 - auditEntireProbabilities , auditEntireProbabilities)
result = data.frame(auditEntirePrediction , auditProbabilities)
names(result) = c("Predicted_Adjusted" , "AuditLowriskProbability" , "AuditHighriskProbability")

# Write the results in a CSV file
write.csv(result, "ROutput.csv" , quote=F)


  create.histograms.yearly = function( X, probs=c(0, 0.995) ) {
    xr=range(X)
    xl=quantile( X, probs=probs )
    br=c( xr[1], seq(xl[1], xl[2], length.out=100 ), xr[2] )
    ny = dim(X)[1]
    nn = matrix(0, ncol=ny, nrow=length(br)-1 )
    for (yy in 1:ny ) {
      nx = hist( X[yy,,], breaks=br, plot=FALSE )
      nn[,yy]=nx$counts
    }
    rownames(nn) = nx$mids
    return(nn)
  }


##
#  alternate visualization of transition matrix analysis:
#  simple barplot of "language shift" aka p(B1,C2|B1)
##

rm(list=ls())
library(ggplot2)

# read in data
source('inread.r')
B.gen1 <- inread('analysis/tp_decade_b1.csv')
# make sure every cohort will be labeled
B.gen1$cohort <- as.factor(B.gen1$cohort)

# plot setup -- could be used for any subset
baseplot <- function(thesubset){ggplot(data = thesubset,
	aes(x=cohort, y=prob)) +
  geom_bar(stat = "identity") +
  ylim(0,1) +
  geom_errorbar(aes(ymin=prob-se, ymax=prob+se),
        width=0.5, size=0.8) +
  xlab("Child's Decade of Birth") +
  theme(axis.text=element_text(size=12),
        axis.title=element_text(size=12))
  }

# specific plot elements for p(B1,C2|B1)
shift <- baseplot(B.gen1[B.gen1$outcome %in% "C.gen2",]) +
  ylab("Proportion of Chinese-monolingual children") +
  labs(title = paste(
    "Rate of shift (loss of Mongolian) among children of bilingual households",
    "\nN =", sum(B.gen1$n)/3,
    "(interviewees only)"))
# other subsets could be plotted likewise

plots <- c("shift")
prefix <- "figures/plot_"
l <- mget(plots)
invisible(mapply(ggsave,
  file=paste0(prefix, names(l), ".pdf"),
  width=7.5, height=5, units="in", plot=l))
invisible(mapply(ggsave,
  file=paste0(prefix, names(l), ".jpg"),
  width=7.5, height=5, units="in", plot=l))


GetMCS <- function(dflist) {
  # This function takes the list of HILDA data frames and calculates the MCS for every viable
  # respondant in the list. It returns a data frame with xwaveid, wave, code and value.

  require(dplyr)

  sf36codes <- c('ghbp', 'ghgh', 'ghmh', 'ghpf', 'ghre', 'ghrp', 'ghsf', 'ghvt')
  sf36 <- GetRaws(dflist, sf36codes) %>%
    mutate(
      val = case_when(
        val < 0 ~ NA_integer_,
        TRUE ~ as.integer(val)
      )
    ) %>%
    spread(code, val) %>%
    na.omit() %>%
    unite(rowid, xwaveid, wave)

  # Convert raw scores to population-based z-scores using ABS means & SD
  sf36popz <- sf36['rowid']
  sf36popz[, 2] <- (sf36['ghpf'] - 83.46290)/23.22864
  sf36popz[, 3] <- (sf36['ghrp'] - 80.28166)/34.83783
  sf36popz[, 4] <- (sf36['ghbp'] - 76.94163)/24.83714
  sf36popz[, 5] <- (sf36['ghgh'] - 71.81575)/20.35165
  sf36popz[, 6] <- (sf36['ghvt'] - 64.47694)/19.77187
  sf36popz[, 7] <- (sf36['ghsf'] - 85.05929)/22.29047
  sf36popz[, 8] <- (sf36['ghre'] - 83.19165)/32.15215
  sf36popz[, 9] <- (sf36['ghmh'] - 75.97772)/16.96210
  sf36.matrix <- as.matrix(sf36popz[, -1])
  rownames(sf36.matrix) <- sf36popz$rowid

  # These are the coefficients from ABS
  MCSwABS <- c(ghpf = -0.24358,
               ghrp = -0.13410,
               ghbp = -0.12414,
               ghgh =  0.05271,
               ghvt =  0.27100,
               ghsf =  0.26460,
               ghre =  0.35922,
               ghmh =  0.48753
  )

  MCS <- sf36.matrix %*% MCSwABS

  # Transform the component score (MCS) to mean 50 and SD 10
  MCS <- (MCS * 10) + 50

  # Convert to data frame
  MCS %>%
    as.data.frame() %>%
    rownames_to_column('rowid') %>%
    rename(val = V1) %>%
    mutate(code = 'mcs') %>%
    separate(rowid, c('xwaveid', 'wave'), sep = '_') -> df

  return(df)
}


#---
#title: "principal component analysis using SNPRelate dirctly from VCF file"
#author: "Tal Dahan-Meir"
#date: "25/08/2021"
#---

### run principal component analysis on vcf file using SNPRelate library ###
library(SNPRelate)

vcf.fn="ammiad_845.vcf"
snpgdsVCF2GDS(vcf.fn, "ccm.gds",  method="biallelic.only")
genofile <- openfn.gds("ccm.gds")
ccm_pca<-snpgdsPCA(genofile)

### load output file to get DGG colors ###
data=read.csv("data/output_with_colors.csv")

### habitat colors vector ###
colors=c("#2a7fff","#f7a8b8","#ff5555","#ff9955","#5fd35f","#ffe680","#aa0000","#9955ff")

tab_identity=data.frame(sample.id=data$Sample, pop=factor(data$Habitat_North_divided), igg_col=factor(data$color), EV1=ccm_pca$eigenvec[,1],EV2=ccm_pca$eigenvec[,2], stringsAsFactors=FALSE)
tab_identity=tab_identity[!grepl("Zavitan",tab_identity$sample.id),]

### plot pca coloring by habitat ###

pdf("20210830_pc12_snprelate_by_habitat.pdf",height=8,width=8)
plot(tab_identity$EV1, tab_identity$EV2, col=colors[as.integer(tab_identity$pop)],xlab="PC1(18.14% explained var.)",ylab="PC2(8.02% explained var.)",pch=20)
legend("bottomright", legend=levels(tab_identity$pop), pch=19, col=colors)
dev.off()

### plot pca coloring by DGG ###

pdf("20210830_pc12_snprelate_by_igg.pdf",height=8,width=8)
plot(tab_identity$EV1, tab_identity$EV2, col=as.character(tab_identity$igg_col),xlab="PC1(18.14% explained var.)",ylab="PC2(8.02% explained var.)",pch=20)
dev.off()


C <- matrix(c(-2,4,6,2,4,1),2,3)
D <- matrix(c(3,9,7,2,5,1,4,-2,8),3,3)
E <- matrix(c(4,8,1,-1,6,-6,0,4,7),3,3)
# C+D cannot be computed because of different dimensions.

x=D+E
y=D-E
z=C%*%D
p=t(E)
x
y
z
p


####
#  carries out transition matrix analysis:
#  calculates transition probability
#  of intergenerational language transmission
#  for each level of some variable
#  such as age cohort or urban-town-rural
#  outputs 6 data tables
####

# must be called from within other script
# that creates objects 'df' and 'xvar'
# see tp_decade.r and tp_urbrur.r

### PART 1. TRANSITION MATRICES ###

# first, make a count matrix
# aka contingency table: child-MBC x parent-MBC
# forces output to 3x3 array, preserving zeroes
transitions <- function(adf){
  x <- as.data.frame(tally(adf %>%
    group_by(self.MBC, avg.elder.MBC))) %>%
    spread(avg.elder.MBC, n) # table done!
# everything below here is just to preserve zeroes and var names
  rownames(x) <- as.character(x$self.MBC)
  x$self.MBC <- NULL
  outdf <- as.data.frame(matrix(nrow=3, ncol=3))
  colnames(outdf) <- c("M.gen1", "B.gen1","C.gen1")
  rownames(outdf) <- c("M.gen2", "B.gen2", "C.gen2")
    for(rr in rownames(x)){
      for(cc in colnames(x)){
      outdf[rr,cc] <- as.numeric(x[rr,cc]) }}
  outdf[is.na(outdf)] <- 0
  return(outdf)
  }

# from count matrix, calculate probabilities
  # conditional probabilities by column: p(child.mbc|parents.mbc)
  prob.bygen1 <- function(df1){
        df2 <- transitions(df1)
        x <- as.data.frame(prop.table(as.matrix(df2),
          margin = 2)) # margin=2 means by column
        return(x)
        }
  # conditional probabilities by row: p(parents.mbc|child.mbc)
  prob.bygen2 <- function(df1){
        df2 <- transitions(df1)
        x <- as.data.frame(prop.table(as.matrix(df2),
          margin = 1)) # margin=1 means by row
        return(x)
        }

# PART 2:  APPLY PROBABILITY MATRIX FUNCTION,
# LOOPING THROUGH ALL LEVELS OF A GROUPING VARIABLE

# loop 1: p(parents.mbc|child.mbc)
  # gen2 = the subset (defined in this script)
  # df = the full dataset (from environment)
  # xvar = the predictor variable (from enviroment)
  bygen2 <- function(gen2){
  outdf <- as.data.frame(matrix(nrow=1, ncol=6))
    colnames(outdf) <- c("cohort", levels(df$avg.elder.MBC), "n", "gen2")
  for (i in levels(df[[xvar]])){
    xgroup <- df[df[[xvar]] == i,]
    n <- length(xgroup$Subject_Code[xgroup$self.MBC == gen2])
    probs <- prob.bygen2(xgroup)
    outdf[i,] <- c(i, probs[rownames(probs) == gen2,], n, gen2)
  }
  outdf[,2] <- as.numeric(outdf[,2])
  outdf[,3] <- as.numeric(outdf[,3])
  outdf[,4] <- as.numeric(outdf[,4])
  outdf$n <- as.integer(outdf$n)
  outdf <- outdf[outdf$cohort %in% levels(df[[xvar]]),]
  outdf$cohort <- as.factor(outdf$cohort)
  rownames(outdf) <- NULL
  return(outdf)
  }

# loop 2: p(child.mbc|parents.mbc)
  # gen1 = the subset (defined in this script)
  # df = the full dataset (from environment)
  # xvar = the predictor variable (from environment)
bygen1 <- function(gen1){
  outdf <- as.data.frame(matrix(nrow=1, ncol=6))
  colnames(outdf) <- c("cohort", levels(df$self.MBC), "n", "gen1")
  for (i in levels(df[[xvar]])){
    xgroup <- df[df[[xvar]] == i,]
    n <- length(xgroup$Subject_Code[xgroup$avg.elder.MBC == gen1])
    probs <- prob.bygen1(xgroup)
    outdf[i,] <- c(i, probs[,colnames(probs) == gen1], n, gen1)
  }
  outdf[,2] <- as.numeric(outdf[,2])
  outdf[,3] <- as.numeric(outdf[,3])
  outdf[,4] <- as.numeric(outdf[,4])
  outdf$n <- as.integer(outdf$n)
  outdf <- outdf[outdf$cohort %in% levels(df[[xvar]]),]
  outdf$cohort <- as.factor(outdf$cohort)
  rownames(outdf) <- NULL
  return(outdf)
}

## PART 3: RUN LOOP FOR SIX SUBSETS ##
# Child-based subsets
M.gen2 <- bygen2(levels(df$self.MBC)[1])
B.gen2 <- bygen2(levels(df$self.MBC)[2])
C.gen2 <- bygen2(levels(df$self.MBC)[3])
# Elder-based subsets
M.gen1 <- bygen1(levels(df$avg.elder.MBC)[1])
B.gen1 <- bygen1(levels(df$avg.elder.MBC)[2])
C.gen1 <- bygen1(levels(df$avg.elder.MBC)[3])

## PART 4: PREPARE PLOT-READY OUTPUT ##
library(tidyr)
# standard error
get.se <- function(df, col, n = "n"){
  p <- df[[col]]
  n <- df[[n]]
  x <- sqrt(p*(1-p)/n)
  return(x)
}
# convert from wide to long format
# then calculate SE
add.se <- function(df){
  df <- gather(df, "outcome", "prob", 2:4)
    # cols 2:4 contain the 3 transition outcomes
  df$se <- get.se(df, "prob" ,"n")
  return(df)
} # gather function is an old version of pivot_longer

M.gen1 <- add.se(M.gen1)
B.gen1 <- add.se(B.gen1)
C.gen1 <- add.se(C.gen1)

M.gen2 <- add.se(M.gen2)
B.gen2 <- add.se(B.gen2)
C.gen2 <- add.se(C.gen2)

# write out
gens <- c(
  "M.gen1", "B.gen1", "C.gen1", "M.gen2", "B.gen2", "C.gen2"
  )
l <- mget(gens)
invisible(mapply(write.csv, l,
  file = paste0("analysis/tp_", xvar, "_",
          tolower(gsub(".gen", "", names(l))), ".csv"),
  row.names = FALSE,
  fileEncoding = "UTF-8"))


softmax <- function (x) {
    m <- max(x)
    exps <- exp(x - m)
    s <- sum(exps)
    return(exps / s)
}
score <- function(input) {
    if ((input[3]) >= (2.45)) {
        var0 <- -0.21995015
    } else {
        var0 <- 0.4302439
    }
    if ((input[3]) >= (2.45)) {
        var1 <- -0.19691855
    } else {
        var1 <- 0.29493433
    }
    if ((input[3]) >= (2.45)) {
        if ((input[4]) >= (1.75)) {
            var2 <- -0.20051816
        } else {
            var2 <- 0.36912444
        }
    } else {
        var2 <- -0.21512198
    }
    if ((input[3]) >= (2.45)) {
        if ((input[3]) >= (4.8500004)) {
            var3 <- -0.14888482
        } else {
            var3 <- 0.2796613
        }
    } else {
        var3 <- -0.19143805
    }
    if ((input[4]) >= (1.6500001)) {
        var4 <- 0.40298507
    } else {
        if ((input[3]) >= (4.95)) {
            var4 <- 0.21724138
        } else {
            var4 <- -0.21974029
        }
    }
    if ((input[3]) >= (4.75)) {
        if ((input[4]) >= (1.75)) {
            var5 <- 0.28692952
        } else {
            var5 <- 0.06272897
        }
    } else {
        if ((input[4]) >= (1.55)) {
            var5 <- 0.009899145
        } else {
            var5 <- -0.19659369
        }
    }
    return(softmax(c((0.5) + ((var0) + (var1)), (0.5) + ((var2) + (var3)), (0.5) + ((var4) + (var5)))))
}


#' @title Aggregate keyword-country data and compute DOI
#'
#' @aliases
#' compute_doi
#' compute_doi.numeric
#' compute_doi.list
#'
#' @description
#' The function computes degree of internationalization (DOI) for object
#' keywords. Degree of internationalization is measured based on the
#' distribution of country search scores.
#'
#' @details
#' The function uses an inverted Gini-coefficient
#' `dplyr::coalesce(1 - ineq::ineq(series, type = "Gini"), 0)`
#' as measure for the degree of internationalization. The more uniform the
#' distribution of search scores across all countries, the higher the inverted
#' Gini-coefficient and the greater the degree of internationalization. In
#' addition to the Gini-coefficient, the package uses inverted Herfindahl index
#' `coalesce(1 - sum((series / sum(series))^2), 0)` and inverted Entropy
#' `dplyr::coalesce(-1 * ineq::ineq(series, parameter = 1, type = "entropy"), 0)`
#' as measures for internationalization.
#'
#' @param control Control batch for which the search score is used. Object
#' of type `numeric`.
#' @param object Object batch for which the keyword-country data
#' is aggregated and DOI is computed.  Object of type `numeric`.
#' @param locations List of locations for which the search score is used.
#' Object of type `character`. Defaults to *"countries"*.
#'
#' @seealso
#' * [example_doi()]
#' * [ineq::ineq()]
#'
#' @return
#' Message that data was aggregated successfully. Data is written to table
#' *data_doi*.
#'
#' @examples
#' \dontrun{
#' compute_doi(
#'   object = 1,
#'   control = 1,
#'   locations = "countries"
#' )
#' compute_doi(
#'   object = as.list(1:5),
#'   control = 1,
#'   locations = "countries"
#' )
#' }
#'
#' @export
#' @rdname compute_doi
#' @importFrom DBI dbWriteTable
#' @importFrom dplyr collect
#' @importFrom dplyr filter
#' @importFrom dplyr mutate
#' @importFrom dplyr select
#' @importFrom glue glue
#' @importFrom purrr map_dbl
#' @importFrom purrr map_lgl
#' @importFrom purrr walk
#' @importFrom rlang .data
#' @importFrom tidyr nest
#' @importFrom tidyr pivot_longer

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

#' @rdname compute_doi
#' @method compute_doi numeric
#' @export

compute_doi.numeric <- function(object, control = 1, locations = "countries") {
  control <- unlist(control)
  .check_length(control, 1)
  .check_length(locations, 1)
  .check_input(locations, "character")
  if (length(object) > 1) {
    compute_doi(control = control, object = as.list(object), locations = locations)
  } else {
    walk(list(control, object), .check_batch)
    if (.test_empty(table = "data_doi", batch_c = control, batch_o = object, locations = locations)) {
      data <- filter(.tbl_score, .data$batch_c == control & .data$batch_o == object)
      data <- collect(data)
      tmp_locations <- pull(collect(filter(.tbl_locations, .data$type == locations)), .data$location)
      data <- filter(data, .data$location %in% tmp_locations & .data$synonym == 0)

      # compute doi measures
      data <- pivot_longer(data, cols = contains("score"), names_to = "type", values_to = "score")
      data <- nest(data, data = c(.data$location, .data$score))
      data <- mutate(data, check = map_lgl(.data$data, ~ !all(is.na(.x$score))))
      out1 <- filter(data, .data$check)
      out1 <- mutate(
        out1,
        gini = map_dbl(.data$data, ~ .compute_gini(series = .x$score)),
        hhi = map_dbl(.data$data, ~ .compute_hhi(series = .x$score)),
        entropy = map_dbl(.data$data, ~ .compute_entropy(series = .x$score))
      )
      out2 <- filter(data, !.data$check)
      out2 <- mutate(
        out2,
        gini = NA,
        hhi = NA,
        entropy = NA
      )
      out <- bind_rows(out1, out2)
      out <- select(
        out,
        .data$date,
        .data$keyword,
        .data$type,
        .data$gini,
        .data$hhi,
        .data$entropy
      )

      # write data
      out <- mutate(
        out,
        batch_c = control,
        batch_o = object,
        locations = locations
      )
      dbWriteTable(conn = globaltrends_db, name = "data_doi", value = out, append = TRUE)
    }
    message(glue("Successfully computed DOI | control: {control} | object: {object} [{object}/{total}]", total = max(.keywords_object$batch)))
  }
}

#' @rdname compute_doi
#' @method compute_doi list
#' @export

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

#' @title Compute gini coefficient
#'
#' @rdname hlprs
#' @keywords internal
#' @noRd
#'
#' @importFrom dplyr coalesce

.compute_gini <- function(series) {
  out <- coalesce(1 - ineq::ineq(series, type = "Gini"), 0)
  return(out)
}

#' @title Compute herfindahl hirschman index
#'
#' @rdname hlprs
#' @keywords internal
#' @noRd

.compute_hhi <- function(series) {
  out <- coalesce(1 - sum((series / sum(series))^2), 0)
  return(out)
}

#' @title Compute entropy
#'
#' @rdname hlprs
#' @keywords internal
#' @noRd

.compute_entropy <- function(series) {
  out <- coalesce(-1 * ineq::ineq(series, parameter = 1, type = "entropy"), 0)
  if (out == -Inf) {
    out <- 0
  }
  return(out)
}


# cat rf.r | R --slave --vanilla --args NTREE MTRY TR PNG

library(randomForest)

set.seed(0)

ntree = as.integer(commandArgs(TRUE)[1])
mtry = as.integer(commandArgs(TRUE)[2])

# load data
csv <- read.csv( commandArgs(TRUE)[3], header=FALSE ); tr.y <- factor(csv[,1]); tr.x <- csv[,2:ncol(csv)]

################################################################################
# random forest

rf = randomForest( tr.y ~ ., data=tr.x, ntree=ntree, mtry=mtry, importance=TRUE, na.action=na.omit )
png( commandArgs(TRUE)[4],height = (40*nrow(rf$importance)))
varImpPlot(rf,n.var=nrow(rf$importance))
dev.off()

print("MeanDecreaseAccuracy")
impRF=importance(rf)
impRF=impRF[,"MeanDecreaseAccuracy"]
print(impRF)

print("MeanDecreaseGini")
impRF=importance(rf)
impRF=impRF[,"MeanDecreaseGini"]
print(impRF)
# vi:nowrap:sw=4:ts=4


vecadd.loop <- function(x,y) {
  l = length(x)
  z = rep(NA,l)
  for (i in 1:l) {
    z[i] = x[i] + y[i]
  }
  return(z)
}

vecadd.array <- function(x,y) {
  return(x+y)
}

x = rnorm(1e6); y = rnorm(1e6)

cat("looped vector add:\n")
z <- vecadd.loop(x,y)
system.time(z <- vecadd.loop(x,y))

cat("array vector add:\n")
z <- vecadd.array(x,y)
system.time(z <- vecadd.array(x,y))


#  James Rekow

subgroupDifferences = function(partition1, partition2){

  #  ARGS: partition1 - a partition of a numeric vector of the form 1:n
  #        partition2 - another partition of the same numeric vector
  #
  #  RETURNS: numDiffs - number of elements in partition2 that are placed in a different subgroup (as
  #                      determined by subgroup index) than in partition1

  #  identify the number of elements in the base set which the partitions divide
  numElements = length(unlist(partition1))

  #  identify the set which the partitions divide
  baseSet = 1:numElements

  computeSubgroupIxVec = function(inputPartition){

    #  ARGS: inputPartition - partition
    #
    #  RETURNS: subgroupIxVec - numeric vector whose ith element is the index of the subgroup to which
    #                           the ith element of the base set belongs to in the input partition

    #  identify number of subgroups in input partition
    numSubgroups = length(inputPartition)

    # intializeVector
    subgroupIxVec = baseSet

    for(ii in 1:numSubgroups){

      #  identify elements of baseSet in subgroup ii
      subgroupElements = inputPartition[[ii]]

      #
      subgroupIxVec[subgroupElements] = ii

    } #  end for

    return(subgroupIxVec)

  } #  end computesubgroupIxVec

  #  compute subgroup ix vector for each partition
  subgroupIxVec1 = computeSubgroupIxVec(partition1)
  subgroupIxVec2 = computeSubgroupIxVec(partition2)

  #  count the number of elements that are in different subgroups in the two partitions
  numDiffs = sum(subgroupIxVec1 != subgroupIxVec2)

  return(numDiffs)

} #  end subgroupDifferences function


#' Fitting bivariate mixed MGL and MGL-EV copula regression models.
#'
#' @description \code{MGL.reg.mixed} is used to fit bivariate MGL and MGL-EV copula regression models for continuous and semi-continuous variables.
#' @param obs two-dimensional matrix for observations.
#' @param U two-dimensional matrix for pseudo copula data with values in \eqn{[0,1]} for (F(y1), F(y2)).
#' @param U_ two-dimensional matrix for pseudo copula data for the data (F(y1), F(y2-1)).
#' @param X design matrix.
#' @param copula 'MGL', 'MGL180', "MGL-EV", "MGL-EV180"
#' @param umin threshold value used in the semi-continuous data.
#' @param f two-dimensional matrix for the density function of marginal distributions.
#' @param initpar Initial values for the parameters to be optimized over.
#' @param hessian Logical. Should a numerically differentiated Hessian matrix be returned?
#' @param ... additional arguments, see \code{\link[stats]{optim}} for more details.
#' @importFrom stats qbeta
#' @importFrom stats optim
#' @return A list containing the following components:
#' * loglike: the value of the estimated maximum of the loglikelihood function.
#' * copula: the name of the fitted copula. "MGL180" and "MGL-EV180" denote the survival MGL and MGL-EV copula respectively.
#' * estimates: the point at which the maximum value of the loglikelihood is obtained.
#' * se: the standard errors of the estimators.
#' * AIC, BIC: the goodness fit of the regression models.
#' * hessian: the hessian at the estimated maximum of the loglikelihood (if requested).
#' @details
#' The estimation method is performed via \code{\link[stats]{optim}} function. Y1 and Y2 are both continuous variables.
#' * Y1: continuous data.
#' * Y2: semi-continuous data where Y2>umin is continuous and Y2<=umin is discrete.
#'
#' copula: "MGL180" and "MGLEV180" denote the survival MGL and survival MGL-EV copula respectively.
#' * For "Gumbel" regression model, the copula parameter \deqn{\delta_i = \exp(X\beta) + 1.}
#' * For "MGL", "MGL180", "MGL-EV", "MGL-EV180" regression model, the copula parameter \deqn{\delta_i = \exp(X\beta),} where \eqn{\beta} is the vector of coefficients to be estimated in the copula regression.
#'
#' @examples
#' library(rMGLReg)
#' u <- cbind(earthqCHI$u1, earthqCHI$u2)
#' u_ <- cbind(earthqCHI$u1, earthqCHI$u2_)
#' y <- cbind(earthqCHI$y1, earthqCHI$y2)
#' f <- cbind(earthqCHI$f1, earthqCHI$f2)
#' obs <- y
#' U <- u
#' U_ <- u_
#' umin <- 20
#' library(splines)
#' X <- ns(earthqCHI$year, knots = quantile(earthqCHI$year, c(0.333, 0.667)), intercept = TRUE)
#' m.MGL180 <- MGL.reg.mixed(obs = y, U = U, U_ = U_, umin = umin, f = f, X = X,
#' copula = "MGL180",
#'                          method = "Nelder-Mead",
#'                         control = list(maxit = 100000),
#'                         initpar = c(0.64, 1.2, 1, -0.2))
#'
#' m.MGLEV180 <- MGL.reg.mixed(obs = y, U = U, U_ = U_, umin = umin, f = f, X = X,
#'                            copula = "MGL-EV180",
#'                            method = "Nelder-Mead",
#'                           control = list(maxit = 100000),
#'                           initpar = c(-0.32, 1, 1, 1))
#' m.MGL180
#' m.MGLEV180
#'
#' @export
#'
#'
MGL.reg.mixed <- function(obs, U, U_, f, X, copula = c(
                            "MGL", "MGL180", "MGL-EV",
                            "MGL-EV180",
                            "Gumbel", 'MGB2'
                          ),
                          umin = 0,
                          hessian = TRUE, initpar, ...) {
  dcMGL.reg <- function(U, param) {
    dim <- length(U)
    a <- 1 / param[1]
    q <- qbeta(1 - U, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - U, shape1 = 0.5, shape2 = a))
    logdc <- (dim - 1) * lgamma(a) + lgamma(a + dim / 2) - dim * lgamma(a + 0.5) + (a + 0.5) * sum(log(q + 1)) - (a + dim / 2) * log(sum(q) + 1)
    out <- exp(logdc)
    return(out)
  }

  dcMGL180.reg <- function(U, param) {
    dcMGL.reg(1 - U, param = param)
  }
  dcMGLEV180.reg <- function(U, param) {
    u1 <- U[1]
    u2 <- U[2]
    as.numeric(dcMGLEV180.bivar(u1, u2, param = param[1]))
  }

  dcMGLEV.reg <- function(U, param) {
    u1 <- U[1]
    u2 <- U[2]
    as.numeric(dcMGLEV.bivar(u1, u2, param = param[1]))
  }

  dgumcop.reg <- function(U, param) {
    as.numeric(fCopulae::devCopula(u = U[1], v = U[2], type = "gumbel", param = param[1])) # Bivariate Extreme
  }

  hcMGL.reg <- function(U, param) {
    hfunc1 <- hcMGL.bivar(u1 = U[1], u2 = U[2], pars = param[1])$hfunc1
    hfunc2 <- hcMGL.bivar(u1 = U[1], u2 = U[2], pars = param[1])$hfunc2
    out <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
    out
  }

  hcMGL180.reg <- function(U, param) {
    hfunc1 <- 1 - hcMGL.bivar(u1 = 1 - U[1], u2 = 1 - U[2], pars = param[1])$hfunc1
    hfunc2 <- 1 - hcMGL.bivar(u1 = 1 - U[1], u2 = 1 - U[2], pars = param[1])$hfunc2
    out <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
    out
  }

  hcMGLEV180.reg <- function(U, param) {
    hfunc1 <- hcMGLEV180.bivar(u1 = U[1], u2 = U[2], param = param[1])$hfunc1
    hfunc2 <- hcMGLEV180.bivar(u1 = U[1], u2 = U[2], param = param[1])$hfunc2
    out <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
    out
  }
  hcMGLEV.reg <- function(U, param) {
    hfunc1 <- 1 - hcMGLEV180.bivar(u1 = 1 - U[1], u2 = 1 - U[2], param = param[1])$hfunc1
    hfunc2 <- 1 - hcMGLEV180.bivar(u1 = 1 - U[1], u2 = 1 - U[2], param = param[1])$hfunc2
    out <- list(hfunc1 = hfunc1, hfunc2 = hfunc2)
    out
  }

  hgumcop.reg <- function(U, param) {
    VineCopula::BiCopHfunc(u1 = U[1], u2 = U[2], family = 4, par = param[1])
  }

  if (copula == "MGL") {
    dcop <- dcMGL.reg
    hcop <- hcMGL.reg
  } else if (copula == "MGL180") {
    dcop <- dcMGL180.reg
    hcop <- hcMGL180.reg
  } else if (copula == "MGL-EV") {
    dcop <- dcMGLEV.reg
    hcop <- hcMGLEV.reg
  } else if (copula == "MGL-EV180") {
    dcop <- dcMGLEV180.reg
    hcop <- hcMGLEV180.reg
  } else if (copula == "Gumbel") {
    dcop <- dgumcop.reg
    hcop <- hgumcop.reg
  }
  # Obs1 <- obs[, 1] # y1 - the first vector of observations
  Obs2 <- obs[, 2] # y2 - the second vector of observations
  f1 <- f[, 1]
  f2 <- f[, 2]
  copLogL <- function(pars, X) {
    ll <- 0
    if (copula == "Gumbel") {
      delta <- exp(X %*% pars) + 1
      for (i in seq_len(nrow(X))) {
        if (Obs2[i] <= umin) {
          ll[i] <- f1[i] * (hcop(U[i, ], param = delta[i])$hfunc1 - hcop(U_[i, ], param = delta[i])$hfunc1)
        } else {
          ll[i] <- f1[i] * f2[i] * dcop(U[i, ], param = delta[i])
        }
      }
    } else if(copula == "MGB2"){
      p1 <- exp(pars[ncol(X) + 1])
      p2 <- exp(pars[ncol(X) + 2])
      q <- exp(X%*%pars[1:(ncol(X))])
      for (i in seq_len(nrow(X))) {
        if (Obs2[i] <= umin) {
          ll[i] <- f1[i] * (hcMGB2.bivar(u1 = U[i,1], u2 = U[i,2], pars1 = p1, pars2 = p2, pars3 = q[i])$hfunc1 - hcMGB2.bivar(u1 = U[i,1], u2 = U_[i,2], pars1 = p1, pars2 = p2, pars3 = q[i])$hfunc1)
        } else {
          ll[i] <- f1[i] * f2[i] * dcMGB2.bivar(u1 = U[i,1], u2 = U[i,2], pars1 = p1, pars2 = p2, pars3 = q[i])
        }
      }
    } else {
      delta <- exp(X %*% pars)
      for (i in seq_len(nrow(X))) {
        if (Obs2[i] <= umin) {
          ll[i] <- f1[i] * (hcop(U[i, ], param = delta[i])$hfunc1 - hcop(U_[i, ], param = delta[i])$hfunc1)
        } else {
          ll[i] <- f1[i] * f2[i] * dcop(U[i, ], param = delta[i])
        }
      }
    }

    res <- - sum((log(ll)))
    return(res)
  }

  resopt <- optim(
    par = initpar,
    fn = copLogL,
    X = X,
    hessian = hessian, ...
  )
  resopt

  list(
    loglike = -resopt$value,
    copula = list(name = copula),
    estimates = resopt$par,
    se = sqrt(diag(solve(resopt$hessian))),
    hessian = -resopt$hessian,
    AIC = 2 * length(resopt$par) + 2 * resopt$value,
    BIC = log(nrow(U)) * length(resopt$par) + 2 * resopt$value
  )
}


# Filling the missing values

#With mean
#Training set
x_train = read.csv("X_train.csv") #read csv file
x_train
for(i in 1:ncol(x_train)){
  x_train[is.na(x_train[,i]), i] <- mean(x_train[,i], na.rm = TRUE)
}

x_train

#Testing set
x_test = read.csv("X_test.csv") #read csv file
x_test
for(i in 1:ncol(x_train)){
  x_test[is.na(x_test[,i]), i] <- mean(x_test[,i], na.rm = TRUE)
}

x_test

#write to csv
write.csv(x_train, "x_train_mean.csv", row.names = FALSE)
write.csv(x_test, "x_test_mean.csv", row.names = FALSE)

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

#With median
#Training set
x_train = read.csv("X_train.csv") #read csv file
x_train
for(i in 1:ncol(x_train)){
  x_train[is.na(x_train[,i]), i] <- median(x_train[,i], na.rm = TRUE)
}

x_train

#Testing set
x_test = read.csv("X_test.csv") #read csv file
x_test
for(i in 1:ncol(x_train)){
  x_test[is.na(x_test[,i]), i] <- median(x_test[,i], na.rm = TRUE)
}

x_test

#write to csv
write.csv(x_train, "x_train_median.csv", row.names = FALSE)
write.csv(x_test, "x_test_median.csv", row.names = FALSE)

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

#By frequency

#NOT SUITABLE FOR THESE DATA SETS AS VALUES ARE double with sometimes more than 5 decimals.
#Maybe we could round all data to the closest integer and then choose the most frequent integer

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

#Hot deck imputation method (Nearest neighbor hot deck imputation) ALLOWED ?

update.packages()

install.packages("VIM")
library(VIM)

if (!requireNamespace("BiocManager", quietly = TRUE))
  install.packages("BiocManager")

BiocManager::install("impute")

#Using impute package

#KNN-imputation on x_train
x_train = read.csv("X_train.csv") #read the file
x_train_knned <- impute::impute.knn(as.matrix(x_train))
x_train <- x_train_knned[["data"]]
x_train

#KNN-imputation on x_test
x_test = read.csv("X_test.csv") #read the file
x_test_knned <- impute::impute.knn(as.matrix(x_test))
x_test <- x_test_knned[["data"]]
x_test

#write to csv
write.csv(x_train, "x_train_KNN.csv", row.names = FALSE)
write.csv(x_test, "x_test_KNN.csv", row.names = FALSE)

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