#------------------------------------------------------------------------------------------------------------------
#Step PRE: Some functions that is used later on in the mod.jointly.generate.binary.normal function algorithm
#and so on

#         Function1: closest element
#         returns whichever element of candidates vector is closest in abs value to x

closest = function(x, candidates) {
    return( candidates[ which.min( abs(candidates - x) ) ] )
}

#        Function2: binary-normal correlation bound ######
#        given parameters for 1 binary and 1 normal RV, return the maximum correlation

BN.rBound = function(p) {
    q = 1-p

    #compute upper bound
    hiBound = dnorm( qnorm(p) ) / sqrt(p*q)
    return( round(hiBound, 2) )
}

#       Function3: expand a matrix of slot_0 to the number of specified stages for time_invariant covariate setting
#       repeat each subject's entry in each row for obs number of times
expand_matrix = function(.matrix, .n.stage) {
    library(plyr)
    cat("Expanding a time invariant covariates to the number of specified stages\n")

    .n = nrow(.matrix)
    .expanded = matrix(c(NA), nrow = .n*.n.stage, ncol = ncol(.matrix) )

    adply(.matrix, 1, function(..subject, ..obs) {
        matrix(rep(..subject, ..obs), nrow = ..obs, byrow = TRUE)
    }, .n.stage)

}

#      FUNCTION4: UPPER TRI VEC:
#      turns matrix into vector of upper-triangular elements

upper_tri_vec = function(m) {
    v1 = as.vector( t(m) )
    keepElement = as.vector( t(upper.tri(m) ) ) #use transpose to avoid going by columns
    v2 = as.numeric( v1[keepElement] )
    return(v2)
}
#------------------------------------------------------------------------------------------------------------------
#Step 1: Creating the "Across" data

mod.generate.jointly.binary=function(no.rows,no.binary,prop.vec.binary,corr.vec.binary, adjust.corrs = TRUE){
    #Definition of the arguments are as follows:
    #no.rows=Number of subjects
    #no.bin=Number of binary variables (among these )
    #no.nor=Number of normally distributed variables
    #prop.vec.binary=Vector of marginal proportions for binary variables
    #mean.vec.nor=Vector of means for normal variables
    #var.nor=Vector of variances for normal variables
    #corr.vec.binary=Specified correlations among all variables
    #b=2*no.bin #b is double number of the total binary vars
    d=no.binary #d is the total dimension
    #adjust.corrs=T/F. If a correlation is out of bounds, should it
    # be adjusted to the closest feasible values?

    ############################################################
    #Important note 1: For convenience, binary variables are assumed
    #to come first, then normal variables follow
    #Important note 2: Correlations are specified in vector form,
    #rather than a matrix form. If the dimension is d, d*(d-1)/2
    #non-redundant correlation terms must be specified. The order
    #in which correlations are specified is based on the upper diagonal
    #elements. For example, if there are four variables (X1,X2,X3,X4),
    #corr.vec.binary is specified in the following form:
    #c(Corr(X1,X2),Corr(X1,X3),Corr(X1,X4),Corr(X2,X3),Corr(X2,X4),
    #Corr(X3,X4))
    #------------------------------------------------------------------------------------------------------------------
    #Step 1-1 Series of control statements to prevent obvious ARGUMENT
    #SPECIFICATION ERRORS:

    if ((no.rows<1)|(floor(no.rows)!=no.rows)){stop("Number of rows must be
                                                    an integer whose value is at least 1!\n")}
    if ((no.binary<1)|(floor(no.binary)!=no.binary)){stop("Number of binary variables
                                                 must be an integer whose value is at least 1!\n")}

    if ((min(prop.vec.binary)<=0)|(max(prop.vec.binary)>=1)){
        stop("Proportions for binary variables must be between 0 and 1!\n")}
    if (length(prop.vec.binary)!=no.binary){stop("Proportion vector
                                           is misspecified, dimension is wrong!\n")}

    if(length(corr.vec.binary)!=(d*(d-1)/2)){
        stop("Vector of correlations is misspecified, dimension is wrong!\n")}

    #------------------------------------------------------------------------------------------------------------------
    #Step 1-2:   Statements to check CORRELATION BOUND VIOLATIONS

    #Step 1-2-1: Form a correlation matrix from the specified correlation vector
    # this is equivalent to lower.tri.to.corr.mat function from BinNor package
    # that Converts a lower vector to a full correlation matrix
    sigma=diag(d)
    temp=1
    for(i in 1:(d-1)){
        for(j in (i+1):d){
            sigma[i,j]=sigma[j,i]=corr.vec.binary[temp]
            temp=temp+1
        }
    }
    #------------------------------------------------------------------------------------------------------------------

    #Step 1-2-1: Check if the specified correlation matrix is positive definite, if not
    #find the nearest positive definite matrix
    #This is equivalent to the function: compute.sigma.star from BinNor package that
    #Computes intermediate (tetrachoric) correlation matrix

    if(is.positive.definite(sigma)==FALSE)
    {sigma=make.positive.definite(sigma)
    print("Specified correlation matrix is not positive definite,")
    print("Algorithm will be using the closest positive definite matrix!")}

    diag(sigma)=1

    p=prop.vec.binary
    q=1-p
    #------------------------------------------------------------------------------------------------------------------

    #Step 1-2-2: Checks if the correlation terms are within the feasible range
    #This is equivalent to the function: validation.range from BinNor package that
    #Checks if the correlation terms among binary-binary, binary-normal
    #and normal-normal combinations.are within the feasible range

    #Check if the correlations for binary-binary combinations are
    #in the feasible range

    #Boundaries for BB =[max(-sqrt((pi*pj)/(qi*qj)),-sqrt((qi*qj)/(pi*pj))),
    #min(sqrt((pi*qj)/(qi*pj)),sqrt((qi*pj)/(pi*qj)))]
    L_BB=diag(no.binary)
    U_BB=diag(no.binary)

    for(i in 1:no.binary){
        for(j in 1:no.binary){
            if (i!=j) L_BB[i,j]=L_BB[j,i]=max(-sqrt((p[i]*p[j])/(q[i]*q[j])),
                                              -sqrt((q[i]*q[j])/(p[i]*p[j])))
            if (i!=j) U_BB[i,j]=U_BB[j,i]=min(sqrt((p[i]*q[j])/(q[i]*p[j])),
                                              sqrt((q[i]*p[j])/(p[i]*q[j])))
        }
    }

    for(i in 1:no.binary){
        for(j in 1:no.binary){
            if(sigma[i,j]<L_BB[i,j] | sigma[i,j]>U_BB[i,j]) {
                if (!adjust.corrs) {
                    # if user does not want to adjust correlations, give error
                    stop("BB corrrelation [", i,",",j,"] is out of range! Specify a feasible number!")
                } else {
                    #adjust correlation to the closest feasible value
                    cat( c("BB corrrelation [", i,",",j,"],", sigma[i,j], ", is out of range! Used closest feasible correlation instead\n"))
                    sigma[i,j] = sigma[j,i] = closest(sigma[i,j], c( L_BB[i,j], U_BB[i,j] ) )
                }
            }
        }
    }

    #Compute the biserial correlations for binary-normal combinations and
    #check if they are in the feasible range

    #temporary matrix
    #BN_temp=sigma

    # replace the BN values in BN_temp with the corresponding phi values correlation btw binary and normal
    #for(i in (no.binary+1):d){
        #for(j in 1:no.binary){
            #BN_temp[i,j]=BN_temp[i,j]/(dnorm(qnorm(p[j]))/sqrt(p[j]*q[j]))
        #}
    #}

    #for(i in (no.binary+1):d){
        #for(j in 1:no.binary){
            #if (BN_temp[i,j]< -1 | BN_temp[i,j]> 1) {

                #if (!adjust.corrs) {q
                    # if user does not want to adjust correlations, give error
                    #stop("BN correlation [", i,",",j,"] is out of range! Specify a feasible number!")
                #} else {
                    #adjust correlation to the closest feasible value
                    #BN_temp[i,j] = closest(BN_temp[i,j], c(-1, 1))

                #}
           # }
        #}
   # }

    #keep the BN part of BN_temp matrix
    #BN=BN_temp[(no.binary+1):d,1:no.binary]

    #Compute the tetrachoric correlations for binary-binary combinations

    # create sigmaBB matrix by converting BB part of sigma into polychoric correlations
    sigmaBB=diag(no.binary)
    for(i in 1:no.binary){
        for(j in 1:no.binary){
            if (i > j) {
                sigmaBB[i,j] = sigmaBB[j,i] = phi2poly( sigma[i,j] ,p[i],p[j])
                #force symmetry because phi2poly is an imperfect optimization process with rounding error
            }
            #########################################################################
            ###### NOTE: ABOVE ROUNDING OF SIGMA ENTRY IS A LITTLE SKETCH!!!!! ######
            #########################################################################

        }
    }

    #Biserial correlations for binary-normal combinations
    #sigmaBN=BN

    #Combine all three types (binary-binary, binary-normal, normal-normal)
    #of correlations to construct the overall correlation matrix
    #(Step 7 in the algorithm)
    sigma_new=sigma
    sigma_new[1:no.binary,1:no.binary]=sigmaBB
    #sigma_new[(no.binary+1):d,1:no.binary]=sigmaBN
    #sigma_new[1:no.binary,(no.binary+1):d]=t(sigmaBN)

    #Check if the final correlation matrix is positive definite, if not
    #find the nearest positive definite matrix (Step 8 in the algorithm)

    if(is.positive.definite(sigma_new)==FALSE) {
        sigma_new=make.positive.definite(sigma_new)
        print("Final correlation matrix is not positive definite,")
        print("Algorithm will be using the closest positive definite matrix!")
    }
    #------------------------------------------------------------------------------------------------------------------

    #Step 1-3: Generate multivariate normal data (Step 9 in the algorithm)
    data=rmvnorm(no.rows,mean=rep(0,d), sigma=sigma_new)

    #------------------------------------------------------------------------------------------------------------------
    #
    ##
    ###
    ####
    ##### shouldn't be abs(data[i,j])<=qnorm(1-p[j])) ???? check BinNOR
    #Step 1-3-1: Obtain binary variables by the thresholds determined by marginal proportions

    for(i in 1:no.rows){
        for(j in 1:no.binary){
            if(data[i,j]<=qnorm(1-p[j])) data[i,j]=0 else data[i,j]=1
        }
    }

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

    #------------------------------------------------------------------------------------------------------------------
    #Step 1-3-3:    Go back to the original scale for normal variables by reverse centering and

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

    #step 1-4: Output is the data matrix!
    diag(sigma_new)=1
    return(list(data,sigma_new))
    #return(data)
    }


obrisi = function(podatki, hc = TRUE, od = 2, do = NULL) {
  n = nrow(podatki)
  if (is.null(do)) {
    do = n - 1
  }

  razdalje = dist(podatki)

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

  k.obrisi
}

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

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

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


#' Compute payment plan
#'
#' @param balance current balance or principal
#' @param income adjusted gross income
#' @param rate interest rate on loan
#' @param years number of years to calculate. Most debt forgiven after 25 years.
#' @param plan which payment plan to use
#' @param subsidized whether the government will help subsidze accrued interest
#' @param income_increase Expected increase in income per year.
#' @export
compute_payments <- function(balance, income, rate, years,
                             plan = c("repaye"),
                             subsidized = FALSE,
                             income_increase = 0.05,
                             family_size = 1
                             ) {
  # inputs
  plan <- match.arg(plan)
  interest <- 0
  repaye_rate <- 0.1

  df <- vector("list", years)

  # compute loan payments over time
  for (yr in seq_len(years)) {
    # calculate payment per month
    ppm <- compute_ppm(income, family_size, repaye_rate)

    # payment_per_year - interest_accrued
    net_payment <- compute_net_payment(balance, rate, ppm)

    # subsidized interest
    if (plan == "repaye") {
      govt_help <- ifelse(subsidized*(yr <= 3), 1, 0.5)
    } else {
      govt_help <- 0
    }
    subsidized_interest <- compute_subsidized_interest(net_payment, govt_help)

    # new balances. pay off the interest first!
    if (net_payment < 0) {
      # interest more than payment
      payment_to_interest <- -subsidized_interest
      payment_to_balance <- 0
    } else {
      # payment more than interest
      payment_to_interest <- min(interest, net_payment)
      payment_to_balance <- net_payment - payment_to_interest
    }

    new_balance <- balance - payment_to_balance
    new_interest <- interest - payment_to_interest

    # update list
    df[[yr]] <- tibble::tibble(
      year = yr,
      principal_before = balance,
      interest_per_month = balance*rate/12,
      payment_per_month = ppm,
      govt_help = govt_help,
      principal_after = new_balance,
      interest_accrued = new_interest
    )

    # update balance
    balance <- new_balance
    interest <- new_interest

    # income increase causes payment increase
    income <- income*(1 + income_increase)
  }

  # bind list
  dplyr::bind_rows(df) %>%
    dplyr::filter(!!rlang::sym("principal_before") >= 0) %>%
    dplyr::mutate(principal_after = pmax(0, !!rlang::sym("principal_after")))
}

#' Compute the net yearly payment
#'
#' Subracts student payment from accrued interest
#' @param balance current balance
#' @param rate interest rate
#' @param ppm payment per month
#'
#' @keywords internal
compute_net_payment <- function(balance, rate, ppm) {
  12*ppm - balance*rate
}

#' Compute the subsidized interest
#'
#' Interest may be subsidized depending on your repayment plan.
#'
#' @param net_payment net payment
#' @param govt_help percentage of subsidzation the government will provide
compute_subsidized_interest <- function(net_payment, govt_help) {
  if (net_payment >= 0) return(0)
  -net_payment*(1 - govt_help)
}

compute_poverty_line <- function(family_size) {
  n <- nrow(poverty)
  if (family_size <= n) {
    poverty[["poverty_line"]][family_size]
  } else {
    poverty[["poverty_line"]][n] + 4320*(family_size - n)
  }
}

#' Payments per month
#'
#' @param income adjusted gross income
#' @param family_size members in family including self, spouse, and dependents
#' @param repaye_rate REPAYE max payment rate is 10% of adjusted income
compute_ppm <- function(income, family_size, repaye_rate = 0.1) {
  poverty_line <- compute_poverty_line(family_size)
  ppm <- (income - 1.5*poverty_line)*repaye_rate/12
  max(ppm, 0)
}


metrop.rwalker.proposal.fun <- function(theta){
  # finding the right scaling factor is more of an art than science
  # or try and error to look for the best fit on acceptance %, ideally .234
  # good starting point 2.38/sqrt(N.dimensions)
  # looking to replace rnorm with multivariate version mvrnorm ?

  n.theta  <- length(theta)
  scale.sd <- round(2.38/sqrt(n.theta), 2)
  return(rnorm(n=n.theta, mean=theta, sd=rep(scale.sd, n.theta)))
}

hamiltonian.proposal.fun <- function(theta){
  #forget it.. it is a good theory
  # H(q, p) = U(q) + K(p) .. the potential and kinetic energy
  # simulate data by the way of the physical system moves than a random walk
  # faster convergence
  # more parameters to worry: epsilon, M, t, L
  # not to mention the change of proposal..
  #   U(q) = -log[pi(q) * L(q|D)]
  # hmc proposal and actual simulation is tight up
  #  condition:
  #     runif(1) < exp(-U(q*)+U(q)-K(p*)+K(p))
  # no to mention the painful gradient (log likelihood function)
  # there are research work being done on the gradient free hamiltonian
  # don't quote on me, it is still an exciting new area
  #
  # good read, I'll leave the work for others :)
  # indeed, please refer to hmc.r
  #
  # for now, it does exactly the random walk if hmc = TRUE

  return(theta+rnorm(length(theta), sd=2.38))
}

# Metroplis Hasting Monte Carlo Simulation
# currently not support thinning nor multiple chains
# fun .......... the logged posterior sampling function
# theta.init ... initial parameter(s) value
# nmc .......... number of iterations for the chain
# nbi .......... number of burn-ins
# hmc .......... reserved for future Hamiltonian or RWHMC implementation
mcmc <- function(fun, theta.init, nmc, nbi, hmc = FALSE, ...) {

  iterations <- nmc + nbi
  chain <- array(dim = c(iterations, length(theta.init)))
  chain[1, ] <- theta.init

  # choose the proposal function
  if(hmc){
    propose <- hamiltonian.proposal.fun          #hamiltonian
  }else{
    propose <- metrop.rwalker.proposal.fun       #metroplis
  }

  for(i in 1:(iterations-1)) {
    proposal <- propose(chain[i, ])
    p <- exp(fun(proposal, ...) - fun(chain[i, ], ...))

    if(runif(1) < p) {
      chain[i+1, ] <- proposal       #accept
    }else{
      chain[i+1, ] <- chain[i, ]     #reject
    }
  }

  return(chain[-(1:nbi), ])
}


DySyn <- function(ts, measure){

  MF <- seq(0.1,0.9,0.2)
  result <- NULL
  rD <- NULL

  for(ti in 1:length(MF)){
    scores <- MoSS(1000, 0.5, MF[ti])
    test.p <- scores[scores[,3]==1,1]
    test.n <- scores[scores[,3]==2,1]

    ifelse(measure=="sord", rQnt <- DySyn_SORD(test.p, test.n, ts), rQnt <- DySyn_DyS(test.p, test.n, ts, measure))

    rD <- c(rD, rQnt[[2]])
    result <- c(result, rQnt[[1]][1])

  }
  result <- round(result[which.min(rD)],2)
  result <- c(result, 1-result)
  return(list(result, min(rD)))
}

DySyn_DyS <- function(p.score, n.score, test, measure="hellinger"){

  alpha <- seq(0,1,by=0.01)

  b_sizes <- c(seq(2,20,2),30)

  result <- NULL

  for(hi in 1:length(b_sizes)){

    Sty_1 <- getHist(p.score, b_sizes[hi])
    Sty_2 <- getHist(n.score, b_sizes[hi])
    Uy    <- getHist(test, b_sizes[hi])

    vDist <- NULL
    vDistAll <- NULL

    f <- function(x){
      return(DySyn_distance(rbind((Sty_1*x)+ (Sty_2*(1-x)), Uy), method = measure))
    }

    result <- c(result, TernarySearch(0, 1, f, 1e-2))
    vDistAll <- c(vDistAll, f(result))
  }

  result <- median(result)
  result <- c(result, 1 - result)
  names(result) <- c("1", "2")
  return(list(round(result,2),vDistAll[order(vDistAll)[1]]))

}

PNTDiff <- function(pos, neg, test, pos_prop){
  p_w <- pos_prop / length(pos)
  n_w <- (1 - pos_prop) / length(neg)
  t_w <- -1 / length(test) # repare no -1 (menos um) !!

  # Cria listas com (valor da observacao), peso [fixo pra cada lista])
  #p <- list(map(lambda x: (x, p_w), pos))
  p <- cbind(pos, rep(p_w, length(pos)))
  #n <- list(map(lambda x: (x, n_w), neg))
  n <- cbind(neg, rep(n_w, length(neg)))
  #t <- list(map(lambda x: (x, t_w), test))
  t <- cbind(test, rep(t_w, length(test)))

  # Concatena numa lista soh e ordena pelos valores de obervacao
  #v <- sorted(p + n + t, key = lambda x: x[0])
  v <- rbind(p, n, t)
  v <- v[order(v[,1]),]

  #acc <- v[0][1] # inicializa acc com o peso do primeiro elemento
  acc <- v[1,2]
  total_cost <- 0

  # comeca a iterar no SEGUNDO elemento (python eh 0-indexado)
  for( i in 2:nrow(v)){
    cost_mul <- v[i,1] - v[i - 1, 1] # custo da movimentacao
    total_cost <- total_cost + abs(cost_mul * acc) #movimenta o que esta acumulado
    acc <- acc + v[i,2]
  }

  return(total_cost)
}

DySyn_SORD <- function(p.score, n.score, test){

  alpha <- seq(0,1,by=0.01)
  vDist <- NULL
  vDistAll <- NULL
  f <- function(x){
    return(PNTDiff(p.score, n.score, test, x))
  }

  result <- TernarySearch(0, 1, f, 1e-5)
  vDist  <- f(result)

  result <- c(result, 1 - result)
  names(result) <- c("1", "2")
  return(list(round(result,2), vDist))

}


# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements.  See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to You under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

### fixed seed to allow repeatable results
set.seed(63)

### Original driver data. This will force our final results to be constrained
### to a 3-dimensional manifold
dim = 4
hidden = 10
embed = 15
raw.train = matrix(rnorm(dim*10000), ncol=dim, nrow=10000)
raw.test = matrix(rnorm(dim*10000), ncol=dim)

### Transformation to final data. This is a simple neural network kind of thing.
w1 = matrix(rnorm(dim*hidden), nrow=dim)
w2 = matrix(rnorm(hidden*embed), nrow=hidden)

sig = function(x) {1/(1+exp(-x)) - 0.5}
xform = function(input, w1, w2) {
    sig(input %*% w1) %*% w2
}

### The final data is 8 dimensional, but only looks complicated
train.data = xform(raw.train, w1, w2)
test.data = xform(raw.test, w1, w2)

### The encoder simply finds the nearest centroids
closest = function(v, k) {
    ## This is same as (centers - v)^2 but works with matrix centers and vector v
    ## numerical stability is probably poor
    distances = rowSums(k$centers^2) + sum(v^2) - 2 * k$centers %*% v
    close = min(distances)
    which(distances == close)
}

encode = function(data, k) {
    apply(data, 1, function(v){closest(v, k)})
}

decode = function(kx, k) {
    as.matrix(k$centers[kx,])
}

reconstruction.error = function(data, k) {
    mean(sqrt(rowSums((data - decode(encode(data, k), k))^2)))
}

k.10 = kmeans(train.data, centers=10, nstart=10, iter.max=50)
x.10 = reconstruction.error(train.data, k.10)
y.10 = reconstruction.error(test.data, k.10)
print(10)

k.20 = kmeans(train.data, centers=20, nstart=10, iter.max=50)
x.20 = reconstruction.error(train.data, k.20)
y.20 = reconstruction.error(test.data, k.20)
print(20)

k.50 = kmeans(train.data, centers=50, nstart=10, iter.max=50)
x.50 = reconstruction.error(train.data, k.50)
y.50 = reconstruction.error(test.data, k.50)
print(50)

k.100 = kmeans(train.data, centers=100, nstart=10, iter.max=50)
x.100 = reconstruction.error(train.data, k.100)
y.100 = reconstruction.error(test.data, k.100)
print(100)

k.200 = kmeans(train.data, centers=200, nstart=10, iter.max=50)
x.200 = reconstruction.error(train.data, k.200)
y.200 = reconstruction.error(test.data, k.200)
print(200)

k.500 = kmeans(train.data, centers=500, nstart=10, iter.max=50)
x.500 = reconstruction.error(train.data, k.500)
y.500 = reconstruction.error(test.data, k.500)
print(500)

k.1000 = kmeans(train.data, centers=1000, nstart=5, iter.max=50)
x.1000 = reconstruction.error(train.data, k.1000)
y.1000 = reconstruction.error(test.data, k.1000)
print(1000)

k.2000 = kmeans(train.data, centers=2000, nstart=3, iter.max=50)
x.2000 = reconstruction.error(train.data, k.2000)
y.2000 = reconstruction.error(test.data, k.2000)
print(2000)

points.fig = function() {
    plot(c(10,20,50,100,200,500,1000, 2000),
     c(x.10, x.20, x.50, x.100, x.200, x.500, x.1000, x.2000),
     ylab="Error", xlab="Centroids", type='b',
     ylim=c(0,2), lwd=2,
     main="Reconstruction error for random points"
     )

    lines(c(10,20,50,100,200,500,1000,2000),
          c(y.10, y.20,  y.50,  y.100,  y.200,  y.500,  y.1000,  y.2000),
          col='red', lwd=2, type='b')

    legend(1000, 1.9, legend=c("Training data", "Held-out data"), col=c("black", "red"), pch=21, lwd=2)
}

cube.root.fig = function() {
    x = data.frame(
        k=c(10, 20,  50,  100,  200,  500,  1000,  2000),
        test=c(y.10, y.20,  y.50,  y.100,  y.200,  y.500,  y.1000,  y.2000),
        train=c(x.10, x.20,  x.50,  x.100,  x.200,  x.500,  x.1000,  x.2000))
    x$rootK = x$k^(1/3)
    x$inv.train = 1/x$train
    x$inv.test = 1/x$test
    m.train = lm(inv.train ~ rootK, x)
    m.test = lm(inv.test ~ rootK, x)

    plot(train~k,x,type='b', xlab="k", ylab="Error", main="Error is approximately cube root of k",
         lwd=2, ylim=c(0,2))
    lines(test~k,x,type='b', col='darkgray', lwd=2)
    lines(x$k,1/predict(m.train, newdata=data.frame(rootK=exp(log(x$k)*0.33333))),
          lwd=2, lty=4, col='red')
    lines(x$k,1/predict(m.test, newdata=data.frame(rootK=exp(log(x$k)*0.33333))),
          lwd=2, lty=4, col='red')
    legend(1000, 1.8, legend=c("Training data", "Test data", "Cube root model"), col=c("black", "darkgray", "red"), pch=21, lwd=2)
}

pdf(file="points.pdf", width=5, height=5)
points.fig()
dev.off()

png(file="images/points.png", width=400, height=400, pointsize=12)
points.fig()
dev.off()

pdf(file="cube-root.pdf", width=5, height=5)
cube.root.fig()
dev.off()

png(file="images/cube-root.png", width=400, height=400, pointsize=12)
cube.root.fig()
dev.off()


##Ядерные функции. По умолчанию используется первая.
nuclearFunction<-function(z, x = 1, r = 2, s = 3) {
  if (x == 1) {
    p<-(1-(z^r))^s
  }
  else if (x == 2) {
    p<-exp(-s*(z^r))
  }
  else if (x == 3) {
    p<-1/(s*(z^r)+1)
  }
  else if (x == 4) {
    p<-1/(z^s)
   }
  else
    p <- 0
  return(p)
}

f<- function(x, y)
{
  z<-function(x)
    return(-(1/((x-1)^2 + 0.2))-(1/(2*(x-2)^2 + 0.15)) -(1/(3*(x-3)^2 + 0.3)))
  return(z(x)+z(y))
}

Ruban <- function(x, deltaX, f, lower, upper, n = 500, e = 0.001, M = 1000, y = 1, q = 2, numberOfNuclearFunc = 1, r = 2, s = 100) {
  if (length(x)!= length(deltaX) || length(x)!= length(lower)  || length(x)!= length(upper))
    stop("Ошибка, не соблюдение размерности у входящих параметров (x, deltaX, upper, lower)!")
  if (n<0)
    stop("Ошибка, количество пробных точек должно быть больше 0!")
  if (e<0)
    stop("Ошибка, константа точности не должна быть меньше 0!")
  if (M<0)
    stop("Ошибка, максимальное количество итераций не должно быть меньше 0!")
  if (y<0)
    stop("Ошибка, (y) не должен быть меньше 0!")
  k<-1 ##Будем использовать для проверки первого критерия останова - превышения числа итераций
  testX<-matrix(0, n, length(x)) ## В матрицу будут записываться пробные точки.
  ## Где n - количество пробных точек,
  ## length(x) - количество координатых направлений
  functionValues<-rep(0, n) ## А эта матрица содержит значения функции в пробных точках
  uValues<-matrix(0, n, length(x)) ##В этой матрице будут храниться значения u для генерации пробных точек
  p<-rep(0, n) ##Ядра
  pNorm<-rep(0, n) ##нормированные ядра
  allX<-matrix(0, M, length(x)) ##Сюда записываем все X
  allX[1,]<-x
  allResults<-f(x[1],x[2]) ##Сюда записываем все результаты. Если число циклов превысит M, то мы выберем из всех результатов наименьший
  while(k<M) {
    pastIterationX<-x ##Запоминаем текущую точку, мы будем использовать ее для условия выхода
    plot(pastIterationX[1], pastIterationX[2], xlim=c(lower[1],upper[1]), ylim=c(lower[2],upper[2]), col="red")
    ##Шаг первый - инициализация пробных точек и расчет значений функции в них:
    for (i in 1:n) {
      for (j in 1:length(x))
        uValues[i,j]<-runif(1, 0, 1)*2 - 1 ##Генерируем u от -1 до 1
      testX[i,]<- x + deltaX * uValues[i,]  ##Генерируем пробную точку
      functionValues[i] <- f(testX[i,1],testX[i,2]) ##Находит значение функции в этой точке(f - какая-то функция)
      points(testX[i,1],testX[i,2], col="blue")
    }
    gmin<-rep(0, n)
    ##Шаг второй - рассчитываем ядра и нормированные ядра:
    for (i in 1:n)
      gmin[i]<-(functionValues[i] - min(functionValues)) / (max(functionValues) - min(functionValues))
    for(i in 1:n) ##Вычисляем ядра
      p[i]<-nuclearFunction(x = numberOfNuclearFunc, z = gmin[i], r=r, s=s)
    for (i in 1:n) ##Вычисляем нормированные ядра
      pNorm[i]<-p[i]/sum(p)
    ##Шаг третий - вычисляем новый центр прямоугольника и его длину:
    for (i in 1:length(x))
      x[i]<-x[i] + deltaX[i] * sum(sapply(1:n, function(x){uValues[x,i]*pNorm[x]}))
    print("---------------")
    cat("Результат ", k, "итерации: x=", x,"\n")
    if (x[1]<lower[1])
      x[1]<-lower[1]
    if (x[2]<lower[2])
      x[2]<-lower[2]
    if (x[1]>upper[1])
      x[1]<-upper[1]
    if (x[2]>upper[2])
      x[2]<-upper[2]
    for (i in 1:length(x))
      deltaX[i]<-y*deltaX[i] * ((sum(sapply(1:n, function(x){(abs(uValues[x,i])^(q)) * pNorm[x]})))^(1/q))
    cat("deltaX=", deltaX, "\n")
    k<-k+1 ##Увеличиваем счетчик итераций
    allX[k,]<-x
    allResults<-c(allResults,f(x[1],x[2]))
    flag <- (max(deltaX) <= e)
    if (flag == TRUE)
      break
    #if (sqrt(sum(deltaX^2)) < e)
    #  break
  }
  cat("Сделано шагов: ", k, "\n")
  return(allX[which.min(allResults),])
}


# 4. faza: Analiza podatkov
source('lib/libraries.r', encoding = 'UTF-8')

#Napoved prirastka za države z največjim in najnižjim BDP

najrazvitejse <- neto_tabela %>% filter(Država %in% najvecji.bdp$Država)
najmanj_razvite <- neto_tabela %>% filter(Država %in% najnizji.bdp$Država)
najmanj_razvite[is.na(najmanj_razvite)] <- 0

najrazvitejse <- najrazvitejse %>% group_by(Leto) %>% summarise(Neto = sum(Neto))
najmanj_razvite <- najmanj_razvite %>% group_by(Leto) %>% summarise(Neto = sum(Neto))

fit <- lm(data=najrazvitejse, Neto ~ Leto +I(Leto^2))
leta <- data.frame(Leto=seq(2011, 2021))
predict(fit, leta)
napoved.prirastka1 <- mutate(leta, Neto=predict(fit, leta))

podatki <- lm(data=najmanj_razvite, Neto ~ Leto)
cas <- data.frame(Leto=seq(2011, 2021))
predict(podatki, cas)
napoved.prirastka2 <- mutate(cas, Neto=predict(podatki, cas))

graf.napovedi.prirastka1 <- ggplot(data=najrazvitejse, aes(x=Leto, y=Neto/1000)) +
  geom_smooth(method = "lm", formula = y ~ x + I(x^2), fullrange = TRUE) +
  geom_point(data=napoved.prirastka1 %>% filter(Leto>2016)) +
  labs(title = 'Napoved prirastka za države z največjim BDP') +
  geom_point(color = 'red') +
  ylab('Neto prirastek v tisočih')

graf.napovedi.prirastka2 <- ggplot(data=najmanj_razvite, aes(x=Leto, y=Neto/1000)) +
  geom_smooth(method = "lm", formula = y ~ x , fullrange = TRUE) +
  geom_point(data=napoved.prirastka2 %>% filter(Leto>2016)) +
  labs(title = 'Napoved prirastka za države z najmanjšim BDP') +
  geom_point(color='red') +
  ylab('Neto prirastek v tisočih')


#######################################################################################
# Impact of Gestational Diabetes Mellitus Screening Strategies on Perinatal Outcomes:
# a Simulation Study
# Coded by: Isaias Prestes; reviewed by Maicon Falavigna
# Performed on R version 2.11.1
# Packages required: hdrcde, boa
# Date: 01/06/12
#######################################################################################

# Simulation study for screening for gestational diabetes WHO

# Settings
n <- 1000000 ;
alfa <- 0.05

# The Beta distribution with parameters shape1 = a and shape2 = b has density
#
# G(a+b)/(G(a)G(b))x^(a-1)(1-x)^(b-1)
#
# for a > 0, b > 0 and 0 = x = 1 where the boundary values at x=0 or x=1 are defined as by continuity (as limits).
# The mean is a/(a+b) and the variance is ab/((a+b)^2 (a+b+1)).

# Given a and b, return a array with mean, variance, deviation, lower endpoint and upper endpoint of the 100(1-alfa)% confidence interval for Beta distribution.
beta.parametros <- function(a, b, alfa, digits = 5) {
	media <- a / (a+b)
	variancia <- (a * b)/ ( (a+b)^2 * (a+b+1) )
	liminf <- qbeta(alfa/2, a, b)
	limsup <- qbeta(1 - alfa/2, a, b)
	return( round( c("Mean"=media,"Var"=variancia,"SD"=variancia^.5, "LL"=liminf, "UL"=limsup) , digits=5) )
}
# Example :
beta.parametros(3, 6, alfa)

# Set RNG seed
set.seed(37589411)

# Values for PWHO
# PWHO <- seq(0.05,0.15,0.01)
PWHO <- 0.05

# Simulated parameters values

# LGA Birth (LGA)
LGA_Iwho_negative <- rbeta(n, 1.5*900, 1.5*9100 ) ; c <- 1.5; beta.parametros(c*900, 9100*c, alfa)
LGA_logRRwho <- rnorm(n, 0.4256, 0.0494) ;		# Distribution for log(RR)
LGA_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # approximated solution
LGA_logRPiadpsg <- rnorm(n, 0.4055, 0.0730) ;		# Distribution for log(RP)
LGA_logRRtreatment <- rnorm(n, -0.6095, 0.1245) ;	# Distribution for log(RR)
LGA_logRRiadpsg <- rnorm(n, 0.5503, 0.1558) ;		# Distribution for log(RR)

# Preeclampsia (PE)
PE_Iwho_negative <- rbeta(n, 22.5, 477.5 ) ; c <- 0.5; beta.parametros(c*45, c*955, alfa)
PE_logRRwho <- rnorm(n, 0.5260, 0.1288) ;		# Distribution for log(RR)
PE_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # approximated solution
PE_logRPiadpsg <- rnorm(n, 0.4055, 0.0730) ;		# Distribution for log(RP)
PE_logRRtreatment <- rnorm(n, -0.4903, 0.1413) ;	# Distribution for log(RR)
PE_logRRiadpsg <- rnorm(n, 0.5374, 0.1108) ;		# Distribution for log(RR)

# Caesarean section (CS)
CS_Iwho_negative <- rbeta(n, 11.7475, 51.7525 ) ; beta.parametros(11.7475, 51.7525, alfa)
CS_logRRwho <- rnorm(n, 0.3144, 0.0508) ;		# Distribution for log(RR)
CS_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # approximated solution
CS_logRPiadpsg <- rnorm(n, 0.4055, 0.0730) ;		# Distribution for log(RP)
CS_logRRtreatment <- rnorm(n, -0.1100, 0.0797) ;		# Distribution for log(RR)
CS_logRRiadpsg <- rnorm(n, 0.2086, 0.1035) ;		# Distribution for log(RR)

# Set simulated block
set.idiaf <- function( PWHO, Iwho_negative, logRRwho, Ptreatment, logRRtreatment, logRPiadpsg, logRRiadpsg) {
	IDIAF <- ( ( PWHO * Iwho_negative * exp(logRRwho) ) ) + ( ( 1 - PWHO ) * Iwho_negative ) / ( (1 - ( PWHO * exp(logRPiadpsg) ) ) + ( exp(logRRiadpsg) * PWHO * exp(logRPiadpsg) ) )
	return(IDIAF)
}

# Functions for model simulation
simula.nao.rastrear <- function ( n , PWHO, Iwho_negative, logRRwho, Ptreatment, logRRtreatment, logRPiadpsg, logRRiadpsg) {
	Iwho_positive <- Iwho_negative * exp(logRRwho) # Iwho_positive = Iwho_negative * RRwho

	ans <- 	(
				( PWHO * Iwho_positive ) + ( ( 1 - PWHO ) * Iwho_negative )
			)

	return(ans)
}

simula.who <- function ( n , PWHO, Iwho_negative, logRRwho, Ptreatment, logRRtreatment, logRPiadpsg, logRRiadpsg) {
	Iwho_positive <- Iwho_negative * exp(logRRwho)

	ans <- 	(
				( ( 1 - PWHO ) * Iwho_negative ) +
				( PWHO * ( 1 - Ptreatment ) * Iwho_positive ) +
				( PWHO * Ptreatment * exp(logRRtreatment) * Iwho_positive )
			)

	return(ans)
}

simula.iadpsg <- function ( n , PWHO, Iwho_negative, logRRwho, Ptreatment, logRRtreatment, logRPiadpsg, logRRiadpsg) {

	Piadpsg <- PWHO * exp(logRPiadpsg)	# Piadpsg = Pwho * PRiadpsg

	Iiadpsg_negative <- ( ( PWHO * Iwho_negative * exp(logRRwho) ) +
						( ( 1 - PWHO) * Iwho_negative ) ) / ( ( ( 1 - (PWHO * exp(logRPiadpsg) ) ) )  +
						( PWHO * exp(logRPiadpsg) * exp(logRRiadpsg) ) )

	Iiadpsg_positive <- Iiadpsg_negative * exp(logRRiadpsg)

	ans <- 	(
				( ( 1 - Piadpsg ) * Iiadpsg_negative ) +
				( Piadpsg * Iiadpsg_positive * Ptreatment * exp(logRRtreatment) ) +
				( Piadpsg * Iiadpsg_positive * ( 1 - Ptreatment ) )
			)

	return(ans)
}

# Looping PWHO values
datasummary <- array(,10)
datasummary.diff <- array(,10)
datasummary.table.diff <- array(,3)

names(datasummary) <- c("PWHO", "Strategy", "Min.",    "1st Qu.", "Median",  "Mean",    "3rd Qu.", "Max.")
names(datasummary.diff) <- c("PWHO", "Strategy", "Min.",    "1st Qu.", "Median",  "Mean",    "3rd Qu.", "Max.")

for ( i in PWHO ) {
	arrayPWHO <- rep(i, n)
	# Compute values for each screening strategies
	resultados.IADPSG.LGA <- simula.iadpsg(  n , arrayPWHO, LGA_Iwho_negative, LGA_logRRwho, LGA_Ptreatment, LGA_logRRtreatment, LGA_logRPiadpsg, LGA_logRRiadpsg)
	resultados.IADPSG.PE <- simula.iadpsg(  n , arrayPWHO, PE_Iwho_negative, PE_logRRwho, PE_Ptreatment, PE_logRRtreatment, PE_logRPiadpsg, PE_logRRiadpsg)
	resultados.IADPSG.CS <- simula.iadpsg(  n , arrayPWHO, CS_Iwho_negative, CS_logRRwho, CS_Ptreatment, CS_logRRtreatment, CS_logRPiadpsg, CS_logRRiadpsg)

	resultados.NR.LGA <- simula.nao.rastrear(  n , arrayPWHO, LGA_Iwho_negative, LGA_logRRwho, LGA_Ptreatment, LGA_logRRtreatment, LGA_logRPiadpsg, LGA_logRRiadpsg)
	resultados.NR.PE <- simula.nao.rastrear(  n , arrayPWHO, PE_Iwho_negative, PE_logRRwho, PE_Ptreatment, PE_logRRtreatment, PE_logRPiadpsg, PE_logRRiadpsg)
	resultados.NR.CS <- simula.nao.rastrear(  n , arrayPWHO, CS_Iwho_negative, CS_logRRwho, CS_Ptreatment, CS_logRRtreatment, CS_logRPiadpsg, CS_logRRiadpsg)

	resultados.WHO.LGA <- simula.who(  n , arrayPWHO, LGA_Iwho_negative, LGA_logRRwho, LGA_Ptreatment, LGA_logRRtreatment, LGA_logRPiadpsg, LGA_logRRiadpsg)
	resultados.WHO.PE <- simula.who(  n , arrayPWHO, PE_Iwho_negative, PE_logRRwho, PE_Ptreatment, PE_logRRtreatment, PE_logRPiadpsg, PE_logRRiadpsg)
	resultados.WHO.CS <- simula.who(  n , arrayPWHO, CS_Iwho_negative, CS_logRRwho, CS_Ptreatment, CS_logRRtreatment, CS_logRPiadpsg, CS_logRRiadpsg)

	resultado.final <- data.frame(
		"PWHO" = arrayPWHO,
		"NR.LGA" = resultados.NR.LGA,
		"NR.PE" = resultados.NR.PE,
		"NR.CS" = resultados.NR.CS,
		"WHO.LGA" = resultados.WHO.LGA,
		"WHO.PE" = resultados.WHO.PE,
		"WHO.CS" = resultados.WHO.CS,
		"IADPSG.LGA" = resultados.IADPSG.LGA,
		"IADPSG.PE" = resultados.IADPSG.PE,
		"IADPSG.CS" = resultados.IADPSG.CS
		)

	write.csv2( resultado.final , paste("table_data_PWHO_", i,".csv", sep="") )

	# Compute differences
	Delta.NR.WHO.LGA <- resultados.NR.LGA  -  resultados.WHO.LGA
	Delta.NR.IADPSG.LGA <- resultados.NR.LGA  -  resultados.IADPSG.LGA
	Delta.WHO.IADPSG.LGA <- resultados.WHO.LGA - resultados.IADPSG.LGA

	Delta.NR.WHO.PE <- resultados.NR.PE  -  resultados.WHO.PE
	Delta.NR.IADPSG.PE <- resultados.NR.PE  -  resultados.IADPSG.PE
	Delta.WHO.IADPSG.PE <- resultados.WHO.PE - resultados.IADPSG.PE

	Delta.NR.WHO.CS <- resultados.NR.CS  -  resultados.WHO.CS
	Delta.NR.IADPSG.CS <- resultados.NR.CS  -  resultados.IADPSG.CS
	Delta.WHO.IADPSG.CS <- resultados.WHO.CS - resultados.IADPSG.CS

	# Compute p-values empirical # Pr { standart strategy > alternative strategy }
	comptype <- c("NR.WHO.LGA","NR.IADPSG.LGA","WHO.IADPSG.LGA","NR.WHO.PE","NR.IADPSG.PE","WHO.IADPSG.PE","NR.WHO.CS","NR.IADPSG.CS","WHO.IADPSG.CS")
	resultados.pvalue <- array(,0)

	for (i in comptype) {
		ans <- c(i, eval(parse(text=paste("sum( ifelse(Delta.",i ," < 0 , 1, 0) ) / n",sep=""))) )
		resultados.pvalue <- rbind(resultados.pvalue, ans)
		print( ans )
	}

	write.csv2( resultados.pvalue , paste("Summary_pvalues.csv", sep=""))

	# NNS for screening strategies
	NNS.Delta.NR.WHO.LGA <- 1 / Delta.NR.WHO.LGA
	NNS.Delta.NR.IADPSG.LGA <- 1 / Delta.NR.IADPSG.LGA
	NNS.Delta.WHO.IADPSG.LGA <- 1 / Delta.WHO.IADPSG.LGA

	NNS.Delta.NR.WHO.PE <- 1 / Delta.NR.WHO.PE
	NNS.Delta.NR.IADPSG.PE <- 1 / Delta.NR.IADPSG.PE
	NNS.Delta.WHO.IADPSG.PE <- 1 / Delta.WHO.IADPSG.PE

	NNS.Delta.NR.WHO.CS <- 1 / Delta.NR.WHO.CS
	NNS.Delta.NR.IADPSG.CS <- 1 / Delta.NR.IADPSG.CS
	NNS.Delta.WHO.IADPSG.CS <- 1 / Delta.WHO.IADPSG.CS

	# Compute binary variables for proportions
	Bin.Delta.NR.WHO.LGA <- ifelse(Delta.NR.WHO.LGA > 0, 1, 0)
	Bin.Delta.NR.IADPSG.LGA <- ifelse(Delta.NR.IADPSG.LGA > 0, 1, 0)
	Bin.Delta.WHO.IADPSG.LGA <- ifelse(Delta.WHO.IADPSG.LGA > 0, 1, 0)

	Bin.Delta.NR.WHO.PE <- ifelse(Delta.NR.WHO.PE > 0, 1, 0)
	Bin.Delta.NR.IADPSG.PE <- ifelse(Delta.NR.IADPSG.PE > 0, 1, 0)
	Bin.Delta.WHO.IADPSG.PE <- ifelse(Delta.WHO.IADPSG.PE > 0, 1, 0)

	Bin.Delta.NR.WHO.CS <- ifelse(Delta.NR.WHO.CS > 0, 1, 0)
	Bin.Delta.NR.IADPSG.CS <- ifelse(Delta.NR.IADPSG.CS > 0, 1, 0)
	Bin.Delta.WHO.IADPSG.CS <- ifelse(Delta.WHO.IADPSG.CS > 0, 1, 0)

	comptype <- c("NR.WHO.LGA","NR.IADPSG.LGA","WHO.IADPSG.LGA","NR.WHO.PE","NR.IADPSG.PE","WHO.IADPSG.PE","NR.WHO.CS","NR.IADPSG.CS","WHO.IADPSG.CS")

	for (i in comptype) {
		ans <- eval(parse(text=paste("table(Bin.Delta.",i,")",sep="")))
		print(ans)

		if ( length(ans) < 2 ) ans <- c("0" = 0, ans[1] )
 		datasummary.table.diff <- rbind( datasummary.table.diff, as.array(c(i,ans)) )
	}

	# Save data
	datasummary.table.diff <- datasummary.table.diff[ !is.na(datasummary.table.diff[,1]) ,]

	datasummary.table.diff <- data.frame(
		"Comparação" = as.character(datasummary.table.diff[,1]),
		"Freq 0" = as.numeric(as.character(datasummary.table.diff[,2])),
		"Freq 1" = as.numeric(as.character(datasummary.table.diff[,3])),
		"Fr 0" = (100 * (as.numeric(as.character(datasummary.table.diff[,2])) / n )),
		"Fr 1" = (100 * (as.numeric(as.character(datasummary.table.diff[,3])) / n ))
		)

	write.csv2( datasummary.table.diff , "Estatísticas_Binarias_Prop_Comp.csv", row.names=FALSE )

	resultado.final.diff <- data.frame(
		"PWHO" = arrayPWHO,
		"NR vs WHO - LGA" = Delta.NR.WHO.LGA,
		"NR vs IADPSG - LGA" = Delta.NR.IADPSG.LGA,
		"WHO vs IADPSG - LGA" = Delta.WHO.IADPSG.LGA,

		"NR vs WHO - PE" = Delta.NR.WHO.PE,
		"NR vs IADPSG - PE" = Delta.NR.IADPSG.PE,
		"WHO vs IADPSG - PE" = Delta.WHO.IADPSG.PE,

		"NR vs WHO - CS" = Delta.NR.WHO.CS,
		"NR vs IADPSG - CS" = Delta.NR.IADPSG.CS,
		"WHO vs IADPSG - CS" = Delta.WHO.IADPSG.CS

		)

	write.csv2( resultado.final.diff , paste("table_data_Differences_PWHO_", i,".csv", sep=""), row.names=FALSE )

	# Compute summary tables
	datasummary <- rbind( datasummary, c( i, "NR.LGA", c(summary(resultado.final$"NR.LGA",)) ,
		quantile(resultado.final$"NR.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "NR.PE", c(summary(resultado.final$"NR.PE")) ,
		quantile(resultado.final$"NR.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "NR.CS", c(summary(resultado.final$"NR.CS")) ,
		quantile(resultado.final$"NR.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	datasummary <- rbind( datasummary, c( i, "WHO.LGA", c(summary(resultado.final$"WHO.LGA")) ,
		quantile(resultado.final$"WHO.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "WHO.PE", c(summary(resultado.final$"WHO.PE")) ,
		quantile(resultado.final$"WHO.PE", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "WHO.CS", c(summary(resultado.final$"WHO.CS")) ,
		quantile(resultado.final$"WHO.CS", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	datasummary <- rbind( datasummary, c( i, "IADPSG.LGA", c(summary(resultado.final$"IADPSG.LGA")) ,
		quantile(resultado.final$"IADPSG.LGA", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "IADPSG.PE", c(summary(resultado.final$"IADPSG.PE")) ,
		quantile(resultado.final$"IADPSG.PE", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary <- rbind( datasummary, c( i, "IADPSG.CS", c(summary(resultado.final$"IADPSG.CS")) ,
		quantile(resultado.final$"IADPSG.CS", probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	# Compute summary tables for differences
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs WHO - LGA", c(summary(Delta.NR.WHO.LGA)) ,
		quantile(Delta.NR.WHO.LGA, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs IADPSG - LGA", c(summary(Delta.NR.IADPSG.LGA)) ,
		quantile(Delta.NR.IADPSG.LGA, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	# Compute summary : screening strategies WHO vs IADPSG for LGA
	datasummary.diff <- rbind( datasummary.diff, c( i, "WHO vs IADPSG - LGA", c(summary(Delta.WHO.IADPSG.LGA)) ,
		quantile(Delta.WHO.IADPSG.LGA, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs WHO - PE", c(summary(Delta.NR.WHO.PE)) ,
		quantile(Delta.NR.WHO.PE, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs IADPSG - PE", c(summary(Delta.NR.IADPSG.PE)) ,
		quantile(Delta.NR.IADPSG.PE, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	# Compute summary : screening strategies WHO vs IADPSG for PE
	datasummary.diff <- rbind( datasummary.diff, c( i, "WHO vs IADPSG - PE", c(summary(Delta.WHO.IADPSG.PE)) ,
		quantile(Delta.WHO.IADPSG.PE, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs WHO - CS", c(summary(Delta.NR.WHO.CS)) ,
		quantile(Delta.NR.WHO.CS, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
	datasummary.diff <- rbind( datasummary.diff, c( i, "NR vs IADPSG - CS", c(summary(Delta.NR.IADPSG.CS)) ,
		quantile(Delta.NR.IADPSG.CS, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )

	# Compute summary : screening strategies WHO vs IADPSG for CS
	datasummary.diff <- rbind( datasummary.diff, c( i, "WHO vs IADPSG - CS", c(summary(Delta.WHO.IADPSG.CS)) ,
		quantile(Delta.WHO.IADPSG.CS, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
}

# Save summary data
datasummary <- datasummary[ !is.na(datasummary[,1]) ,]
datasummary.diff <- datasummary.diff[ !is.na(datasummary.diff[,1]) ,]

datasummary <- data.frame(datasummary)
names(datasummary) <- c(names(datasummary)[1:(length(names(datasummary))-2)],
paste("Percentil ",round((alfa/2)*100, digits=1),sep=""), paste("Percentil ",round((1-alfa/2)*100, digits=1),sep=""))

datasummary.diff <- data.frame(datasummary.diff)
names(datasummary.diff) <- c(names(datasummary.diff)[1:(length(names(datasummary))-2)],
paste("Percentil ",round((alfa/2)*100, digits=1),sep=""), paste("Percentil ",round((1-alfa/2)*100, digits=1),sep=""))

write.csv2( datasummary , paste("Summary_statistics.csv", sep=""), row.names=FALSE )
write.csv2( datasummary.diff , paste("Summary_statistics_for_differences.csv", sep=""), row.names=FALSE )

# Summary - distribution - Compute the Highest Posterior Density Interval (HPD)
require(hdrcde)
require(boa)

comptype <- c("NR.LGA","NR.PE","NR.CS","WHO.LGA","WHO.PE","WHO.CS","IADPSG.LGA","IADPSG.PE","IADPSG.CS")

for (i in comptype) {
	print(paste("Computing HPD Interval for ",i,sep=""))

	graphname <- paste("grafico_",i,".png", sep="")
	png(file.path(paste(getwd(),"//saida", sep=""),graphname))
		ans <- hdr.den(resultado.final[,i])
	dev.off()

	# Using boa package
	ans <- boa.hpd(resultado.final[,i], alpha = 0.05)
	write.csv2( ans , paste("HPD ",i,".csv", sep=""))
	print( ans )

}

comptype <- c("NR.WHO.LGA","NR.IADPSG.LGA","WHO.IADPSG.LGA","NR.WHO.PE","NR.IADPSG.PE","WHO.IADPSG.PE","NR.WHO.CS","NR.IADPSG.CS","WHO.IADPSG.CS")

for (i in comptype) {
	print(paste("Computing HPD Interval for Difference ",i,sep=""))

	graphname <- paste("grafico_IDiff_",i,".png", sep="")
	png(file.path(paste(getwd(),"//saida", sep=""),graphname))
		ans <- eval(parse(text=paste("hdr.den(Delta.",i,")",sep="")))
	dev.off()

	# Using boa package
	ans <- eval(parse(text=paste("boa.hpd(Delta.",i,", alpha = 0.05)",sep="")))
	write.csv2( ans , paste("HPD Diff ",i,".csv", sep=""))
	print( ans )

}

comptype <- c("NR.WHO.LGA","NR.IADPSG.LGA","WHO.IADPSG.LGA","NR.WHO.PE","NR.IADPSG.PE","WHO.IADPSG.PE","NR.WHO.CS","NR.IADPSG.CS","WHO.IADPSG.CS")

for (i in comptype) {
	print(paste("Computing HPD Interval for NNS",i,sep=""))

	graphname <- paste("grafico_NNS_Diff_",i,".png", sep="")
	png(file.path(paste(getwd(),"//saida", sep=""),graphname))
		ans <- eval(parse(text=paste("plot(density(NNS.Delta.",i,"))",sep="")))
	dev.off()

	# Using boa package
	ans <- eval(parse(text=paste("boa.hpd(NNS.Delta.",i,", alpha = 0.05)",sep="")))
	write.csv2( ans , paste("HPD Diff ",i,".csv", sep=""))
	print( ans )

}

###############################
# Sensitivity analysis - HAPO #
###############################

# Screening strategies settings
LGA_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # melhor solução encontrada
LGA_logRRtreatment <- rnorm(n, -0.6095, 0.1245) ;	# A distribuição de log(RR)

PE_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # melhor solução encontrada
PE_logRRtreatment <- rnorm(n, -0.4903, 0.1413) ;	# A distribuição de log(RR)

CS_Ptreatment <- rbeta(n, 40.5,  4.5 ) ; c <- 4.5; beta.parametros(9*c, 1*c, alfa) # melhor solução encontrada
CS_logRRtreatment <- rnorm(n, -0.1100, 0.0797) ;		# A distribuição de log(RR)

# Common parameters settings
Pwho_HAPO <- 0.114
Piadpsg_HAPO <- 0.161
LGA_Iwhopos_HAPO <- 0.137
PE_Iwhopos_HAPO <- 0.076
CS_Iwhopos_HAPO <- 0.244
LGA_Iiadpsgpos_HAPO <- 0.162
PE_Iiadpsgpos_HAPO <- 0.091
CS_Iiadpsgpos_HAPO <- 0.244

# Compute incidence reduction - WHO
RI_LGA_WHO <- Pwho_HAPO * LGA_Iwhopos_HAPO * LGA_Ptreatment * (1-exp(LGA_logRRtreatment))
NNS_LGA_WHO <- 1 / RI_LGA_WHO

RI_PE_WHO  <- Pwho_HAPO * PE_Iwhopos_HAPO * PE_Ptreatment * (1-exp(PE_logRRtreatment))
NNS_PE_WHO <- 1 / RI_PE_WHO

RI_CS_WHO <- Pwho_HAPO * CS_Iwhopos_HAPO * CS_Ptreatment * (1-exp(CS_logRRtreatment))
NNS_CS_WHO <- 1 / RI_CS_WHO

# Compute incidence reduction - IADPSG
RI_LGA_IADPSG <- Piadpsg_HAPO * LGA_Iiadpsgpos_HAPO * LGA_Ptreatment * (1-exp(LGA_logRRtreatment))
NNS_LGA_IADPSG <- 1 / RI_LGA_IADPSG

RI_PE_IADPSG <- Piadpsg_HAPO * PE_Iiadpsgpos_HAPO * PE_Ptreatment * (1-exp(PE_logRRtreatment))
NNS_PE_IADPSG <- 1 / RI_PE_IADPSG

RI_CS_IADPSG <- Piadpsg_HAPO * CS_Iiadpsgpos_HAPO * CS_Ptreatment * (1-exp(CS_logRRtreatment))
NNS_CS_IADPSG <- 1 / RI_CS_IADPSG

# Save data
resultado.final.sa <- data.frame(
	"RI_LGA_WHO" = RI_LGA_WHO,
	"NNS_LGA_WHO" = NNS_LGA_WHO,
	"RI_PE_WHO" = RI_PE_WHO,
	"NNS_PE_WHO" = NNS_PE_WHO,
	"RI_CS_WHO" = RI_CS_WHO,
	"NNS_CS_WHO" = NNS_CS_WHO,

	"RI_LGA_IADPSG" = RI_LGA_IADPSG,
	"NNS_LGA_IADPSG" = NNS_LGA_IADPSG,
	"RI_PE_IADPSG" = RI_PE_IADPSG,
	"NNS_PE_IADPSG" = NNS_PE_IADPSG,
	"RI_CS_IADPSG" = RI_CS_IADPSG,
	"NNS_CS_IADPSG" = NNS_CS_IADPSG
	)

write.csv2( resultado.final.sa , "table_data_sensitivity analysis.csv" )

# Compute summary tables
tabela.resumo.sa <- array(,9)

vet.nomeselementos <- c("RI_LGA_WHO","NNS_LGA_WHO","RI_PE_WHO","NNS_PE_WHO","RI_CS_WHO","NNS_CS_WHO",
                        "RI_LGA_IADPSG", "NNS_LGA_IADPSG", "RI_PE_IADPSG", "NNS_PE_IADPSG", "RI_CS_IADPSG", "NNS_CS_IADPSG")

for (i in vet.nomeselementos) {
	ans <- eval(parse(text=i))
	tabela.resumo.sa <- rbind( tabela.resumo.sa, c( i, summary(ans), quantile(ans, probs = c(alfa/2, 1 - alfa/2), names = FALSE ) ) )
}

tabela.resumo.sa <- tabela.resumo.sa[ !is.na(tabela.resumo.sa[,1]) ,]

tabela.resumo.sa <- data.frame(tabela.resumo.sa)
names(tabela.resumo.sa) <- c("Estatística/Estratégia", names(tabela.resumo.sa)[2:(length(names(tabela.resumo.sa))-2)],
paste("Percentil ",round((alfa/2)*100, digits=1),sep=""), paste("Percentil ",round((1-alfa/2)*100, digits=1),sep=""))

write.csv2( tabela.resumo.sa , paste("Summary_AS_HAPO.csv", sep=""), row.names=FALSE )

# Summary - Highest Posterior Density Interval (HPD)
vet.nomeselementos1 <- c("RI_LGA_WHO","RI_PE_WHO","RI_CS_WHO","RI_LGA_IADPSG", "RI_PE_IADPSG", "RI_CS_IADPSG")
vet.nomeselementos2 <- c("NNS_LGA_WHO", "NNS_LGA_IADPSG","NNS_PE_WHO", "NNS_PE_IADPSG", "NNS_CS_WHO", "NNS_CS_IADPSG")
vet.nomeselementos <- c(vet.nomeselementos1, vet.nomeselementos2)

for (i in vet.nomeselementos) {
	print(paste("HPD Interval for ",i," | Sensitivity analysis HAPO",sep=""))

	graphname <- paste("grafico_AS_HAPO_",i,".png", sep="")
	png(file.path(paste(getwd(),"//saida", sep=""),graphname))
		ans <- eval(parse(text=paste("plot(density(",i,"))",sep="")))
	dev.off()

	ans <- eval(parse(text=paste("boa.hpd(",i,", alpha = 0.05)",sep="")))
	write.csv2( ans , paste("HPD Sensitivity analysis HAPO ",i,".csv", sep=""))
	print( ans )

}

dev.off()

####################
# End of the syntaxe
####################

Simulation Gestational Diabetes WHO/Simulation main.r


bootstrap_samples = function( expected_I, observed_I, number_samples, window_size=3 , use_wa = FALSE, beta = 0.9){
  "
  Once the expected_I vector is computed is posible to generate the bootsrapped
  samples for  a confidence interval cosntruction.

  Parameters
  ----------
  Expected_I : numeric vector
    Number of sintomatic people on a given day (estimated).
  Observed_I : numeric vector
    Number of sintomatic people on a given day.
  number_samples : numeric
    number of samples.
  window_size : numeric
    smoothing factor.

  Returns
  -------
  standarized_residual : data_frame
    bootstrapped sample
  "
  standarized_residual <- standarized_residuals(expected_I, observed_I, window_size)
  samples = list()
  for( i in 1:number_samples)
  {
      sample <- sample(standarized_residual$SR, length(expected_I), replace = TRUE)

      if(use_wa){
        DES = 1:length(expected_I)
        temp_de = standarized_residual$DE
        for(j in 2:length(observed_I))
        {
          temp_de[j] = beta*temp_de[j - 1] + (1-beta)*temp_de[j]
        }
        sample = sample*temp_de
      }else{
        sample = sample*standarized_residual$DE
      }
      sample_I = expected_I + sample
      samples <- list.append(samples, i=sample_I)
  }
  df <- data.frame(matrix(unlist(samples), nrow=length(samples), byrow=T))
  return(df)
}

standarized_residuals = function(expected_I, observed_I, window_size=3){
"
  Residuals normalization for an umbaised bootstrap.

  Parameters
  ----------
  Expected_I : numeric vector
    Number of sintomatic people on a given day (estimated).
  Observed_I : numeric vector
    Number of sintomatic people on a given day.
  window_size : numeric
    smoothing factor.

  Returns
  -------
  standarized_residual : list
    SR : residuals
    DE : standard deviation
  "
  half_window_size = floor(window_size / 2)
  standarized_residual <- observed_I - expected_I
  DES = 1:length(expected_I)
  for( i in seq(half_window_size + 1, length(expected_I) - half_window_size + 1))
  {
    indices = (i-half_window_size):(i + half_window_size-1)
    DE = sd(observed_I[indices] - expected_I[indices])
    standarized_residual[i] = standarized_residual[i]/DE
    DES[i] = DE
  }

  first_window_idexes = 1:half_window_size
  last_window_indexes = (length(expected_I) - half_window_size + 1):length(expected_I)
  DE_in = sd(observed_I[first_window_idexes] - expected_I[first_window_idexes])
  DE_out = sd(observed_I[last_window_indexes] - expected_I[last_window_indexes])
  DES[first_window_idexes] = DE_in
  DES[last_window_indexes] = DE_out
  standarized_residual[first_window_idexes] = standarized_residual[first_window_idexes]/DE_in
  standarized_residual[last_window_indexes] = standarized_residual[last_window_indexes]/DE_out
  return(list("SR"=standarized_residual, "DE"=DES))
}

compute_variances = function(observed_I, window_size=3){
  "
  Residuals normalization for an umbaised bootstrap.

  Parameters
  ----------
  Expected_I : numeric vector
    Number of sintomatic people on a given day (estimated).
  Observed_I : numeric vector
    Number of sintomatic people on a given day.
  window_size : numeric
    smoothing factor.

  Returns
  -------
  standarized_residual : list
    SR : residuals
    DE : standard deviation
  "
  variance_observed = 1:length(observed_I)
  half_window_size = floor(window_size / 2)
  for( i in seq(half_window_size + 1, length(observed_I) - half_window_size + 1))
  {
    indices = (i-half_window_size):(i + half_window_size-1)
    variance = var(observed_I[indices])
    variance_observed[i] = variance
  }

  first_window_idexes = 1:half_window_size
  last_window_indexes = (length(observed_I) - half_window_size + 1):length(observed_I)
  DE_in = var(observed_I[first_window_idexes])
  DE_out = var(observed_I[last_window_indexes])
  variance_observed[first_window_idexes] = DE_in
  variance_observed[last_window_indexes] = DE_out
  return(variance_observed)
}


#' f_qscop
#'
#' Estimate the quantile given specific $(\tau, x)$
#'
#' @param tau conditional probability
#' @param n1 the first covariates
#' @param til_beta the current estimation fro $\tilde{\beta}$
#' @param m_sigma $K_\tau K_1 \times K_\tau K_1 \Sigma$ diagonal block matix.
#' @param ktau internal knots of tau
#' @param mtau order for tau spline
#'
#'
#' @return An estimated the quantile given specific $(\tau, x)$
#'
#' @examples
#' \dontrun{
#' k1 <- 4; ktau <- 4; m1 <- 4; mtau <- 4; y <- rnorm(200)
#' n1 <- f_n1(1:200, k1, m1); beta <- rnorm(prod(ktau + mtau, k1 + m1))
#' til_beta <- tilde_beta(beta, k1 + m1)
#' m_sigma <- f_sigma(ktau + mtau, k1 + m1)
#' f_qscop(seq(0, 1, 0.1), n1, til_beta, m_sigma, ktau, mtau)
#' f_qscop(0, n1, til_beta, m_sigma, ktau, mtau) < f_qscop(1, n1, til_beta, m_sigma, ktau, mtau)

#' }

f_qscop <- function(tau, n1, til_beta, m_sigma, ktau, mtau) {
    m_n <- kronecker(spline_basis(tau, ktau, mtau, c(1, 0)), n1)
    out <- m_n %*% m_sigma %*% til_beta
    return(c(out))
}

#' f_qzeros
#'
#' zeros function to find the root $\tau_i$ for each observs
#'
#' @param tau conditional probability
#' @param idx index of the observations
#' @param v_y vector of y
#' @param n1 spline basis for the first covariates
#' @param ... other 4 args for f_qscop in order (til_beta, m_sigma, ktau, mtau)
#'
#'
#' @return Difference bw response and estimation $Q(\tau, x_i) - y_i$
#'
#' @examples
#' \dontrun{
#' k1 <- 4; ktau <- 4; m1 <- 4; mtau <- 4; y <- rnorm(200)
#' n1 <- f_n1(1:200, k1, m1); beta <- rnorm(prod(ktau + mtau, k1 + m1))
#' til_beta <- tilde_beta(beta, k1 + m1)
#' m_sigma <- f_sigma(ktau + mtau, k1 + m1)
#' f_qzeros(0.5, 2:3, y, n1, til_beta, m_sigma, ktau, mtau)
#' }
f_qzeros <- function(tau, idx, v_y, n1, ...) {
    n1 <- n1[idx, ]
    if (length(idx) == 1) {
        n1 <- t(n1)
    }
    s_dif <- f_qscop(tau, n1, ...) - v_y[idx]
    if ((tau == 0 && s_dif > 0) || (tau == 1 && s_dif < 0)) {
        return(0)
    }

    return(s_dif)
}

#' f_tausearch
#'
#' search the $\tau^*$ using the unitroot function
#'
#' @param v_y vector of y
#' @param n1 spline basis for the first covariates
#' @param ... other 4 args for f_qscop in order (til_beta, m_sigma, k2, m2)
#'
#'
#' @return $\tau^*$
#'
#' \dontrun{
#' k1 <- 4; ktau <- 4; m1 <- 4; mtau <- 4; y <- rnorm(200)
#' n1 <- f_n1(1:200, k1, m1); beta <- rnorm(prod(ktau + mtau, k1 + m1))
#' til_beta <- tilde_beta(beta, k1 + m1)
#' m_sigma <- f_sigma(ktau + mtau, k1 + m1)
#' f_qzeros(0.5, 2:3, y, n1, til_beta, m_sigma, ktau, mtau)
#' v_taus <- f_tausearch(y, n1, til_beta, m_sigma, ktau, mtau)
#' sapply(1:200, function(x) {
#'      f_qscop(v_taus[x], t(n1[x, ]), til_beta, m_sigma, ktau, mtau)
#' }) - y
#' }
f_tausearch <- function(v_y, n1, ...) {
    taustar <- sapply(seq_along(v_y), function(x) {
                    uniroot(f_qzeros,
                            idx = x,
                            v_y = v_y,
                            n1 = n1,
                            ...,
                            interval = c(0, 1))$root})
    return(taustar)
}


 E04NFJ Example Program Results

 *** e04nf

 Parameters
 ----------

 Problem type...........       QP2

 Linear constraints.....         7       Feasibility tolerance..  1.05E-08
 Variables..............         7       Optimality tolerance...  1.05E-08
 Hessian rows...........         7       Rank tolerance.........  1.11E-14

 Infinite bound size....  1.00E+20       COLD start.............
 Infinite step size.....  1.00E+20       EPS (machine precision)  1.11E-16

 Check frequency........        50       Expand frequency.......         5
 Minimum sum of infeas..        NO       Crash tolerance........  1.00E-02

 Max degrees of freedom.         7       Print level............        10
 Feasibility phase itns.        70       Monitoring file........        -1
 Optimality  phase itns.        70

 Workspace provided is     IWORK(      17),  WORK(     189).
 To solve problem we need  IWORK(      17),  WORK(     189).

  Itn     Step Ninf Sinf/Objective  Norm Gz
    0  0.0E+00    3   1.038000E-01  0.0E+00
    1  4.1E-02    1   3.000000E-02  0.0E+00
    2  4.2E-02    0   0.000000E+00  0.0E+00
 Itn     2 -- Feasible point found.
    2  0.0E+00    0   4.580000E-02  0.0E+00
    3  1.3E-01    0   4.161596E-02  0.0E+00
    4  1.0E+00    0   3.936227E-02  4.2E-17
    5  4.1E-01    0   3.758935E-02  1.2E-02
    6  1.0E+00    0   3.755377E-02  1.0E-17
    7  1.0E+00    0   3.703165E-02  3.8E-17

 Varbl State     Value       Lower Bound   Upper Bound    Lagr Mult   Slack

 V   1    LL  -1.000000E-02 -1.000000E-02  1.000000E-02  0.4700         .
 V   2    FR  -6.986465E-02 -0.100000      0.150000           .      3.0135E-02
 V   3    FR   1.825915E-02 -1.000000E-02  3.000000E-02       .      1.1741E-02
 V   4    FR  -2.426081E-02 -4.000000E-02  2.000000E-02       .      1.5739E-02
 V   5    FR  -6.200564E-02 -0.100000      5.000000E-02       .      3.7994E-02
 V   6    FR   1.380544E-02 -1.000000E-02      None           .      2.3805E-02
 V   7    FR   4.066496E-03 -1.000000E-02      None           .      1.4066E-02

 L Con State     Value       Lower Bound   Upper Bound    Lagr Mult   Slack

 L   1    EQ  -0.130000     -0.130000     -0.130000      -1.908     -5.5511E-17
 L   2    FR  -5.879898E-03      None     -4.900000E-03       .      9.7990E-04
 L   3    UL  -6.400000E-03      None     -6.400000E-03 -0.3144      8.6736E-19
 L   4    FR  -4.537323E-03      None     -3.700000E-03       .      8.3732E-04
 L   5    FR  -2.915996E-03      None     -1.200000E-03       .      1.7160E-03
 L   6    LL  -9.920000E-02 -9.920000E-02      None       1.955         .
 L   7    LL  -3.000000E-03 -3.000000E-03  2.000000E-03   1.972      4.3368E-18

 Exit e04nf  - Optimal QP solution.

 Final QP objective value =   0.3703165E-01

 Exit from QP problem after     7 iterations.


hist_nwj <- function(x, type='nwj', alpha=0.01, P=0.99, breaks=NULL, jfit='all',
                     upperbound=TRUE, main=NULL, subtitle='yes', suppress='no') {
    ## plot histogram and normal, Weibull, and Johnson distributions
    ## adds lines for upper tolerance limits for given alpha and proportion
    ## alpha  = 1 - confidence
    ## P = coverage proportion (tolerance interval only)
    proportion = P
    ## breaks = number of bins used in the histogram (default auto determines number)
    ## jfit  = 'all' = uses SuppDists::JohnsonFit to determine parameters
    ##       = 'SU'  = uses ExtDist::eJohnsonSU to determine parameters
    ##       = list of user specified parameters
    ##         e.g., jparms <- list(gamma   = -1.039,
    ##                              delta   = 1.66,
    ##                              xi      = 14.46,
    ##                              lambda  = 6.95,
    ##                              type    = 'SU')
    ##              johnson_tol(mtcars$mpg, jfit=jparms)
    ## main = title for histogram (default is "Histogram of ...")
    ## subtitle = 'yes' = puts description of lines in subtitle
    ##          = 'no'  = subtitle is blank
    ##          = user specified, single line subtitle
    ## suppress = 'yes' creates plot but does not return calculated values to the screen
    ##            (e.g., fit parameters and tolerance limits)

    ## name of variable passed in
    xname <- deparse(substitute(x))

    ## initialize parameters
    xmean <- NA
    xsd   <- NA
    shape <- NA
    scale <- NA
    jparms <- NA
    tol_out_norm <- NA
    tol_out_weib <- NA
    tol_out_john <- NA
    upper_tolerance_limit_norm <- NA
    upper_tolerance_limit_weib <- NA
    upper_tolerance_limit_john <- NA
    xdensity_norm <- NA
    xdensity_weib <- NA
    xdensity_john <- NA

    if (grepl('n', type)) {
        ## normal distribution calculations
        tol_out_norm <- tolerance::normtol.int(x, alpha = alpha, P=proportion, side=1)
        upper_tolerance_limit_norm <- tol_out_norm$'1-sided.upper'
    }

    if (grepl('w', type)) {
        ## Weibull distribution calculations
        if (min(x) < 0) {
            cat('\n')
            cat('#####################################################################\n')
            cat('Skip Weibull: Negative values cannot be fit with Weibull distribution\n')
            cat('#####################################################################\n\n')
            tol_out_weib <- NA
            shape <- NA
            scale <- NA
            upper_tolerance_limit_weib <- NA
        } else {
            tol_out_weib <-  tolerance::exttol.int(x, alpha=alpha, P=proportion, side=1, dist="Weibull")
            shape   <- tol_out_weib$'shape.1'
            scale   <- tol_out_weib$'shape.2'
            upper_tolerance_limit_weib <- tol_out_weib$'1-sided.upper'
        }
    }

    if (grepl('j', type)) {
        ## Johnson distribution calculations
        tol_out_john <- johnson_tol(x, alpha=alpha, P=proportion, side=1, jfit=jfit)
        jparms   <- tol_out_john$jparms
        upper_tolerance_limit_john <- tol_out_john$xtol_upper
    }

    ## create vectors with density distributions
    xmin    <- min(x)
    if (isTRUE(upperbound)) {
        xmax <- max(x,
                    upper_tolerance_limit_norm,
                    upper_tolerance_limit_weib,
                    upper_tolerance_limit_john,
                    na.rm = TRUE)
    } else {
        xmax <- max(x, na.rm = TRUE)
    }
    chuncks <- (xmax-xmin)/1000
    xrange  <- seq(xmin,xmax,by=chuncks)
    xmean   <- mean(x)
    xsd     <- sd(x)
    if (grepl('n', type)) xdensity_norm <- stats::dnorm(xrange,xmean,xsd)
    if (grepl('w', type)) xdensity_weib <- stats::dweibull(xrange,shape=shape,scale=scale)
    if (grepl('j', type)) xdensity_john <- SuppDists::dJohnson(xrange, jparms)

    ## make histogram
    ## warning: xlim range can mess up x-axis
    ## obtain histogram parameters but suppress plot
    if (is.null(breaks)) {
        ## breaks not specified so figure out what to use
        out <- hist(x, plot=FALSE)
        breaks <- length(out$breaks)
    }
    ## hist needed with number of breaks to be used to get density for max height of histogram
    out <- hist(x, breaks=breaks, plot=FALSE)
    maxdensity <- max(xdensity_norm, xdensity_weib, xdensity_john, out$density, na.rm=TRUE)
    ymax <- max(out$density, maxdensity)
    ## create plot
    if (is.null(main)) main <- paste('Histogram of', xname, sep=" ")
    hist(x, breaks=breaks,
         xlab = xname,
         xlim=c(xmin,xmax+(xmax-xmin)/breaks),
         ylim=c(0,maxdensity),
         freq=FALSE,
         main=main)
    if (subtitle == 'yes') {
        n <- w <- j <- NULL
        if (grepl('n', type)) n <- 'red = normal,'
        if (grepl('w', type)) w <- 'blue = Weibull,'
        if (grepl('j', type)) j <- 'black = Johnson'
        ## subtitle <- list('line color: red = normal, blue = Weibull, black = Johnson',
        ##                  'line type: solid = distribution or mean, dashed = 1-sided upper bound')
        subtitle <- list(paste('line color:', n, w, j, sep=' '),
                         'line type: solid = distribution or mean, dashed = 1-sided upper bound')
        mtext(subtitle, side=3, line=c(0.75, 0), cex=.75, col='black')
    } else if (subtitle == 'no') {
        ## skip subitile
    } else {
        ## use user specified subitile
        mtext(subtitle)
    }

    ## add distributions
    if (grepl('n', type)) lines(x=xrange, y=xdensity_norm, col='red',   lty=1)
    if (grepl('w', type)) lines(x=xrange, y=xdensity_weib, col='blue',  lty=1)
    if (grepl('j', type)) lines(x=xrange, y=xdensity_john, col='black', lty=1)

    ## add lines for mean and upper 1-sided 99/99 tolerance limits
    abline(v=xmean,col="red")
    if (isTRUE(upperbound)) {
        if (grepl('n', type)) abline(v=upper_tolerance_limit_norm,col="red",  lty=2)
        if (grepl('w', type)) abline(v=upper_tolerance_limit_weib,col="blue", lty=2)
        if (grepl('j', type)) abline(v=upper_tolerance_limit_john,col="black",lty=2)
    }

    ## print to screen
    if (suppress == 'no') {
        cat("Upper, 1-Sided Tolerance Limits\n")
        cat("confidence =", 1-alpha, ", coverage proportion", proportion, '\n')
        cat("-------------------------------")
        cat("\n")
        if (grepl('n', type)) {
            cat("Normal distribution (red):\n")
            cat("   mean                =",xmean,"\n")
            cat("   standard deviation  =",xsd,"\n")
            cat("   tolerance limit     =",upper_tolerance_limit_norm,"\n")
            cat("\n")
        }
        if (grepl('w', type)) {
            cat("Weibull distribution (blue):\n")
            cat("   shape               =",shape,"\n")
            cat("   scale               =",scale,"\n")
            cat("   tolerance limit     =",upper_tolerance_limit_weib,"\n")
            cat("\n")
        }
        if (grepl('j', type)) {
            cat("Johnson distribution (black):\n")
            cat("   gamma               =",jparms$gamma ,"\n")
            cat("   delta               =",jparms$delta ,"\n")
            cat("   xi                  =",jparms$xi    ,"\n")
            cat("   lambda              =",jparms$lambda,"\n")
            cat("   type                =",jparms$type  ,"\n")
            cat("   tolerance limit     =",upper_tolerance_limit_john,"\n")
            cat("   (tolerance limit is the distribution bound if type SB or SL)\n")
        }
    }

    return(list(sided = '1-sided, upper limits',
                proportion = proportion,
                alpha = alpha,
                nparms = list(mean = xmean, sd=xsd),
                wparms = list(shape = shape, scale = scale),
                jparms = jparms,
                tol_out_norm=tol_out_norm,
                tol_out_weib=tol_out_weib,
                tol_out_john=tol_out_john))

}

## set.seed(1)
## jparms <- list(gamma = -1.039, delta = 1.66, xi = 14.46, lambda = 6.95, type    = 'SU')
## xjohn <- SuppDists::rJohnson(999, parms=jparms) + 2
## out   <- hist_nwj(xjohn, jfit=jparms)

## out <- hist_nwj(mtcars$mpg)
## out <- hist_nwj(mtcars$mpg, type='n')
## out <- hist_nwj(mtcars$mpg, type='w')
## out <- hist_nwj(mtcars$mpg, type='j')
## out <- hist_nwj(mtcars$mpg, type='nw')


correlations <- function(x, y, block=5, nboot=1000) {

	orig <- cor(x,y)
	distr <- array(0, nboot)

	for(boot in 1:nboot) {

		nblock <- length(x)/block

		tmpx <- sample(seq(1:(length(x)-block)), size=nblock, replace=TRUE)
		tmpy <- sample(seq(1:(length(y)-block)), size=nblock, replace=TRUE)

		x.b <- 0
		y.b <- 0

		for(i in 1:nblock) {
			x.b <- c(x.b, x[tmpx[i]:(tmpx[i]+block-1)])
			y.b <- c(y.b, y[tmpy[i]:(tmpy[i]+block-1)])
		}
		distr[boot] <- cor(x.b, y.b)
	}

	p <- length(which(abs(distr) >= abs(orig)))/nboot

    my_return <- list('p' = p, 'distr' = distr)

	return (my_return)
}

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/1.csv")

rr1  <- correlations(data$RR_A,data$RR_B)
pos1 <- correlations(data$Pos_A,data$Pos_B)
del1 <- correlations(data$Delta_PosA, data$Delta_PosB)

rp1 <-correlations(data$RR_A,data$Pos_A)
rd1 <-correlations(data$RR_A,data$Delta_PosA)
rp1_ <-correlations(data$RR_B,data$Pos_B)
rd1_ <-correlations(data$RR_B,data$Delta_PosB)
crp1 <-correlations(data$RR_A,data$Pos_B)
crd1 <-correlations(data$RR_A,data$Delta_PosB)
crp1_ <-correlations(data$RR_B,data$Pos_A)
crd1_ <-correlations(data$RR_B,data$Delta_PosA)

crd1$p
crd2$p
crd3$p
crd4$p
crd5$p
crd6$p

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/2.csv")

rr2  <- correlations(data$RR_A,data$RR_B)
pos2 <- correlations(data$Pos_A,data$Pos_B)
del2 <- correlations(data$Delta_PosA, data$Delta_PosB)

rp2 <-correlations(data$RR_A,data$Pos_A)
rd2 <-correlations(data$RR_A,data$Delta_PosA)
rp2_ <-correlations(data$RR_B,data$Pos_B)
rd2_ <-correlations(data$RR_B,data$Delta_PosB)

crp2 <-correlations(data$RR_A,data$Pos_B)
crd2 <-correlations(data$RR_A,data$Delta_PosB)
crp2_ <-correlations(data$RR_B,data$Pos_A)
crd2_ <-correlations(data$RR_B,data$Delta_PosA)

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/3.csv")

rr3  <- correlations(data$RR_C,data$RR_D)
pos3 <- correlations(data$Pos_C,data$Pos_D)
del3 <- correlations(data$Delta_PosC, data$Delta_PosD)

rp3 <-correlations(data$RR_C,data$Pos_C)
rd3 <-correlations(data$RR_C,data$Delta_PosC)
rp3_ <-correlations(data$RR_D,data$Pos_D)
rd3_ <-correlations(data$RR_D,data$Delta_PosD)
crp3 <-correlations(data$RR_C,data$Pos_D)
crd3 <-correlations(data$RR_C,data$Delta_PosD)
crp3_ <-correlations(data$RR_D,data$Pos_C)
crd3_ <-correlations(data$RR_D,data$Delta_PosC)

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/4.csv")

rr4  <- correlations(data$RR_C,data$RR_D)
pos4 <- correlations(data$Pos_C,data$Pos_D)
del4 <- correlations(data$Delta_PosC, data$Delta_PosD)

rp4 <-correlations(data$RR_C,data$Pos_C)
rd4 <-correlations(data$RR_C,data$Delta_PosC)
rp4_ <-correlations(data$RR_D,data$Pos_D)
rd4_ <-correlations(data$RR_D,data$Delta_PosD)

crp4 <-correlations(data$RR_C,data$Pos_D)
crd4 <-correlations(data$RR_C,data$Delta_PosD)
crp4_ <-correlations(data$RR_D,data$Pos_C)
crd4_ <-correlations(data$RR_D,data$Delta_PosC)

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/5.csv")

rr5  <- correlations(data$RR_E,data$RR_F)
pos5 <- correlations(data$Pos_E,data$Pos_F)
del5 <- correlations(data$Delta_PosE, data$Delta_PosF)

rp5 <-correlations(data$RR_E,data$Pos_E)
rd5 <-correlations(data$RR_E,data$Delta_PosE)
rp5_ <-correlations(data$RR_F,data$Pos_F)
rd5_ <-correlations(data$RR_F,data$Delta_PosF)

crp5 <-correlations(data$RR_E,data$Pos_F)
crd5 <-correlations(data$RR_E,data$Delta_PosF)
crp5_ <-correlations(data$RR_F,data$Pos_E)
crd5_ <-correlations(data$RR_F,data$Delta_PosE)

data <- read.csv("C:/Users/LucasMarquesGasparin/Desktop/Learning/TCC/Data/Processed/6.csv")

rr6  <- correlations(data$RR_E,data$RR_F)
pos6 <- correlations(data$Pos_E,data$Pos_F)
del6 <- correlations(data$Delta_PosE, data$Delta_PosF)

rp6 <-correlations(data$RR_E,data$Pos_E)
rd6 <-correlations(data$RR_E,data$Delta_PosE)
rp6_ <-correlations(data$RR_F,data$Pos_F)
rd6_ <-correlations(data$RR_F,data$Delta_PosF)

crp6 <-correlations(data$RR_E,data$Pos_F)
crd6 <-correlations(data$RR_E,data$Delta_PosF)
crp6_ <-correlations(data$RR_F,data$Pos_E)
crd6_ <-correlations(data$RR_F,data$Delta_PosE)

rr1$p
hist(rr1$distr)

pos1$p
hist(pos1$distr)

del1$p
hist(del1$distr)

# Simulação

X <- vector(length = T)
Y <- vector(length = T)
T = 1000
nboot = 1000
p_valores = array(0, nboot)
for(boot in 1:nboot) {
	t = 1
	X[0] <- rnorm(0)
	Y[0] <- rnorm(0)
	while (t < T) {
		t = t + 1
		Y[t] <- 0.5*Y[t-1] + rnorm(1)
		X[t] <- 0.5*X[t-1] + rnorm(1)
	}
	rr <- correlations(X, Y)
	p_valores[boot] <- rr$p
}

hist(p_valores)


# Various useful functions

getPmat <- function(tmu,tv_ti_ratio,acgt) {
    # Returns the evolutionary substitution matrix
    if (any(acgt >= 1) || any(acgt <= 0)) {
        abort("The ACGT frequencies must be in the range 0 to 1")
    } else if (sum(acgt) != 1) {
        abort("The ACGT frequencies do not sum to 1")
    } else if (tv_ti_ratio <= 0) {
        abort("The transversion and transtition ratio cannot go under 0")
    }

    # Returns the substitution probability matrix.
    if (tv_ti_ratio == 1 && identical(acgt, c(0.25, 0.25, 0.25, 0.25))) {
        return(jukesCantorPmat(tmu))
    } else {
        Q <- qmatHKY85(tmu, tv_ti_ratio, acgt)
        r  <- eigen(Q)
        B <- r$vectors
        E  <- diag(exp(r$values))

        #      Q        The eigen vector change of basis
        #  M  ->   M
        #
        #  ^       ^
        #  |B^-1   |B
        #     Eig
        #  N  ->   N

        # Little trick to avoid numerical difficulties
        out <- solve(a=t(B), b=E %*% t(B))

        rownames(out) <- c("A","C","G","T")
        colnames(out) <- c("A","C","G","T")
        return(out)
    }
}

jukesCantorPmat2 <- function(tmu){
    # Using the Juke-Cantor model
    names <- c("A", "C", "G", "T")
    return(matrix(1 / 4 - exp(-tmu) / 4, nrow=4, ncol=4, dimnames=list(names, names)) + diag(exp(-tmu), 4, 4))
}

qmatHKY85 <- function(tmu, tv_ti, acgt) {
    # HKY85 model
    #               |  sum_1          pi_c * tv_ti   pi_g           pi_t * tv_ti  |
    #               |  pi_a * tv_ti   sum_2          pi_g * tv_ti   pi_t          |
    #  Q = tmu  *   |  pi_a           pi_c * tv_ti   sum_3          pi_t * tv_ti  |
    #               |  pi_a * tv_ti   pi_c           pi_g * tv_ti   sum_4         |
    #
    Qmat <- rbind(
        c(0, tv_ti, 1, tv_ti) * acgt,
        c(tv_ti, 0, tv_ti, 1) * acgt,
        c(1, tv_ti, 0, tv_ti) * acgt,
        c(tv_ti, 1, tv_ti, 0) * acgt)

    return(tmu * (Qmat - diag(rowSums(Qmat))))
}

metroDesc <- function(lpr, lol){
    # the logic in the Metropolis-Hastings step
    stopifnot(!is.na(lpr))
    stopifnot(!is.na(lol))

    return(log(runif(1)) < lpr - lol)
}

seqProbVecLambda <- function(lambda, lambda_disp, m, termini="both") {
    # Returns the position specific probability of being in an overhang
    pvals <- dnbinom(1:m - 1, prob=lambda, size=lambda_disp)
    psum <- (1 - cumsum(pvals)) / 2

    if (termini == "both") {
        return(c(psum[1:(m / 2)], rev(psum[1:(m / 2)])))
    } else if (termini == "5p") {
        return(psum)
    } else if (termini == "3p") {
        return(rev(psum))
    } else {
        abort("Invalid value for termini: '%s'", termini)
    }
}

cat("Compiling C++ extension. This may take a moment ..\n")
sourceCpp(code='
// [[Rcpp::depends(RcppGSL)]]
#include <RcppGSL.h>

#include <gsl/gsl_sf_gamma.h>

// [[Rcpp::export]]
double logLikFunOneBaseFast(
    const Rcpp::NumericVector Gen,
    const Rcpp::NumericVector S,
    const Rcpp::NumericVector theta,
    const double deltad,
    const double deltas,
    const Rcpp::NumericVector laVec,
    const Rcpp::NumericVector nuVec,
    const int m,
    const int lin
) {
    Rcpp::NumericVector pDam(4);
    double result = 0;

    for (int i = 0; i < laVec.size(); i++) {
        double la = laVec[i];
        double nu = nuVec[i];
        double pct = nu * (la * deltas + deltad * (1 - la));
        double pga = (1 - nu) * (la * deltas + deltad * (1 - la));

        pDam[0] = theta(lin - 1, 0) * 1 + theta(lin - 1, 2) * pga;
        pDam[1] = theta(lin - 1, 1) * (1 - pct);
        pDam[2] = theta(lin - 1, 2) * (1 - pga);
        pDam[3] = theta(lin - 1, 1) * pct + theta(lin - 1, 3) * 1;

        double p1 = gsl_sf_lnfact(Gen(i)) -
            gsl_sf_lnfact(S(i, 0)) -
            gsl_sf_lnfact(S(i, 1)) -
            gsl_sf_lnfact(S(i, 2)) -
            gsl_sf_lnfact(S(i, 3));

        double p2 = S(i, 0) * log(pDam[0]) +
            S(i, 1) * log(pDam[1]) +
            S(i, 2) * log(pDam[2]) +
            S(i, 3) * log(pDam[3]);

        result += p1 + p2;
    }
    return result;
}')
cat("Compilation of C++ extension completed\n")

logLikAll <- function(dat, Theta, deltad, deltas, laVec, nuVec, m) {
    # Calculates the logLikelihood for all the bases
    if (deltad < 0 || deltad > 1 || deltas < 0 || deltas > 1) {
        return(-Inf)
    }

    Asub <- dat[, "A.C"] + dat[, "A.G"] + dat[, "A.T"]
    ALL <- logLikFunOneBaseFast(dat[,"A"], cbind(dat[,"A"]-Asub,dat[,"A.C"],dat[,"A.G"],dat[,"A.T"]),Theta,deltad,deltas,laVec,nuVec,m,1)

    Csub <- dat[, "C.A"] + dat[, "C.G"] + dat[, "C.T"]
    CLL <- logLikFunOneBaseFast(dat[,"C"], cbind(dat[,"C.A"],dat[,"C"]-Csub,dat[,"C.G"],dat[,"C.T"]),Theta,deltad,deltas,laVec,nuVec,m,2)

    Gsub <- dat[, "G.A"] + dat[, "G.C"] + dat[, "G.T"]
    GLL <- logLikFunOneBaseFast(dat[,"G"], cbind(dat[,"G.A"],dat[,"G.C"],dat[,"G"]-Gsub,dat[,"G.T"]),Theta,deltad,deltas,laVec,nuVec,m,3)

    Tsub <- dat[, "T.A"] + dat[, "T.C"] + dat[, "T.G"]
    TLL <- logLikFunOneBaseFast(dat[,"T"], cbind(dat[,"T.A"],dat[,"T.C"],dat[,"T.G"],dat[,"T"]-Tsub),Theta,deltad,deltas,laVec,nuVec,m,4)

    return(ALL + CLL + GLL + TLL)
}

getParams <- function(cp){
    #Utility function nice to update the MCMC iterations matrix
    return(c(cp$Theta,cp$Rho,cp$DeltaD,cp$DeltaS,cp$Lambda,cp$LambdaRight,cp$LambdaDisp))
}

plotTrace<- function(dat,main,k=111){
    #Running median of the MCMC iterations
    plot(1:length(dat),dat,xlab="Iteration",ylab="",main=main,type="l")
}

plotEverything <- function(mcmcOut,hi=0,pl,thin=100){
    #Plots the MCMC traceplot in the form of a running median and
    #histogram of the MCMC iterations
    if (sum(c(cu_pa$same_overhangs==FALSE,
                    cu_pa$fix_disp==FALSE,
                    cu_pa$fix_ti_tv==FALSE))>1){
        #Check if I need to add a extra row
        a_extra_row <- 1
    }else {
        a_extra_row <- 0
    }
    par(mfrow=c(3,2+a_extra_row))
    if(hi){
        hist(mcmcOut$out[,"Theta"],main=expression(theta),xlab="",freq=FALSE)
        if (!mcmcOut$cu_pa$fix_ti_tv){
            hist(mcmcOut$out[,"Rho"],main=expression(rho),xlab="",freq=FALSE)
        }
        hist(mcmcOut$out[,"DeltaD"],main=expression(delta[d]),xlab="",freq=FALSE)
        hist(mcmcOut$out[,"DeltaS"],main=expression(delta[s]),xlab="",freq=FALSE)
        hist(mcmcOut$out[,"Lambda"],main=expression(lambda),xlab="",freq=FALSE)
        if (!mcmcOut$cu_pa$same_overhangs){
            hist(mcmcOut$out[,"LambdaRight"],main=expression(lambda[r]),xlab="",freq=FALSE)
        }
        if (!mcmcOut$cu_pa$fix_disp){
            hist(mcmcOut$out[,"LambdaDisp"],main=expression(sigma[lambda]),xlab="",freq=FALSE)
        }
        hist(mcmcOut$out[,"LogLik"],main="LogLik",xlab="",freq=FALSE)
    }else {
        plotTrace(mcmcOut$out[,"Theta"],main=expression(theta))
        if (!mcmcOut$cu_pa$fix_ti_tv){
            plotTrace(mcmcOut$out[,"Rho"],main=expression(theta))
        }
        plotTrace(mcmcOut$out[,"DeltaD"],main=expression(delta[d]))
        plotTrace(mcmcOut$out[,"DeltaS"],main=expression(delta[s]))
        plotTrace(mcmcOut$out[,"Lambda"],main=expression(lambda))
        if (!mcmcOut$cu_pa$same_overhangs){
            plotTrace(mcmcOut$out[,"LambdaRight"],main=expression(lambda[r]))
        }
        if (!mcmcOut$cu_pa$fix_disp){
            plotTrace(mcmcOut$out[,"LambdaDisp"],main=expression(sigma[lambda]))
        }
        plotTrace(mcmcOut$out[,"LogLik"],main="LogLik")
    }
    par(mfrow=c(1,1))
}

accRat <- function(da){
    #A rough measure of the acceptance ratio
    return(length(unique(da))/length(da))
}

adjustPropVar <- function(mcmc,propVar){
    #Adjust the proposal variance to get something near .22
    for (i in colnames(mcmc$out)){
        if (i=="LogLik"){
            next
        } else if (i=="LambdaRight" & mcmc$cu_pa$same_overhangs){
            next
        } else if (i=="LambdaDisp" & mcmc$cu_pa$fix_disp){
            next
        } else if (i=="Rho" & mcmc$cu_pa$fix_ti_tv){
            next
        }
        rat <- accRat(mcmc$out[,i])
        if (rat<0.1){
            propVar[[i]] <- propVar[[i]]/2
        } else if (rat>0.3) {
            propVar[[i]] <- propVar[[i]]*2
        }
    }
    return(propVar)
}

runGibbs <- function(cu_pa,iter){
    #Sampling over the conditional posterior distribution
    #for the parameters.
    esti <- matrix(nrow=iter,ncol=8)
    colnames(esti) <- c("Theta","Rho","DeltaD","DeltaS","Lambda","LambdaRight","LambdaDisp","LogLik")
    for (i in 1:iter){
        cu_pa<-updateTheta(cu_pa)
        if (!cu_pa$fix_ti_tv){
            #Fix the transition and transversion ratio
            cu_pa<-updateRho(cu_pa)
        }
        cu_pa<-updateDeltaD(cu_pa)
        cu_pa<-updateDeltaS(cu_pa)
        cu_pa<-updateLambda(cu_pa)
        if (!cu_pa$same_overhangs){
            #Not the same overhangs update lambda right
            cu_pa <- updateLambdaRight(cu_pa)
        }
        if (!cu_pa$fix_disp){
            #Allowing dispersion in the overhangs
            cu_pa<-updateLambdaDisp(cu_pa)
        }
        esti[i,c(1:7)] <- getParams(cu_pa)
        esti[i,"LogLik"] <- logLikAll(cu_pa$dat,cu_pa$ThetaMat,cu_pa$DeltaD,cu_pa$DeltaS,cu_pa$laVec,cu_pa$nuVec,cu_pa$m)
        if (! (i %% 1000) && cu_pa$verbose){
            cat("MCMC-Iter\t",i,"\t",esti[i,"LogLik"],"\n")
        }
    }
    return(list(out=esti,cu_pa=cu_pa))
}

simPredCheck <- function(da,output){
    #Simulates one draw from the posterior predictive distribution
    #and the probability of a C>T substitution because of a cytosine
    #demnation.
    bases <- da[,c("A","C","G","T")]
    #Constructing the lambda vector
    if (output$cu_pa$same_overhangs){
        laVec <- seqProbVecLambda(sample(output$out[,"Lambda"],1),
                                  sample(output$out[,"LambdaDisp"],1),
                                  output$cu_pa$m,
                                  output$cu_pa$termini)
    }else {
        laVecLeft <- seqProbVecLambda(sample(output$out[,"Lambda"],1),
                                      sample(output$out[,"LambdaDisp"],1),
                                      output$cu_pa$m)
        laVecRight <- seqProbVecLambda(sample(output$out[,"LambdaRight"],1),
                                       sample(output$out[,"LambdaDisp"],1),
                                       output$cu_pa$m)
        laVec <- c(laVecLeft[1:(output$cu_pa$m/2)],laVecRight[(output$cu_pa$m/2+1):output$cu_pa$m])
    }
    #Constructing the nu vector
    nuVec <- output$cu_pa$nuVec

    #Sample the other parameters
    des <- sample(output$out[,"DeltaS"],1)
    ded <- sample(output$out[,"DeltaD"],1)
    the <- sample(output$out[,"Theta"],1)
    rho <- sample(output$out[,"Rho"],1)
    pmat <- getPmat(the,rho,output$cu_pa$acgt)
    ptransCT <- pmat["C","T"]
    ptransCC <- pmat["C","C"]
    ptransGA <- pmat["G","A"]
    ptransGG <- pmat["G","G"]
    #
    coln <- c("A.C","A.G","A.T","C.A","C.G","C.T","G.A","G.C","G.T","T.A","T.C","T.G")
    subs <- matrix(NA,nrow=nrow(output$cu_pa$dat),ncol=4+length(coln))
    colnames(subs) <- c("A","C","G","T",coln)
    #
    damProb <- rep(NA,nrow(output$cu_pa$dat))
    damProbGA <- damProb
    for (i in 1:nrow(output$cu_pa$dat)){
        #Construct the site specific probabilities
        pct <- nuVec[i]*(laVec[i]*des+ded*(1-laVec[i]))
        pga <- (1-nuVec[i])*(laVec[i]*des+ded*(1-laVec[i]))
        pDamMat <- matrix(c(
                         1,0,0,0,
                         0,1-pct,0,pct,
                         pga,0,1-pga,0,
                         0,0,0,1
                         ),nrow=4,byrow=TRUE)
        ThetapDam <- pDamMat %*% pmat
        #Calculate the probability C.T due to cytosine demanation
        damProb[i] <- ptransCC*pct/(ptransCC*pct+ptransCT)
        #Do not forget the reverse complement
        damProbGA[i] <- ptransGG*pga/(ptransGG*pga+ptransGA)
        #Then draw from a multinomial distribution
        subs[i,c("A.C","A.G","A.T")] <- t(rmultinom(1,output$cu_pa$dat[i,"A"],ThetapDam[1,]))[-1]/output$cu_pa$dat[i,"A"]
        subs[i,c("C.A","C.G","C.T")] <- t(rmultinom(1,output$cu_pa$dat[i,"C"],ThetapDam[2,]))[-2]/output$cu_pa$dat[i,"C"]
        subs[i,c("G.A","G.C","G.T")] <- t(rmultinom(1,output$cu_pa$dat[i,"G"],ThetapDam[3,]))[-3]/output$cu_pa$dat[i,"G"]
        subs[i,c("T.A","T.C","T.G")] <- t(rmultinom(1,output$cu_pa$dat[i,"T"],ThetapDam[4,]))[-4]/output$cu_pa$dat[i,"T"]
    }
    return(list(subs=subs,damProb=damProb,damProbGA=damProbGA))
}

calcSampleStats <- function(da,X){
    #Summary statistics of the posterior distributions
    return(data.frame(
                      x=1:nrow(da),
                      pos=da[,"Pos"],
                      mea=apply(X,1,mean),
                      med=apply(X,1,median),
                      loCI=apply(X,1,quantile,c(0.025), na.rm = TRUE),
                      hiCI=apply(X,1,quantile,c(0.975), na.rm = TRUE)
                      ))
}

postPredCheck <- function(da,output,samples=10000){
    #Plots the 95% posterior predictive intervals with the data as lines.
    #Returns the site specific probability of a C>T or G>A substitution
    #because of a cytosine demnation.
    CTs <- matrix(NA,nrow=nrow(da),ncol=samples)
    GAs <- matrix(NA,nrow=nrow(da),ncol=samples)
    REs <- matrix(NA,nrow=nrow(da),ncol=samples)
    C2TProbs <- matrix(NA,nrow=nrow(da),ncol=samples)
    G2AProbs <- matrix(NA,nrow=nrow(da),ncol=samples)
    #Two indices here, 1-based and the relative one
    da <- cbind(1:(nrow(da)),da)
    colnames(da)[1] <- "oneBased"
    #Get the breaks depending on parameters for pretty plots
    if (output$cu_pa$termini == "both") {
        bres <- c(seq(from=1,to=floor(nrow(da)/2),by=2),rev(seq(from=nrow(dat),to=floor(nrow(da)/2)+1,by=-2)))
    } else if (output$cu_pa$termini == "5p") {
        bres <- seq(from=1,to=nrow(da),by=2)
    } else if (output$cu_pa$termini == "3p") {
        bres <- seq(from=nrow(dat),to=1,by=-2)
    }else {
        abort("There is something fishy with the options")
    }
    labs <- dat[bres,"Pos"]
    #Sample from the posterior predicitive distibution
    for (i in 1:samples){
        sam <- simPredCheck(da,output)
        C2TProbs[,i] <- sam$damProb
        G2AProbs[,i] <- sam$damProbGA
        CTs[,i] <- sam$subs[,"C.T"]
        GAs[,i] <- sam$subs[,"G.A"]
        REs[,i] <- apply(sam$subs[,c("A.C","A.G","A.T","C.A","C.G","G.C","G.T","T.A","T.C","T.G")],1,mean)
    }
    CTsStats <- calcSampleStats(da,CTs)
    GAsStats <- calcSampleStats(da,GAs)
    REsStats <- calcSampleStats(da,REs)
    #Plotting the posterior predictive intervals
    p <- ggplot()+
         geom_point(aes(x,mea,colour="C->T"),data=CTsStats)+
         geom_point(aes(x,mea,colour="G->A"),data=GAsStats)+
         geom_point(aes(x,mea,colour="Others"),data=REsStats)+
         geom_errorbar(aes(x=x,ymin=loCI,ymax=hiCI,color="C->T"),data=CTsStats)+
         geom_errorbar(aes(x=x,ymin=loCI,ymax=hiCI,color="G->A"),data=GAsStats)+
         geom_errorbar(aes(x=x,ymin=loCI,ymax=hiCI,color="Others"),data=REsStats)+
         geom_line(aes(oneBased,C.T/C),color="red",data=data.frame(da))+
         geom_line(aes(oneBased,G.A/G),color="green",data=data.frame(da))+
         geom_line(aes(oneBased,((A.C+A.G+A.T)/A+(C.A+C.G)/C+(G.C+G.T)/G+(T.A+T.C+T.G)/T)/10),color="blue",data=data.frame(da))+
         labs(y = "Substitution rate",
              x = "Relative position",
              colour = "Subs. type",
              title = "Posterior prediction intervals")+
         scale_x_continuous(breaks=bres,labels=labs)
    if (output$cu_pa$use_bw_theme){
        p <- p+theme_bw()
    }
    plot(p)
    #The correcting probabilities
    coProbs <- cbind(da[,"Pos"],apply(C2TProbs,1,mean),apply(G2AProbs,1,mean))
    colnames(coProbs) <- c("Position","C.T","G.A")
    return(coProbs)
}

writeMCMC <- function(out,filename){
    #Writes the posterior samples to a file
    parameters <- c("Theta","DeltaD","DeltaS","Lambda")
    if (!out$cu_pa$fix_ti_tv){
        parameters <- c(parameters,"Rho")
    }
    if (!out$cu_pa$same_overhangs){
        parameters <- c(parameters,"LambdaRight")
    }
    if (!out$cu_pa$fix_disp){
        parameters <- c(parameters,"LambdaDisp")
    }
    parameters <- c(parameters,"LogLik")
    write.csv(out$out[,parameters],paste(filename,".csv",sep=""))
    #Now calculate summary statistic of the posterior distributions
    mea <- apply(out$out[,parameters],2,mean)
    std <- apply(out$out[,parameters],2,sd)
    qua <- apply(out$out[,parameters],2,quantile,seq(from=0,to=1,by=.025))
    acc <- apply(out$out[,parameters],2,accRat)
    summStat <- rbind(mea,std,acc,qua)
    rownames(summStat)[1] <- "Mean"
    rownames(summStat)[2] <- "Std."
    rownames(summStat)[3] <- "Acceptance ratio"
    write.csv(summStat,paste(filename,"_summ_stat.csv",sep=""))
}


#' V-structure bias, binary exposure and binary outcome.
#'
#' Explore bias due to sample ascertainment when the exposure and outcome are binary variables. This class explores the range or OR generated by parameters in the following model:
#' \eqn{P(S = 1 | A,Y) = \beta_0 + \beta_a A + \beta_y Y + \beta_{ay}AY}
#' Where A is a binary exposure, Y is a binary outcome and S indicates whether an individual is present in the dataset
#' \eqn{P(S = 1)} is the proportion of the population that is present in the data.
#'
#' @importFrom R6 R6Class
#' @export
VBB <- R6Class("VBB", list(

	#' @field param Dataframe of parameter range list
	param = NULL,
	details = list(),

	#' @description
	#' Calculate the expected OR under collider bias when null hypothoses of OR = 1 is true:
	#' @param b0 Baseline probability of being selected
	#' @param ba Effect of A on being selected
	#' @param by Effect of Y on being selected
	#' @param bay Effect of joint AY interaction on being selected
	#'
	#' @return Odds ratio
	or_calc = function(b0, ba, by, bay)
	{
		b0 * (b0 + ba + by + bay) / ((b0 + ba) * (b0 + by))
	},

	#' @description
	#' Calculate the proportion of samples included in the model for a given set of parameters
	#' @param b0 Baseline probability of being selected
	#' @param ba Effect of A on being selected
	#' @param by Effect of Y on being selected
	#' @param bay Effect of joint AY interaction on being selected
	#' @param pA \eqn{P(A = 1)} in the general population
	#' @param pY \eqn{P(Y = 1)} in the general population
	#' @param pAY \eqn{P(A = 1, Y = 1)} in the general population
	#'
	#' @return P(S = 1)
	ps_calc = function(b0, ba, by, bay, pA, pY, pAY)
	{
		b0 + ba * pA + by * pY + bay * pAY
	},

	#' @description
	#' Specify a set of parameters for the structural equation, and calculate the set of odds ratios that would be obtained, assuming the odds ratio of A on Y in the total population is 1.
	#' @param target_or Target odds ratio. e.g. in an observational study this OR is observed, and the researcher seeks to find parameter ranges that could explain it
	#' @param pS Proportion of the population present in the sample
	#' @param pA \eqn{P(A = 1)} in the general population
	#' @param pY \eqn{P(Y = 1)} in the general population
	#' @param pAY \eqn{P(A = 1, Y = 1)} in the general population
	#' @param b0_range Baseline probability of being selected. Provide a range of values to explore e.g. `c(0,1)`
	#' @param ba_range Effect of A on being selected into the sample. Provide a range of values to explore e.g. `c(-0.2, 0.2)`
	#' @param by_range Effect of Y on being selected into the sample. Provide a range of values to explore e.g. `c(-0.2, 0.2)`
	#' @param bay_range Effect of AY interaction on being selected into the sample. Provide a range of values to explore e.g. `c(-0.2, 0.2)`
	#' @param granularity Granularity of the search space. Default=`100`, going much higher can be computationally difficult
	#' @param pS_tol Tolerance of pS value Default=`0.0025`
	#' @return Data frame of parameters that satisfy the `target_or` and target `pS` values
	parameter_space = function(target_or, pS, pA, pY, pAY, b0_range, ba_range, by_range, bay_range, granularity=100, pS_tol=0.0025)
	{
		s <- sign(log(target_or))
		param <- expand.grid(
			pA = pA,
			pY = pY,
			pAY = pAY,
			b0 = seq(b0_range[1], b0_range[2], length.out=granularity) %>% unique(),
			ba = seq(ba_range[1], ba_range[2], length.out=granularity) %>% unique(),
			by = seq(by_range[1], by_range[2], length.out=granularity) %>% unique(),
			bay = seq(bay_range[1], bay_range[2], length.out=granularity) %>% unique()
		)
		message(nrow(param), " parameter combinations")
		self$details$parameter_combinations <- nrow(param)
		param <- param %>%
		dplyr::mutate(ps1 = self$ps_calc(b0=b0, ba=ba, pA=pA, by=by, pY=pY, bay=bay, pAY=pAY)) %>%
		dplyr::filter(ps1 >= pS - pS_tol & ps1 <= pS + pS_tol & b0 + by + ba + bay > 0) %>%
		dplyr::mutate(or = self$or_calc(b0=b0, ba=ba, by=by, bay=bay))
		message(nrow(param), " within pS_tol")
		self$details$within_ps_told <- nrow(param)
		if(target_or >= 1)
		{
			param <- subset(param, or >= target_or & or < 50)
		} else {
			param <- subset(param, or <= target_or & or > 0)
		}
		message(nrow(param), " beyond OR threshold")
		self$details$beyond_or <- nrow(param)
		self$param <- dplyr::as_tibble(param)
	},

	#' @description
	#' 3D scatterplot of output from `parameter_space` function. See [`plot3D::scatter3D`] for info on parameters
	#' @param ticktype Default=`"detailed"`
	#' @param theta Default=`130`
	#' @param phi Default=`0`
	#' @param bty Default=`"g"`
	#' @param xlab Default=`"ba"`
	#' @param ylab Default=`"by"`
	#' @param zlab Default=`"b0"`
	#' @param clab Default=`"OR"`
	#' @param ... Further parameters to be passed to [`plot3D::scatter3D`]
	#' @return Scatterplot
	scatter3d = function(ticktype="detailed", theta=130, phi=0, bty="g", xlab=expression(beta[A]), ylab=expression(beta[Y]), zlab=expression(beta[AY]), clab=expression(beta[0]), ...)
	{
		plot3D::scatter3D(x=self$param$ba, y=self$param$by, z=self$param$bay, colvar=self$param$b0, ticktype = ticktype, theta=theta, phi=phi, bty=bty, xlab=xlab, ylab=ylab, zlab=zlab, clab=clab, ...)
	},

	#' @description
	#' Simple scatterplot of output from parameter_space function. Plotted are the parameter values of `b0`, `ba` and `by` that can give rise to an OR \eqn{\ge} `target_or`
	scatter = function()
	{
		ggplot2::ggplot(self$param, ggplot2::aes(x=ba, y=by)) +
		ggplot2::geom_point(ggplot2::aes(colour=b0)) +
	    ggplot2::xlab(expression(beta[A])) +
    	ggplot2::ylab(expression(beta[Y])) +
    	ggplot2::labs(colour = expression(beta[0]))
	},

	#' @description
	#' Histogram of odds ratios across the range of parameter values
	#' @param bins How many bins to split histogram. Default=`30`
	#'
	#' @return ggplot object
	histogram = function(bins=30)
	{
		ggplot2::ggplot(self$param, ggplot2::aes(x=or)) +
		ggplot2::geom_histogram(bins=bins) +
		ggplot2::scale_x_log10() +
		ggplot2::xlab("OR")
	}

))