##require(mgcv)

##'convience function for the logistic transform
##' @param x the number to be transformed
##'
##' @return the logistic transform

logistic <- function(x){
  return(log(x/(1-x)))
}

##'convience function for the inverse logistic transform
##' @param x the number to be transformed
##'
##' @return the inverse logistic transform

inv_logistic <- function(x) {
  return(exp(x)/(1+exp(x)))
}

##' Function to estimate the progress on an epidemic
##' using the method of Viboud and Chowell.
##'
##' @param epi.curve an epidemic curve
##' @param cum.sum the cumulative sums to use...allows us to pass
##'        in epi.curve with missing observations.
##' @param r intrinsic growth parameter
##' @param p "deceleration of growth' parameter
##' @param K final size of the outbreak
##' @param ... additional options to optim
##'
##' @return expected final size of outbreak and params specifying outbreak

final.size.ViboudChowell <- function(epi.curve,
                                     cum.curve = cumsum(epi.curve),
                                     r =1,
                                     p = 0.5,
                                     K = max(cum.curve),...){

  log.K <- log(K)
  log.r <- log(r)
  logistic.p <- logistic(p)

  ## NOTE: when using cum.curve=cumsum(epi.curve), cum.curve is using whatever epi.curve is when it is first used
  cum.curve <- cum.curve[-length(cum.curve)] ##this was here because we don't have a groundtruth data for the last element of the cumsum (see preds for why)
  ##line up epi curve data with cumulative data
  epi.curve <- epi.curve[-1]

  if(length(epi.curve) == 0){
    return(NA)
  }

  ##current fit will be by optim. Setting objective function
  ##takes parameter in order r,p,K...assuming alpha is 1 for now
  ob.func <- function(param) {
    loc.r <- exp(param[1]) #range 0 to inf
    loc.p <- inv_logistic(param[2]) #range 0 to inf
    loc.K <- exp(param[3]) #range 0 to inf

    preds <- loc.r*cum.curve^loc.p * (1 - cum.curve/loc.K)
    rc <- sum(abs(epi.curve - preds))/sum(epi.curve)
    return(rc)
  }

  #call optim wiht som not insane starting values
  tmp <- optim(c(log.r,logistic.p,log.K), ob.func, ...)

  return(list(r = exp(tmp$par[1]), p = inv_logistic(tmp$par[2]), K = exp(tmp$par[3])))
}

##' Function to estimate the progress on an epidemic
##' using the method of Viboud and Chowell, with shared
##' parameters accross epidmeics
##'
##' @param ecs a list of epidemic curves
##' @param cum.curves the cumulative sums to use...allows us to pass
##'        in ecs with missing observations.
##' @param r intrinsic growth parameter
##' @param p "deceleration of growth' parameter
##' @param K final size of the outbreak
##' @param ... additional options to optim
##'
##' @return expected final size of outbreak and params specifying outbreak
final.size.ViboudChowell.pooled <- function(ecs,
                                     cum.curves = sapply(ecs, cumsum),
                                     r =1, p = 0.5,
                                     K = sapply(cum.curves, max),...){

  log.K <- log(K)
  log.r <- log(r)
  logistic.p <- logistic(p)

  for (i in 1:length(ecs)) {
    ## NOTE: when using cum.curve=cumsum(epi.curve), cum.curve is using whatever epi.curve is when it is first used
    cum.curves[[i]] <- cum.curves[[i]][-length(cum.curves[[i]])] ##this was here because we don't have a groundtruth data for the last element of the cumsum (see preds for why)
    ##line up epi curve data with cumulative data
    ecs[[i]] <- ecs[[i]][-1]

    if(length(ecs[[i]]) == 0){
      stop("Empty epidemic curve")
    }
  }

  ##current fit will be by optim. Setting objective function
  ##takes parameter in order r,p,K...assuming alpha is 1 for now
  ob.func <- function(param) {
    loc.r <- exp(param[1]) #range 0 to inf
    loc.p <- inv_logistic(param[2]) #range 0 to inf
    loc.K <- exp(param[3:length(param)]) #range 0 to inf

    rc <- 0

    for (i in 1:length(ecs)) {
      cum.curve <- cum.curves[[i]]
      epi.curve <- ecs[[i]]
      preds <- loc.r*cum.curve^loc.p * (1 - cum.curve/loc.K[i])
      #print(i)
      #print(sum(abs(epi.curve - preds))/sum(epi.curve))
      denom <- sum(epi.curve)
      if(denom==0) {denom<-1}
      rc <- rc + sum(abs(epi.curve - preds))/denom
    }

    return(rc)
  }

    print(log.r)
    print(logistic.p)
    print(range(exp(log.K)))
  #call optim wiht som not insane starting values
  tmp <- optim(c(log.r,logistic.p,log.K), ob.func, ...)

    ##print(tmp)

  return(list(r = exp(tmp$par[1]), p = inv_logistic(tmp$par[2]), K = exp(tmp$par[3:(2+length(ecs))])))
}

##' Function to estimate parameters given K is fixed using K from the gam
##' using the method of Viboud and Chowell.
##'
##' @param epi.curve an epidemic curve
##' @param cum.sum the cumulative sums to use...allows us to pass
##'        in epi.curve with missing observations.
##' @param r intrinsic growth parameter
##' @param p "deceleration of growth' parameter
##' @param K epidemic curves generated from the gam model
##' @param ... additional options to optim
##'
##' @return refitted r and p values

final.size.ViboudChowell.fit.params <- function(epi.curve,
                                                cum.curve = cumsum(epi.curve),
                                                r=1,
                                                p = 0.5,
                                                K = max(cum.curve),...){

  log.K <- log(K)
  log.r <- log(r)
  logistic.p <- logistic(p)

  #print(log.K)
  #print(log.r)
  #print(logistic.p)

  ## NOTE: when using cum.curve=cumsum(epi.curve), cum.curve is using whatever epi.curve is when it is first used
  cum.curve <- cum.curve[-length(cum.curve)] ##this was here because we don't have a groundtruth data for the last element of the cumsum (see preds for why)
  ##line up epi curve data with cumulative data
  epi.curve <- epi.curve[-1]

  if(length(epi.curve) == 0){
    return(100000)
  }

  ##current fit will be by optim. Setting objective function
  ##takes parameter in order r,p,K...assuming alpha is 1 for now
  ob.func <- function(param) {
    loc.r <- exp(param[1])

    loc.p <- inv_logistic(param[2]) #range 0 to 1

    preds <- loc.r*cum.curve^loc.p * (1 - cum.curve/K)
    rc <- sum(abs(epi.curve - preds))/sum(epi.curve)
    return(rc)
  }

  #call optim wiht som not insane starting values
  tmp <- optim(c(log.r,logistic.p), ob.func, ...)
  #cat("fit.parms.r", log.r, ":", logistic.p, "\n")

  return(list(r = exp(tmp$par[1]), p = inv_logistic(tmp$par[2])))
}

##' Function to estimate parameters given K is fixed using K from the gam
##' using the method of Viboud and Chowell using information from all
##' epi curves to create a single set of r and p values.
##'
##' @param epi.curve an list of epidemic curves.
##' @param cum.sum the cumulative sums to use...allows us to pass
##'        in epi.curve with missing observations.
##' @param r intrinsic growth parameter
##' @param p "deceleration of growth' parameter
##' @param K epidemic curves generated from the gam model
##' @param ... additional options to optim
##'
##' @return refitted r and p values
final.size.ViboudChowell.fit.params.pooled <- function(epi.curve,
                                                       cum.curve = lapply(epi.curve,cumsum),
                                                       r=1, p = 0.5,
                                                       K = sapply(cum.curve,max),...){

  log.K <- log(K)
  log.r <- log(r)
  logistic.p <- logistic(p)

  #print(log.K)
  #print(log.r)
  #print(logistic.p)

  ## NOTE: when using cum.curve=cumsum(epi.curve), cum.curve is using whatever epi.curve is when it is first used
  # cum.curve <- cum.curve[-length(cum.curve)] ##this was here because we don't have a groundtruth data for the last element of the cumsum (see preds for why)
  cum.curve <- lapply(cum.curve,function(x){x[-length(x)]}) ##this was here because we don't have a groundtruth
  ##line up epi curve data with cumulative data
  # epi.curve <- epi.curve[-1]
  epi.curve <- lapply(epi.curve,function(x){x[-1]})

  if(length(epi.curve) == 0){
    # return(100000)
    stop("Use at least one epi curve.")
  }
  #Debug only
  lapply(epi.curve,function(x){if(length(x) == 0){stop("Do not use empty epi curves.")}})

  ##current fit will be by optim. Setting objective function
  ##takes parameter in order r,p,K...assuming alpha is 1 for now

  ob.func <- function(param) {
    rc <- 0
    for(i in 1:length(epi.curve)){
      loc.r <- exp(param[1])

      loc.p <- inv_logistic(param[2]) #range 0 to 1

      # preds <- loc.r*cum.curve^loc.p * (1 - cum.curve/K)
      preds <- loc.r*cum.curve[[i]]^loc.p * (1 - cum.curve[[i]]/K[i])

      denom <- sum(epi.curve[[i]])
      if(denom==0) {denom<-1}

      rc <- rc + sum(abs(epi.curve[[i]] - preds))/denom

    }
    return(rc)
  }

    ##call optim wiht som not insane starting values
    print(r,p)
    print(c(log.r,logistic.p))
    print(K)
    tmp <- optim(c(log.r,logistic.p), ob.func, ...)
    print(tmp)
  cat("fit.parms.r", exp(tmp$par[1]), ":", exp(tmp$par[2]), "\n")

    rc <- list(r = exp(tmp$par[1]), p = inv_logistic(tmp$par[2]))
    ##don't let these be 0, sub with  10^-12
    if (rc$r == 0) {rc$r<-10^-12}
    if (rc$p == 0) {rc$p<-10^-12}
  return(rc)

}

##' Function to estimate K using updated parameters
##' using the method of Viboud and Chowell.
##'
##' @param epi.curve an epidemic curve
##' @param cum.sum the cumulative sums to use...allows us to pass
##'        in epi.curve with missing obsrvations.
##' @param r intrinsic growth parameter
##' @param p "deceleration of growth' parameter
##' @param K final size
##' @param ... additional options to optim
##'
##' @return expected final size of outbreak

final.size.ViboudChowell.fit.K <- function(epi.curve,
                                           cum.curve = cumsum(epi.curve),
                                           r=1,
                                           p=0.5,
                                           K = max(cum.curve), ...){

  logistic.p <- logistic(p)
  log.r <- log(r)
  log.K <- log(K)

  #cat("passed.parms.r", log.r, ":", logistic.p, "\n")

  ## NOTE: when using cum.curve=cumsum(epi.curve), cum.curve is using whatever epi.curve is when it is first used
  cum.curve <- cum.curve[-length(cum.curve)] ##this was here because we don't have a groundtruth data for the last element of the cumsum (see preds for why)
  ##line up epi curve data with cumulative data
  epi.curve <- epi.curve[-1]

  if(length(epi.curve) == 0){
    #return(100000)
    stop("Use at least one epi curve.")
  }

  ##current fit will be by optim. Setting objective function
  ##takes parameter in order r,p,K...assuming alpha is 1 for now

  ob.func <- function(param) {
    loc.K <- exp(param[1]) #range 0 to inf

    preds <- r*cum.curve^p * (1 - cum.curve/loc.K)

    if(length(epi.curve) < 5){
      warning("This needs longer epi curves")
      return(0)
    }

    #rc <- sum(((log(epi.curve+1) - log(preds+1))^2))  #+ loc.K^.1875
    rc <- sum(abs(epi.curve - preds))/sum(epi.curve) +
        (abs(max(cum.curve)-loc.K)^.01-1) #weak penalty for additional cases
    ##cat("**", loc.K,":", K,":", rc,"\n")#Debug

    return(rc)
  }

  #call optim wiht som not insane starting values
  tmp <- optim(c(log.K), ob.func, method = "Brent",
               lower = log(max(cum.curve, na.rm = T)) ,
               upper = log(7*10^9), ...)
  #tmp <- optimize(ob.func, method = "L-BFGS-B", lower = 0 , upper = log(7*10^9), ...)

  #print(tmp) ##DEBUG

  #if (exp(tmp$par[1])>10^7) stop("Exploding K")
  return(list(K = exp(tmp$par[1])))
}

##' Function gets the error compared to the final estimate
##' for final size estimates over the entire epidemic
##' curve
##'
##' @param epi.curve the epidemic curve to be analyzed
##' @param ... additional parameters to the fitting
##'
##' @return a "time series" of errors

ts.err.final.size.ViboudChowell <- function(epi.curve, ...) {

}

##'Function runs a jacknife calculation on the final size
##'for the Viboud Chowell model
##'
##' @param epi.curve
##' @param ... additional parameters to optim
##'
##' @return

jackknife.final.size.ViboudChowell <- function(epi.curve,...) {

  rc <- vector(length=length(epi.curve)-1)
  cum.curve<- cumsum(epi.curve)

  for (i in 2:length(epi.curve)) {
    tmp.cum <- cum.curve[-(i-1)]
    tmp.epi <- epi.curve[-i]
    rc[i-1] <- final.size.ViboudChowell(tmp.epi,tmp.cum, ...)
  }

  return(rc)
}

##' Function generates a bunch of epidemic curves of different
##' percent done based on a ViboudChowell model given values of
##' r and p and a series of final sizes.
##'
##' @param pct a vector of percent of epidemic done of the same length
##'     as the number we should generate.
##' @param K a vector of final epidemic sizes
##' @param r the growth rate
##' @param p the extent the growthrate is super or sub exponential
##'
##' @return a list of epidemic curves
gen.epicurves.ViboudChowell <- function (pct, K, r, p) {
  rc <- list()

  for (i in 1:length(pct)) {
    ## for each epidemic we want to generate, start with
    ## a single case and then loop until we generate
    ## the appropriate percentage of the final size.
    ec <- (1)
    while (sum(ec)<K[i]*pct[i]) {
        ec <- c(ec,rpois(1, r*sum(ec)^p*(1-sum(ec)/K[i])))
        ##ec <- c(ec,r*sum(ec)^p*(1-sum(ec)/K[i]))#debug
    }
    rc[[i]] <- ec
  }

  return(rc)
}

##' function generates a bunch of epidemic curves of a different percent done
##' based on a stochastic discrete time SIR model. Presume epidemic starts with a single
##' case.
##'
##' @param pct a vector of the percent epidemic done of th esmae length we should generate
##' @param beta a vector of betas for each simulation
##' @param N a verctor of population sizes
##' @param gamma a vector of the recovery rates, or a sigle shared value
##'
##' @return a list of epidemic curves and a vector of final sizes.
gen.epidemic.curves.SIR <- function(pct, beta, N, gamma) {

    if (length(beta)==1) {beta <- rep(beta, length(pct))}
    if (length(gamma)==1) {gamma <- rep(gamma, length(pct))}
    if (length(N)==1) {gamma <- rep(N, length(pct))}

    rc_ecs <- list()
    rc_fs <- c()

    for (i in 1:length(pct)) {
        #print(i)
        ## generate the epidemic curve.
        repeat {
            S <- N[i]-1
            I <- 1
            R <- 0

            curve <-1

            while (I > 0) {
                infs <- rbinom(1,S, 1-exp(-I*beta[i]/N[i]))
                recovs <- rbinom(1,I, 1-exp(-gamma[i]))
                S <- S - infs
                I <- I + infs - recovs
                R <- R + recovs

                curve <- c(curve, infs)
            }

            if (sum(curve) > 10) { #eliinate stochastic fadeouts
                break
            }
        }

        ## truncate it by pct
        fs <- sum(curve)

        target_sz <-fs * pct[i]
        ind <- max(c(which(cumsum(curve)<=target_sz),2)) #ust have at least 2 obse

        rc_ecs[[i]] <- curve[1:ind]
        rc_fs <- c(rc_fs, fs)

    }

    return(list(ecs=rc_ecs, fs=rc_fs))
}

##' Perform an MCMC to estimate percent of epidemic complete from
##' a combination of covariates and predictor variables. Uses GAMs
##' to fit covariate relationship, and assumes ViboudChowell
##' underlying model.
##'
##' @param epi.curves all the epi curves we are going
##' @param x data frame of covariates
##' @param f formula to add to use in the GAM. Assume outcome variable
##'        is called K
##' @param mcmc.iter the number of interations to run
##'
##' @return the samples from the MCMC

simple.EPInf.mcmc <- function (epi.curves, x, f, mcmc.iter = 1000) {
  require(mgcv)

  ##first determine priors for the percent done.
  expected.K <- rep(0, length(epi.curves))
  for (i in 1:length(epi.curves)) {
    expected.K[i] <-
      final.size.ViboudChowell(epi.curves[[i]])
  }

  pcts <- sapply(epi.curves, sum)/expected.K
  ##convert pcts above 1 to fractionally less than 1.
  pcts[pcts>1] <- 0.999999999

  cur.pcts <- log(pcts/(1-pcts))

  totals <- sapply(epi.curves, sum)

  ##set up the matrix for MCMC return
  rc <- matrix(nrow=mcmc.iter, ncol=length(pcts))

  ##fit model at starting parameters. Note that here we can just
  ##use K
  x$K <- sqrt(expected.K)
  mdl <- gam(formula(f),data=x)

  ##calculate the likelihood of the observed
  ##given pcts and expected K.
  cur.ll <- sum(dpois(totals,logistic(cur.pcts)*
                        predict(mdl)^2, log=T)) +
    sum(dpois(round(expected.K), expected.K, log=TRUE)) #clearly part of the problem

  rc[1,] <- cur.pcts

  ##Do the MCMC loops
  for (i in 2:mcmc.iter) {
    ##propose new pcts for a random place
    prop.pcts <- cur.pcts
    ind <- sample(length(prop.pcts),1)
    prop.pcts[ind] <- cur.pcts[ind] + rnorm(1, 0,1)
    prop.K <- totals/logistic(prop.pcts)

    ##refit model
    x$K <- sqrt(prop.K)
    mdl <- gam(formula(f),data=x)

    ##calculate proposal likelihood
    prop.ll <- sum(dpois(totals,logistic(prop.pcts)*
                           predict(mdl)^2, log=T)) +
      sum(dpois(round(prop.K), expected.K, log=TRUE))

    if ((prop.ll - cur.ll) > log(runif(1))) {
      ##accept
      cur.ll <- prop.ll
      cur.pcts <- prop.pcts
    }

    rc[i,] <- cur.pcts

  }

  return(rc)

}

##' Simple compare function that will be used in simple.epiInf.EM to generate
##' the absolute error of the observed and predicted percent complete of the
##' epidemic curve
##' @param this_iter the current iteration of the loop
##' @param last_iter the previous iteration of the loop
##'
##' @return the absolute error of percent complete between the iterations

compare <- function(this_iter, last_iter){
  # if(!(('pcts' %in% names(this_iter)) & ('pcts' %in% names(last_iter)))){
  #   stop("pcts not found")
  # }
  #
  # if(length(this_iter$pcts) != length(last_iter$pcts)){
  #   stop("arguments have different lengths")
  # }

    K.diff <- abs(this_iter$K - last_iter$K)
    K.stat.diff <- abs(this_iter$K.stat - last_iter$K.stat)

  return(max(sum(K.diff), sum(K.stat.diff)))
}

##' Initialization function. Estimates final size and
##' parameters based on epidemic curve that will be used to start
##' EM approach.
##' @param epi.curve the epidemic curve to be analyzed
##'
##' @return list of final sizes and percent done of epidemic

initialize.em <- function(epi.curves){

  res <- final.size.ViboudChowell.pooled(epi.curves, method="BFGS")

  return(list(K=res$K, r=res$r,p=res$p))
}

##' Simple EM approach to estimating epidemic progress.
##' Basic algorithm is to initialize using epi-curve data
##' and then interate between fitting model and fitting
##' epi curve data using pooled estimates until convergance.
##' Using a GAM model to start.
##'
##'  @param epi.curves the individual epi curves
##'  @param x data frame of covariates
##'  @param f formula to use in GAM
##'  @param max.iter the maxiumum number of iterations performed
##'  @param threshold the desired precision of output
##'
##'  @return a vector of estimated final sizes
##'
simple.epiInf.EM <- function(epi.curves, x, f, max.iter = 100, threshold = 10^-5){
  require(mgcv)
  #browser()
  ## initialize using information from epidemic curves
  this_iter <- initialize.em(epi.curves)
  #print(this_iter)

  ## We want to use the total observed cases as a lower bound for final size
  #lower_K <- sapply(epi.curves,sum)

  ##Loop until ending critera is met
  iter <- 0
  #print(iter)
  ## make sure values are above the threshold
  last_iter <- list(K = this_iter$K+2*threshold,
                    #pcts=this_iter$pcts+2*threshold,
                    r = this_iter$r+2*threshold,
                    p = this_iter$p+2*threshold)

  Khist <- NULL
  Khist.stat <- NULL
  par.hist <- NULL

  while(
    (compare(last_iter, this_iter) >= threshold) &
    (iter < max.iter)){
    # browser()
    ## Re-starting loop
    last_iter <- this_iter

    ##Get the length of the epi curves.
    epi.curve.length <- c()
    for(i in 1:length(epi.curves)){
      curve.length <- length(epi.curves[[i]])
      epi.curve.length[i] <- curve.length
    }

    ## fit statistical model (use final size for covariates)
    ## where currently model is 'K~x'
    x$K <- round(this_iter$K) #Rounding becuase we are uding poisson
    # x$K = this_iter$K
    #mdl <- gam(formula(f), data = x)
    #mdl <- gam(formula(f), data = x, weights = epi.curve.length)
    mdl <- gam(formula(f), data = x, family = poisson(), weights = epi.curve.length)

    ## predict model
    K.stat <- predict(mdl,type='response')
    #cat("statistical prediction", K.stat, "\n")
    #print(cbind(x$K,K.stat))

    ## re-estimate parameters
    ## only want final percentage complete
    #expected.r <- rep(0, length(epi.curves))

        tmp <- final.size.ViboudChowell.fit.params.pooled(epi.curves,
                                                          K = K.stat,
                                                          r = this_iter$r,
                                                          p = this_iter$p,
                                                          method="BFGS")

    #cat(this_iter$r,"->",tmp$r," : ", this_iter$p, "->", tmp$p, "\n")
    expected.p <- tmp$p
    expected.r <- tmp$r

    ## estimate final size based on epidemic curve
    expected.K <- c()

    for(i in 1:length(epi.curves)) {
        tmp <- final.size.ViboudChowell.fit.K(epi.curves[[i]], r = expected.r, p = expected.p, K = K.stat[[i]])

      expected.K[i] <- tmp$K
    }

    this_iter$K <- expected.K
    this_iter$r <- expected.r
    this_iter$p <- expected.p
    this_iter$K.stat <- K.stat

    Khist <-rbind(Khist, expected.K)
    Khist.stat <- rbind(Khist.stat, K.stat)
    par.hist <- rbind(par.hist, c(this_iter$r, this_iter$p))

    # if(iter %% 10 == 0){
    #   cat("model prediction ",iter,":", expected.K, "\n")
    #   print(summary(mdl))
    #   print(paste("iter =" ,iter, sep=""))
    #   print("K")
    #   print(this_iter$K)
    #   print("r")
    #   print(this_iter$r)
    #   print("p")
    #   print(this_iter$p)
    #   print(K.stat)
    # }

    #print(compare(last_iter, this_iter))
    #print(last_iter)
    #print(this_iter)
    #this_iter$pcts <- mapply(x=epi.curves,y=this_iter$K,function(x,y){x[length(x)]/y})

    #this_iter$pcts[this_iter$pcts > 1] <- 0.999999999
        iter = iter + 1

        cat("Err : ",compare(last_iter, this_iter),"\n")
  }
  print(iter)
  #return(this_iter$pcts)
  rc <- this_iter
  rc$Khist <- Khist
  rc$Khist.stat <- Khist.stat
  rc$par.hist <- par.hist
  return(rc)

}

##' Algorithm does the EM fit of viboud chowell and a gam, but without pooling parameters.
##'
##'

##' Initialization function. Estimates final size
##' based on cumulative epidemic curve that will be
##' used to start the statistical model approach
##'
##' @param epi.curve the epidemic curve to be analyzed
##'
##' @return list of final sizes of the epidemic

initialize_stat <- function(epi.curves){
  K <- sapply(epi.curves, sum)
  return(list(K=K))
}

##' Naive statistical approach to estimating epidemic progress.
##' Basic algorithm is to initialize using epi-curve data
##' and then generate final size from statistical model
##'
##'  @param epi.curves the individual epi curves
##'  @param x data frame of covariates

stat_inference <- function(epi.curves, x){

  fit <- initialize_stat(epi.curves)

  x$K <- round(fit$K)

  mdl <- glm(log(K) ~ x , data = x)

  stat_pred <- predict(mdl,type='response')

  fit$stat_pred <- exp(stat_pred)

  rc <- fit
  return(rc)

}

################### MORE GENERAL FRAMEWORK#################

##' Functoin that fits a general epidemic and statistical model using an EM
##' algorithm.
##'
##' @param epi.curves the individual epidemic curves to fit
##' @param x data frame of covariates. First columns assumed to contain K initialized for the odel fits
##' @param stat.mdl.fit a function that fits the statistical model with the following parameters and returns a fir model:
##'               - x: a data frame of covariates that must include the final size column K a
##' @param epi.mdl.fit a function that calls the epi model with the following parameter and returns a fit model:
##'               - epi.curves: the epidemic curves.
##'               - K: the projected fornal sizes
##'               - prev.mdl : the previous model. should behave when this is null
##' @param stat.mdl.pred: a function that takes in a statisitcal model and returns a vector of predicted final sizes
##' @param epi.mdl.pred: a fuctnion that takes in the epdiemic model and and returns a vector of predicted final sizes
##' @param max.iter the maximum number of iterations to run
##' @param threshold the desired precision of the putput
##'
##'
##' @return a vector of estimated final sizes
##'
epiInf.EM <- function (epi.curves, x,
                       stat.mdl.fit, epi.mdl.fit,
                       stat.mdl.pred, epi.mdl.pred,
                       max.iter=100, threshold = 10^-5) {

    iter <- 0 #keep track of iterations

    ##for the first loop through, make sure that we are abover threshold
    iter.diff <- 2*threshold *2

    ##matrices for holding results.
    K <- matrix(nrow=max.iter, ncol= length(epi.curves))
    K.stat <- matrix(nrow=max.iter, ncol= length(epi.curves))

    ##previous epi model
    prev.epi.mdl <- NULL

    ## Loop until endinc criteria is met
    while ((iter.diff >= threshold) &
           (iter<max.iter))  {

               iter <- iter+1

               ## Fit the statistical model on htis iteration
               fit.stat.mdl <-stat.mdl.fit(x)
               K.stat[iter,] <- stat.mdl.pred(fit.stat.mdl)

               #print(K.stat[iter,])

               ## Fit the epidemic model using the stat stuff
               fit.epi.mdl <- epi.mdl.fit(epi.curves, K.stat[iter,], prev.mdl=prev.epi.mdl)
               prev.epi.mdl <- fit.epi.mdl

               ##print(cbind(fit.epi.mdl$peak.time, fit.epi.mdl$spread, fit.epi.mdl$K)) ##DEBUG

               K[iter,] <- epi.mdl.pred(fit.epi.mdl)

               ## Update the dta matrix with these Ks
               x$K <- K[iter,]

               ## update the iter differential if this is the second iteratoin or beyond
               if (iter>1) {
                   ##iter.diff <- max(sum(abs(K[iter-1,]-K[iter,])),
                   ##                 sum(abs(K.stat[iter-1,]-K.stat[iter,])))
                   iter.diff <- sum(abs(K[iter-1,]-K[iter,]))/length(K[iter,])
                   #print(cbind(K[iter-1,],K[iter,]))

               }

               ##print(cbind(x$K, K[iter,]))
               ##hist(K.stat[iter,]- K[iter,])
               ##print(which(abs(K.stat[iter,]- K[iter,])>10000))
               #cat(iter, ":",iter.diff ,":", range(K[iter,]),":",
               #    range(K.stat[iter,]),"\n")
           }

    ##return a list with the two Ks and the final Ks
    return(list(K=K[iter,],
                K.stat=K.stat[iter,],
                Khist = K[1:iter,],
                Khist.stat = K.stat[1:iter,]))
}

##' Function for doing random forrest fit of the K data appropriate for
##' passing in to epiInf.EM
##'
##' @param x the data frame to fit basedd on
##'
##' @return a fit random forrest model
##'
stat.mdl.rf.fit <- function(x) {
    require(randomForest)

    y <- x$K
    x <- as.matrix(subset(x, select=-K))

    rc <- randomForest(x=x, y=y)

    return(rc)
}

##'Function for doing the predict for duing the predict for the
##' results from a stat.mdl.rf.fit
##'
##' @param mdl the fit model
##'
##' @return a vector of predicted final sizes
##'
stat.mdl.rf.pred <- function(mdl) {
    return(predict(mdl))
}

##' Function for doing random forrest fit of the K data appropriate for
##' passing in to epiInf.EM
##'
##' @param x the data frame to fit basedd on
##'
##' @return a fit random forrest model
##'
stat.mdl.rpart.fit <- function(x) {
    require(rpart)

    f <- formula(paste0("K~",paste(names(subset(x,select=-K)),collapse="+")))
    rc <- rpart(f, data=x)

    return(rc)
}

##'Function for doing the predict for duing the predict for the
##' results from a stat.mdl.rf.fit
##'
##' @param mdl the fit model
##'
##' @return a vector of predicted final sizes
##'
stat.mdl.rpart.pred <- function(mdl) {
    return(predict(mdl))
}

##' Function for doing the fit for a viboud chowell model of the epidemic curves.
##' Parameters are considered to be drawn from a shared distribution. Fit is done via optim
##'
##' @param ecs the epidemic curves
##' @param K the Ks
##'
##' @return a vector of parameters for the fit model
##'
epi.mdl.ViboudChowell.fit <- function (ecs, K) {

    ##make some starting values for p and r with a touch of noise
    logistic.p.intercept <- 0
    logistic.p <- rnorm(length(ecs),0,1)

    log.r.intercept <- 0
    log.r <- rnorm(length(ecs),0,1)

    ## Calculate the cumulative incidence curves
    cum.curve = lapply(ecs,cumsum)
    cum.curve <- lapply(cum.curve,function(x){x[-length(x)]}) ##drop the last cumsum observation as it does not contibute
    epi.curve <- lapply(ecs,function(x){x[-1]}) ##first observed epi curve also does not contribute

    lapply(epi.curve,function(x){if(length(x) == 0){stop("Do not use empty epi curves.")}})

    ## will fit by optim using poisson error function at each step with shared priors.
    ## param vector is structured as follows....first parameter is shared r
    ## parameters 2...(length(ec)+1) are individual rs
    ## parameters (length(ec)+2 is shard p
    ## parameters length(ec)+3...2*length(ec)+2 are inividual ps
    ob.func <- function(param) {
        rc <- 0
        for(i in 1:length(epi.curve)){
            loc.r <- exp(param[1+i])
            loc.p <- inv_logistic(param[length(ecs)+2+i]) #range 0 to 1

            ## preds <- loc.r*cum.curve^loc.p * (1 - cum.curve/K)

            preds <- loc.r*cum.curve[[i]]^loc.p * (1 - cum.curve[[i]]/K[i])
            preds[preds<.1] <- .1
            #print(length(param))
            #cat("locp :", loc.p, "locr :", loc.r,"\n")
            #print(cbind(preds,epi.curve[[i]], dpois(epi.curve[[i]],preds)))
            log.prob <- sum(dpois(epi.curve[[i]], preds, log=TRUE)) +
                dnorm(param[1+i],param[1], 3) + ##magic number of variance
                dnorm(param[length(ecs)+2+i], param[length(ecs)+2], 3) ##magic number
            #cat(i,":",log.prob,"\n")

            rc <- rc - log.prob

        }
        return(rc)
    }

    tmp <- optim(c(log.r.intercept, log.r, logistic.p.intercept, logistic.p), ob.func,
                 method="CG")
    return(list(r=exp(tmp$par[(1+(1:length(ecs)))]), p=inv_logistic(tmp$par[(2+length(ecs)+(1:length(ecs)))]), ecs=ecs,
                fit.Ks=K))

}

##' Funciton for doing the "predict" step for the viboud cholel model
##' Essentially takes the p and r parameters and fits K given those parameters
##'
##' Has some weak schrinkage of K towards a single value
##'
##' @param pars the parameters from a model fit given K
##'
##' @return a vector of Ks
##'
epi.mdl.ViboudChowell.pred <- function(pars) {
    log.K <- log(pars$fit.Ks)
    ecs <- pars$ecs

    cum.curve = lapply(ecs,cumsum)
    cum.curve <- lapply(cum.curve,function(x){x[-length(x)]}) ##drop the last cumsum observation as it does not contibute
    epi.curve <- lapply(ecs,function(x){x[-1]}) ##first observed epi curve also does not contribute

    lapply(epi.curve,function(x){if(length(x) == 0){stop("Do not use empty epi curves.")}})

    ## Joint fitting of Ks
    ob.func <- function(param) {
        rc <- 0
        for(i in 1:length(epi.curve)){
            loc.r <- pars$r[i]
            loc.p <- pars$p[i]
            loc.a <- pars$a[i]
            K <- exp(param[i])

            ## preds <- loc.r*cum.curve^loc.p * (1 - cum.curve/K)
            preds <- loc.r*cum.curve[[i]]^loc.p * (1 - (cum.curve[[i]]/K)^loc.a)
            preds[preds<.1] <- .1
            #print(length(param))
            #cat("locp :", loc.p, "locr :", loc.r," loc.K:", K, "\n")
            #print(preds)
            log.prob <- sum(dpois(epi.curve[[i]], preds, log=TRUE))#+
                #dnorm(log(K), mean(param), 2, log=TRUE)

            rc <- rc - log.prob
        }

        return(rc)
    }

    ##tmp <- optim(log.K, ob.func,control=list(maxit=5000))
    tmp <- optim(log.K, ob.func, method="Nelder-Mead", control=list(maxit=10000))

    print(tmp)

    return(exp(tmp$par))

}

##' Function for doing the first fit for a viboud chowell model of the epidemic curves.
##' Parameters are considered to be drawn from a shared distribution.
##'
##' Fit is done via optim
##'
##' @param ecs the epidemic curves
##'
##' @return a vector of Ks
##'
epi.mdl.ViboudChowell.init <- function (ecs) {

    ##make some starting values for p and r with a touch of noise
    logistic.p.intercept <- 0
    logistic.p <- rnorm(length(ecs),0,1)

    log.r.intercept <- 0
    log.r <- rnorm(length(ecs),0,1)

    log.K <- log(2*sapply(ecs,sum))

    log.a.intercept <- 0
    log.a <- rnorm(length(ecs),0,1)

    ## Calculate the cumulative incidence curves
    cum.curve = lapply(ecs,cumsum)
    cum.curve <- lapply(cum.curve,function(x){x[-length(x)]}) ##drop the last cumsum observation as it does not contibute
    epi.curve <- lapply(ecs,function(x){x[-1]}) ##first observed epi curve also does not contribute

    lapply(epi.curve,function(x){if(length(x) == 0){stop("Do not use empty epi curves.")}})

    ## will fit by optim using poisson error function at each step with shared priors.
    ## param vector is structured as follows....first parameter is shared r
    ## parameters 2...(length(ec)+1) are individual rs
    ## parameters (length(ec)+2 is shard p
    ## parameters length(ec)+3...2*length(ec)+2 are inividual ps
    ## parameter 2*length(ec)+3...3*length(ec) are the Ks
    ob.func <- function(param) {
        rc <- 0
        for(i in 1:length(epi.curve)){
            loc.r <- exp(param[1+i])
            loc.p <- inv_logistic(param[length(ecs)+2+i]) #range 0 to 1
            loc.K <- exp(param[2*length(ecs)+2+i])
            loc.a <- exp(param[3*length(ecs)+3+i])

            ## preds <- loc.r*cum.curve^loc.p * (1 - cum.curve/K)

            preds <- loc.r*cum.curve[[i]]^loc.p * (1 - (cum.curve[[i]]/loc.K)^loc.a)

            preds[preds<.1] <- .1

            log.prob <- sum(dpois(epi.curve[[i]], preds, log=TRUE)) +
                dnorm(param[1+i],param[1], 3, log=T) + ##magic number of variance
                dnorm(param[length(ecs)+2+i], param[length(ecs)+2], 3, log=T) +
                dnorm(param[3*length(ecs)+3+i], param[3*length(ecs)+3], 3, log=T)# +
                ##dnorm(log10(loc.K),0,5, log=T)

            ## if(is.nan(log.prob)) {
            ##      print(cbind(preds,epi.curve[[i]], dpois(epi.curve[[i]],preds, log=T)))
            ##      cat("locp :", loc.p, "locr :", loc.r,"logprob:", log.prob,"\n")
            ## }

            rc <- rc - log.prob

        }
        #print(rc)

        return(rc)
    }

    tmp <- optim(c(log.r.intercept, log.r, logistic.p.intercept, logistic.p, log.K,
                   log.a.intercept, log.a), ob.func,
                  control=list(maxit=10000))
    print(tmp)
    return(list(r=exp(tmp$par[(1+(1:length(ecs)))]),
                p=inv_logistic(tmp$par[(2+length(ecs)+(1:length(ecs)))]),
                K=exp(tmp$par[2*length(ecs)+2+1:length(ecs)]),
                a=exp(tmp$par[3*length(ecs)+3+1:length(ecs)])))

}

##' Function for doing the first fit for a viboud chowell model of the epidemic curves.
##' Parameters are fit independently for each epidemic
##'
##' Fit is done via optim
##'
##' @param ecs the epidemic curves
##'
##' @return a vector of Ks
##'
epi.mdl.ViboudChowell.init2 <- function (ecs) {

    ##make some starting values for p and r with a touch of noise
    logistic.p <- rnorm(length(ecs),0,1)

    log.r <- rnorm(length(ecs),0,1)

    log.K <- log(2*sapply(ecs,sum))

    log.a <- rnorm(length(ecs),0,1)

    ## Calculate the cumulative incidence curves
    cum.curve = lapply(ecs,cumsum)
    cum.curve <- lapply(cum.curve,function(x){x[-length(x)]}) ##drop the last cumsum observation as it does not contibute
    epi.curve <- lapply(ecs,function(x){x[-1]}) ##first observed epi curve also does not contribute

    lapply(epi.curve,function(x){if(length(x) == 0){stop("Do not use empty epi curves.")}})

    ob.func <- function(param) {
        rc <- 0
        loc.r <- exp(param[1])
        loc.p <- inv_logistic(param[2]) #range 0 to 1
        loc.K <- exp(param[3])
        loc.a <- exp(param[4])

        preds <- loc.r*cum.curve[[i]]^loc.p * (1 - (cum.curve[[i]]/loc.K)^loc.a)

        preds[preds<.1] <- .1

        log.prob <- sum(dpois(epi.curve[[i]], preds, log=TRUE)) +
            dnorm(log10(loc.K),0,5, log=T)

        rc <- - log.prob

        return(rc)
    }

    rc <- list()

    for (i in 1:length(ecs)) {
        tmp <- optim(c(log.r[i], logistic.p[i],
                       log.K[i], log.a[i]), ob.func,
                     control=list(maxit=10000))
        rc$converged <- c(rc$converged,tmp$convergence)
        rc$r <- c(rc$r, exp(tmp$par[1]))
        rc$p <- c(rc$p, inv_logistic(tmp$par[2]))
        rc$K <- c(rc$K, exp(tmp$par[3]))
        rc$a <- c(rc$a, exp(tmp$par[4]))

        }

    return(rc)

}

##' Funciton for doing the "predict" step for the viboud cholel model
##' Essentially takes the p and r parameters and fits K given those parameters
##'
##' Has some weak schrinkage of K towards 0e
##'
##' @param pars the parameters from a model fit given K
##'
##' @return a vector of Ks
##'
epi.mdl.ViboudChowell.pred2 <- function(pars) {
    log.K <- log(pars$fit.Ks)
    ecs <- pars$ecs

    cum.curve = lapply(ecs,cumsum)
    cum.curve <- lapply(cum.curve,function(x){x[-length(x)]}) ##drop the last cumsum observation as it does not contibute
    epi.curve <- lapply(ecs,function(x){x[-1]}) ##first observed epi curve also does not contribute

    lapply(epi.curve,function(x){if(length(x) == 0){stop("Do not use empty epi curves.")}})

    ##Individual fitting of Ks
    ob.func <- function(param, loc.r, loc.p, loc.a, cum.curve, epi.curve) {
        K <- param
        preds <- loc.r*cum.curve^loc.p * (1 - (cum.curve/K)^loc.a)
        preds[preds<.1] <- .1

        log.prob <- sum(dpois(epi.curve, preds, log=TRUE)) +
             dnorm(log10(K),0,9, log=T)

        return(-log.prob)
    }

    rc <- rep(NA, length(log.K))

    for (i in 1:length(rc)) {
        tmp <- optimize(ob.func, c(sum(ecs[[i]]), 10^7),
                        loc.r=pars$r[i], loc.p=pars$p[i],
                        loc.a=pars$a[i],
                        cum.curve = cum.curve[[i]],
                        epi.curve=epi.curve[[i]])
        rc[i] <- tmp$minimum
    }

    return(rc)
}

##' Function for doing the fit for a viboud chowell model of the epidemic curves.
##' Parameters are considered to be independent for each epidem. Fit is done via optim
##'
##' @param ecs the epidemic curves
##' @param K the Ks
##' @param prev.mde an optional argument with the previous model
##'
##' @return a vector of parameters for the fit model
##'
epi.mdl.ViboudChowell.fit2 <- function (ecs, K, prev.mdl=NULL) {

    ##make some starting values for p and r with a touch of noise
    if (is.null(prev.mdl)) {
        logistic.p <- rnorm(length(ecs),0,1)
        log.r <- rnorm(length(ecs),0,1)
        log.a <- rnorm(length(ecs),0,1)
    } else {
        logistic.p <- prev.mdl$logistic.p
        log.r <- prev.mdl$log.r
        log.a <- prev.mdl$log.a
    }

    ## Calculate the cumulative incidence curves
    cum.curve = lapply(ecs,cumsum)
    cum.curve <- lapply(cum.curve,function(x){x[-length(x)]}) ##drop the last cumsum observation as it does not contibute
    epi.curve <- lapply(ecs,function(x){x[-1]}) ##first observed epi curve also does not contribute

    lapply(epi.curve,function(x){if(length(x) == 0){stop("Do not use empty epi curves.")}})

    ob.func <- function(param, loc.K) {
        rc <- 0
        loc.r <- exp(param[1])
        loc.p <- inv_logistic(param[2]) #range 0 to 1
        loc.a <- exp(param[3])

        preds <- loc.r*cum.curve[[i]]^loc.p * (1 - (cum.curve[[i]]/loc.K)^loc.a)

        preds[preds<.1] <- .1

        log.prob <- sum(dpois(epi.curve[[i]], preds, log=TRUE)) +
            dnorm(log10(loc.K),0,9, log=T)

        rc <- - log.prob

        return(rc)
    }

    rc <- list()

    for (i in 1:length(ecs)) {
        tmp <- optim(c(log.r[i], logistic.p[i],
                       log.a[i]), ob.func,
                     loc.K = K[i],
                     control=list(maxit=10000))
        rc$converged <- c(rc$converged,tmp$convergence)
        rc$log.r <- c(rc$log.r, tmp$par[1])
        rc$logistic.p <- c(rc$logistic.p, tmp$par[2])
        rc$log.a <- c(rc$log.a, tmp$par[3])

    }

    rc$r <- exp(rc$log.r)
    rc$p <- inv_logistic(rc$logistic.p)
    rc$a <- exp(rc$log.a)

    rc$fit.Ks <- K
    rc$ecs <- ecs

    return(rc)

}

##' Version of the epidemiologic model that fits a normal distribution to an epidemic curve.
##' INitialization fits all parameters, including final size, peak time (i.e., mean) and
##' spread (i.e., standard deviation)
##'
##' @param ecs the epidemic curves
##'
##' @return a list with final size, peak time and spread
##'
epi.mdl.normcurve.init <- function(ecs) {

    fs <- 2*sapply(ecs, sum) #start at twice the observed cases
    peak.time <- sapply(ecs, length) #the consistent choice for peak time is the length of the EC
    spread <- peak.time/3 #the consistent choice for peak time and size
    converged <- rep(0, length(ecs))

    ##objective function. POisson error on pedicted incdience.
    ob.func <- function(par, ec) {
        loc.fs <- exp(par[1])
        loc.sd <- exp(par[3])
        pred <- loc.fs * (pnorm(1:length(ec), par[2], loc.sd) -  pnorm((1:length(ec))-1, par[2], loc.sd))

        log.prob <- sum(dpois(ec, pred, log=TRUE))  +
            dnorm(log10(loc.fs), 0,1, log=TRUE)

        if(is.nan(log.prob)) {
            print(par)
            print(ec)
        }

        return(-log.prob)
    }

    for (i in 1:length(ecs)) {
        ec <- ecs[[i]]

        #print(c(fs[i], peak.time[i], spread[i]))
        tmp <- optim(c(log(fs[i]), peak.time[i], log(spread[i])), ob.func, ec=ecs[[i]])

        converged[i] <- tmp$convergence
        fs[i] <- exp(tmp$par[1])
        peak.time[i] <- tmp$par[2]
        spread[i] <- exp(tmp$par[3])
    }

    return(list(K=fs, peak.time = peak.time, spread=spread, converged=converged))

}

##' Version of the epidemiologic model that fits a normal distribution to an epidemic curve.
##' fit fits the
##'
##' @param ecs the epidemic curves
##' @param K the values of K
##' @param prev.mdl the previous model, can be null
##'
##' @return a list with final size, peak time and spread
##'
epi.mdl.normcurve.fit <- function(ecs, K, prev.mdl=NULL) {

    fs <- K #start at twice the observed cases
    peak.time <- sapply(ecs, length) #the consistent choice for peak time is the length of the EC

    if (is.null(prev.mdl)) {
        peak.time <- sapply(ecs, length) #the consistent choice for peak time is the length of the EC
        spread <- peak.time/3 #the consistent choice for peak time and size
    } else {
        peak.time <- prev.mdl$peak.time
        spread <- prev.mdl$spread
    }

    converged <- rep(0, length(ecs))

    ##objective function. POisson error on pedicted incdience.
    ob.func <- function(par, ec, fs) {
        loc.sd <- exp(par[2])
        pred <- fs * (pnorm(1:length(ec), par[1], loc.sd) -  pnorm((1:length(ec))-1, par[1], loc.sd))

        log.prob <- sum(dpois(ec, pred, log=TRUE))

        if (is.nan(log.prob)) {
            print(par)
            print(ec)
        }

        return(-log.prob)
    }

    for (i in 1:length(ecs)) {
        ec <- ecs[[i]]

        #print(c(fs[i], peak.time[i], spread[i]))
        tmp <- optim(c(peak.time[i], log(spread[i])), ob.func, ec=ecs[[i]], fs=fs[i])

        converged[i] <- tmp$convergence
        peak.time[i] <- tmp$par[1]
        spread[i] <- exp(tmp$par[2])
    }

    return(list(K=fs, peak.time = peak.time, spread=spread, converged=converged, ecs=ecs))

}

##' Version of the epidemiologic model that fits a normal distribution to an epidemic curve.
##' INitialization fits all parameters, including final size, peak time (i.e., mean) and
##' spread (i.e., standard deviation)
##'
##' @param ecs the parameters of the fit model
##'
##' @return a list with final size, peak time and spread
##'
epi.mdl.normcurve.pred <- function(pars) {

    #everything starts at the previous estimates for everything
    fs <- pars$K
    peak.time <- pars$peak.time
    spread <- pars$spread
    converged <- rep(0, length(pars$ecs))

    ##objective function. POisson error on pedicted incdience.
    ob.func <- function(par, ec, peak.time, spread) {

        pred <- par * (pnorm(1:length(ec), peak.time, spread) -  pnorm((1:length(ec))-1, peak.time, spread))

        log.prob <- sum(dpois(ec, pred, log=TRUE)) +
            dnorm(log10(par),0, 1, log=TRUE)

        if(is.nan(log.prob)) {
            print(par)
            print(peak.time)
            print(spread)
            print(ec)
        }

        return(-log.prob)
    }

    for (i in 1:length(ecs)) {
        ec <- pars$ecs[[i]]
        #print(ec)
                                        #print(c(fs[i], peak.time[i], spread[i]))

        tmp <- optimize(ob.func, interval=c(sum(ec),10^7),  ec=ec, peak.time=peak.time[i], spread=spread[i])

        fs[i] <- tmp$minimum
    }

    return(fs)

}

##' Function for doing random forrest fit of the K data appropriate for
##' passing in to epiInf.EM
##'
##' @param x the data frame to fit basedd on
##'
##' @return a fit random forrest model
##'
stat.mdl.linear.fit <- function(x) {
    require(rpart)

    f <- formula(paste0("K~",paste(names(subset(x,select=-K)),collapse="+")))
    rc <- lm(f, data=x)

    return(rc)
}

##'Function for doing the predict for duing the predict for the
##' results from a stat.mdl.rf.fit
##'
##' @param mdl the fit model
##'
##' @return a vector of predicted final sizes
##'
stat.mdl.linear.pred <- function(mdl) {
    rc <-predict(mdl)
    rc[rc<1] <- 1
    return(rc)
}

##' Function for doing superlearner fit of the K data appropriate for
##' passing in to iInf.EM
##'
##' @param x the data frame to fit basedd on
##'
##' @return a fit superlearner model
##'
stat.mdl.sl.fit <- function(x) {
  require(SuperLearner)
  require(gam)
  require(rpart)
  require(randomForest)
  y <- x$K
  x <- as.data.frame(subset(x, select=-K))
  rc <- SuperLearner(X = x, Y = y, newX = x, family = "gaussian", SL.library = c("SL.rpart", "SL.randomForest", "SL.glm", 'SL.gam')) #'SL.gam',
  ##rc <- SuperLearner(X = x, Y = y, newX = x, family = "gaussian", SL.library = c("SL.rpart", "SL.glm", 'SL.gam')) #'SL.gam',

  return(rc)
}
##'Function for doing the predict for duing the predict for the
##' results from a stat.mdl.sl.fit
##'
##' @param mdl the fit model
##'
##' @return a vector of predicted final sizes
##'
stat.mdl.sl.pred <- function(mdl) {
  return(pmax(1,predict(mdl, onlySL = T)$pred))
}


require(rms)

# Example of penalty from help page using lrm:

n <- 1000    # define sample size
set.seed(17) # so can reproduce the results
age            <- rnorm(n, 50, 10)
blood.pressure <- rnorm(n, 120, 15)
cholesterol    <- rnorm(n, 200, 25)
sex            <- factor(sample(c('female','male'), n,TRUE))
# Specify population model for log odds that Y=1
L <- .4*(sex=='male') + .045*(age-50) +
  (log(cholesterol - 10)-5.2)*(-2*(sex=='female') + 2*(sex=='male'))
# Simulate binary y to have Prob(y=1) = 1/[1+exp(-L)]
y <- ifelse(runif(n) < plogis(L), 1, 0)

f <- lrm(y ~ blood.pressure + sex * (age + rcs(cholesterol,4)),
         x=TRUE, y=TRUE)
p <- pentrace(f, seq(.2,1,by=.05))
plot(p)
p$diag      # may learn something about fractional effective d.f.
# for each original parameter
update(f,penalty=.02)

# Example modified for ols:

fols <- ols(blood.pressure ~sex * (age + rcs(cholesterol,4)), x=TRUE, y=TRUE)
pols <- pentrace(fols, seq(0,10,by=.5))
plot(pols)
pols$diag
update(fols,penalty=10)


#######################################
#
# Program to analyze distance between
# Reddit subreddits using the cooccurrence
# of commentors across subreddits.
# Also implements "subreddit algebra"
# by adding and subtracting subreddit
# vectors.
# By @martintrevor_ for FiveThirtyEight
#
#######################################

library(reshape2)
library(lsa)
library(ggtern)

##### Part 1: Load in the data

# This CSV file was created by running the SQL code in processData.sql in Google's BigQuery
rawsubredditvecs = read.table("all_starting_2015_01_overlaps_top2200_no200_10com_allrank_mod_122716.csv",header=TRUE,sep=",")

##### Part 2: Format and clean data for analysis

castsubredditvecs = dcast(rawsubredditvecs,t1_subreddit~t2_subreddit,FUN="identity",fill=0)
subredditvecst = as.matrix(castsubredditvecs[,-1])
rownames(subredditvecst) = castsubredditvecs[,1]
subredditvecs = t(subredditvecst)
subredditvecssums = apply(subredditvecs,1,sum)
subredditvecsnorm = sweep(subredditvecs,1,subredditvecssums,"/")
subredditvecssumscontext = apply(subredditvecs,2,sum)
contextprobs = subredditvecssumscontext/sum(subredditvecssumscontext)
subredditvecspmi = log(sweep(subredditvecsnorm,2,contextprobs,"/")) # PMI version
subredditvecsppmi = subredditvecspmi
subredditvecsppmi[subredditvecspmi<0] = 0 # PPMI version
scalar1 <- function(x) {x / sqrt(sum(x^2))} # Function to normalize vectors to unit length
subredditvecsppminorm = t(apply(subredditvecsppmi,1,scalar1))

##### Part 3: Analysis of subreddit similarities

## Looking at which subreddits are closest to each other (and combinations of subreddits)
cursubmat = subredditvecsppminorm
cursubmatt = t(cursubmat)
currownameslc = tolower(rownames(cursubmat))
# Function to calculate subreddit similarities and perform algebra
# Note that curops always has a leading "+"
findrelsubreddit <- function(cursubs,curops,numret=20) {
    cursubs = tolower(cursubs)
    curvec = 0
    for(i in 1:length(cursubs)) {
	    curvec = ifelse(curops[i]=="+",list(curvec + cursubmat[which(currownameslc==cursubs[i]),]),list(curvec - cursubmat[which(currownameslc==cursubs[i]),]))[[1]]
    }
    curclosesubs = cosine(x=curvec,y=cursubmatt)
    curclosesubso = order(curclosesubs,decreasing=TRUE)
    curclosesubsorder = curclosesubs[curclosesubso]
    curclosesubsorderc = curclosesubsorder[-which(tolower(names(curclosesubsorder))%in%cursubs)]
return(head(curclosesubsorderc,numret))
}

## Political examples

# /r/The_Donald
cursubs = c("the_donald")
curops = c("+")
findrelsubreddit(cursubs,curops,5)

# /r/The_Donald - /r/politics
cursubs = c("the_donald","politics")
curops = c("+","-")
findrelsubreddit(cursubs,curops,5)

# /r/hillaryclinton - /r/politics
cursubs = c("hillaryclinton","politics")
curops = c("+","-")
findrelsubreddit(cursubs,curops,5)

# /r/The_Donald - /r/SandersforPresident
cursubs = c("the_donald","sandersforpresident")
curops = c("+","-")
findrelsubreddit(cursubs,curops,5)

# /r/SandersforPresident - /r/The_Donald
cursubs = c("sandersforpresident","the_donald")
curops = c("+","-")
findrelsubreddit(cursubs,curops,5)

# /r/fatpeoplehate + /r/CoonTown + /r/politics
cursubs = c("fatpeoplehate","coontown","politics")
curops = c("+","+","+")
findrelsubreddit(cursubs,curops,5)

## Validation examples

# /r/nba + /r/minnesota
cursubs = c("nba","minnesota")
curops = c("+","+")
findrelsubreddit(cursubs,curops,5)

# /r/personalfinance - /r/Frugal
cursubs = c("personalfinance","frugal")
curops = c("+","-")
findrelsubreddit(cursubs,curops,5)

# /r/Fitness + /r/TwoXChromosomes
cursubs = c("fitness","twoxchromosomes")
curops = c("+","+")
findrelsubreddit(cursubs,curops,5)

## Creating the ternary plot

# Similatrity to /r/The_Donald
cursubs = c("the_donald")
curops = c("+")
Dsubsims = findrelsubreddit(cursubs,curops,nrow(cursubmat))
# Similarity to /r/SandersforPresident
cursubs = c("sandersforpresident")
curops = c("+")
Ssubsims = findrelsubreddit(cursubs,curops,nrow(cursubmat))
# Similarity to /r/hillaryclinton
cursubs = c("hillaryclinton")
curops = c("+")
Hsubsims = findrelsubreddit(cursubs,curops,nrow(cursubmat))
# List of subreddits we're interested in
ternarysubs = c("theredpill","coontown","fatpeoplehate","politics","worldnews","news","sjwhate","thebluepill","feminism","books","political_revolution","basicincome")
Dternarysubsims = Dsubsims[tolower(names(Dsubsims))%in%ternarysubs]
Sternarysubsims = Ssubsims[tolower(names(Ssubsims))%in%ternarysubs]
Hternarysubsims = Hsubsims[tolower(names(Hsubsims))%in%ternarysubs]
# Normalizing the matrix
allternarysubsims = transform(merge(transform(merge(Sternarysubsims,Dternarysubsims,by="row.names"),row.names=Row.names,Row.names=NULL),Hternarysubsims,by="row.names"),row.names=Row.names,Row.names=NULL)
colnames(allternarysubsims) = c("S","D","H")
allternarysubsimssums = apply(allternarysubsims,1,sum)
allternarysubsimsnorm = sweep(allternarysubsims,1,allternarysubsimssums,"/")
# Creating the plot
pdf("./ternaryplotanno.pdf",height=10,width=10)
ggtern(data=allternarysubsimsnorm,aes(S,D,H)) + geom_point() + geom_text(label=rownames(allternarysubsimsnorm),hjust=0,vjust=0)
dev.off()
pdf("./ternaryplot.pdf",height=10,width=10)
ggtern(data=allternarysubsimsnorm,aes(S,D,H)) + geom_point() + theme_classic()
dev.off()

# Find subreddits that are particularly biased towards any of the three main candidate subreddits
allsubsims = transform(merge(transform(merge(Ssubsims,Dsubsims,by="row.names"),row.names=Row.names,Row.names=NULL),Hsubsims,by="row.names"),row.names=Row.names,Row.names=NULL)
colnames(allsubsims) = c("S","D","H")
chooseunique = c("H") # Set candidate subreddit of interest
curunique = 1/(allsubsims[,(!(colnames(allsubsims)==chooseunique))]/allsubsims[,chooseunique]) # Calculate fold enrichment of target candidate subreddit over other candidate subreddits for all other subreddits
allsubsimsmin = apply(allsubsims,1,min)
curuniquemin = apply(curunique,1,min)
curuniqueminc = curuniquemin[-which(allsubsimsmin==0)]
curuniquemat = data.frame(enrich=curuniqueminc,allsubsims[match(names(curuniqueminc),rownames(allsubsims)),])
curuniquemato = curuniquemat[order(curuniquemat$enrich,decreasing=TRUE),]
curuniquematoc = curuniquemato[which(curuniquemato[,chooseunique]>=0.25),] # Threshold for high enrichment and high raw similarity
head(curuniquematoc,20)


# get_scale_breaks_untransformed.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

# Returns a vector of scale breaks well distributed as powers of 10, inside
# the given range limit.plot.untr and avoiding exponents smaller than mix.exp.

get.scale.breaks.untransformed <- function( limit.plot.untr, min.exp )
{
    if ( limit.plot.untr[ 1 ] > 10^min.exp )
        breaks.exp.min <- ceiling( log10( limit.plot.untr[ 1 ] ) )
    else if ( limit.plot.untr[ 1 ] > 0 )
        breaks.exp.min <- min.exp
    else if ( limit.plot.untr[ 1 ] > -10^min.exp )
        breaks.exp.min <- 0
    else
        breaks.exp.min <- - floor( log10( - limit.plot.untr[ 1 ] ) )

    if ( limit.plot.untr[ 2 ] < -10^min.exp )
        breaks.exp.max <- - ceiling( log10( - limit.plot.untr[ 2 ] ) )
    else if ( limit.plot.untr[ 2 ] < 0 )
        breaks.exp.max <- - min.exp
    else if ( limit.plot.untr[ 2 ] < 10^min.exp )
        breaks.exp.max <- 0
    else
        breaks.exp.max <- floor( log10( limit.plot.untr[ 2 ] ) )

    breaks.exp <- breaks.exp.min : breaks.exp.max

    breaks.exp <- breaks.exp[
        abs( breaks.exp ) == 0 | abs( breaks.exp ) >= min.exp ]

    sapply( breaks.exp, function ( be )
        if ( be > 0 )
            10^be
        else if ( be < 0 )
            -10^-be
        else
            be
    )
}


library(corrplot)

dn.fig = "figures/sig_ranked_correlation"
dir.create(dn.fig, showWarnings = F, recursive = T)

df.scores = fread("results/Score_table.txt")
names(df.scores) = sub("microarray", "PBMC", names(df.scores))

score.mat = df.scores %>%
  dplyr::select(-response) %>%
  tibble::column_to_rownames("subject") %>% data.matrix()

cc = cor(score.mat, method = "spearman", use = "pairwise.complete.obs")

cm.cor = pals::brewer.rdbu(10) %>% rev()

ccm = cor.mtest(score.mat, method = "spearman")
ccp = ccm$p
ord = c(13, 12, 1, 7, 14, 6, 4, 5, 2, 3, 9, 10, 8, 11)

fn.cor = glue::glue("{dn.fig}/Score_Spearman_corrplot_sig")
png(paste0(fn.cor, ".png"), w=500, h=600)
corrplot(cc[ord,ord], col=cm.cor,
         tl.col="black", cl.pos="b", order="original",
         p.mat=ccp[ord,ord], insig="label_sig", sig.level=c(0.001, 0.01, 0.05), pch.col="white", pch.cex = 1)
dev.off()
pdf(paste0(fn.cor, ".pdf"), w=5, h=6, useDingbats = F)
corrplot(cc[ord,ord], col=cm.cor,
         tl.col="black", cl.pos="b", order="original",
         p.mat=ccp[ord,ord], insig="label_sig", sig.level=c(0.001, 0.01, 0.05), pch.col="white", pch.cex = 1)
dev.off()


library(quantmod)

stock <- na.omit(get(getSymbols('GOOG')))

x = Cl( stock )
y = SMA( Cl(stock), 5 )
row <- x > y
#View( cbind(x, y, row) )
pl <- setNames( rep( 0, length(x) ), time(stock) ) # [p]rofit and [l]ose vector
head(pl)

m <- 6
while ( m < nrow(stock) ) {
    if (row[m-1] == 0 && row[m] == 1) {
        long <- as.numeric( Op(stock)[m+1] )
        while ( row[m] == 1 && m < nrow(stock) ) {
            m = m + 1
        }
        pl[m] <- as.numeric( Op(stock)[m+1] ) - long # short - long == sell - buy
    }
    m = m+1
}

plot( cumsum(pl), type='l', col='red', lwd=2 )


# Model comparison
require(caret)
fit1 = train(pred ~ .,
 data = dat,
 method = "svmRadial",
 preProc = c("center", "scale"),
 tuneLength = 10,
 trControl = trainControl(method = "repeatedcv",
 repeats = 5))

fit2 = train(pred ~ .,
 data = dat,
 method = "glm",
 preProc = c("center", "scale"),
 tuneLength = 10,
 trControl = trainControl(method = "repeatedcv",
 repeats = 5))

# Difference between model fits
diff(resamples(list(SVM=fit1, Logistic=fit2)))

# Regression performance
R2(predicted, observed)
RMSE(predicted, observed)
cor(predicted, observed)
cor(predicted, observed, method = "spearman")

# Plot predictions and residuals
df = data.frame(Training=dat, Predicted=predict(trained))
ggplot(data=df, aes(Training ~ Predicted)) + geom_point()
df1 = data.frame(Training=resid(model), Predicted=predict(trained))
ggplot(data=df1, aes(Residual, Predicted)) + geom_point()

# Labelled resudials
plot(model, which=1)

# Scale-location plot
plot(model, which=3)

# Cooks distance
plot(model, which=5)

# Confidence intervals
confint(model)

# Influence and outlier detection
influence(model)

# Covariances of residuals
covariances = sapply(c("pred1", "pred2"), function(o) { return(cov(model$residuals, dat[o])) })

# RMSE of residuals
sqrt(sum(model$residuals^2)/(nrow(dat)-num_predictors)) == model$sigma == sqrt(deviance(model)/(nrow(dat)-num_predictors))

# R squared - variation explained by model
summary(model)$r.squared

roc_curve <- function(pr.m)
{
  pr <- prediction(pr.m, actual)
  pe <- performance(pr, "tpr", "fpr")
  au <- performance(pr, "auc")@y.values[[1]]
  pd <- data.frame(fpr=unlist(pe@x.values), tpr=unlist(pe@y.values))

  p <- ggplot(pd, aes(x=fpr, y=tpr))
  p <- p + geom_line(colour="red")
  p <- p + xlab("False Positive Rate") + ylab("True Positive Rate")
  p <- p + ggtitle(deparse(substitute(pr.m)))
  p <- p + annotate("text", x=0.50, y=0.00, hjust=0, vjust=0, size=5,
  label=paste("Area under curve =", round(au, 2)))

  return(p)
}

# Dicky-Fuller test on stationarity
require(tseries)
adf.test(dat, alternative="stationary", k=0)
adf.test(dat, alternative="explosive", k=0)

# GLS
require(nlme)
plot(ACF(model, form=~var), alpha=0.05)
model1 = update(model, correlation=corAR1())
require(MuMIn)
AICc(model, model1)


set.seed(101)
pred <- runif(1000)
act <- round(pred)
pred[sample(1000, 500)] <- runif(500)   # noise

## Test AUROC ------------------------------------------------------------------

## Metrics::auc(act, pred)
## 0.7568871
## ROCR::performance(ROCR::prediction(pred, act), "auc")
## 0.7568871
expect_equal(
    mtr_auc_roc(act, pred),
    target = 0.7568871,
    tol = 1e-7
)

## Test AUPRC ------------------------------------------------------------------

## PRROC::pr.curve(pred[act == 1], pred[act == 0], curve = FALSE)
## Area under curve (Integral): 0.7149685
## Area under curve (Davis & Goadrich): 0.7149619

## expect_equal(
##     mtr_auc_prc(act, pred),
##     target = 0.7149619,
##     tol = 1e-2
## )

## Test AUC on large dataset ---------------------------------------------------

## preds <- c(rbeta(1e6, 25, 30), rbeta(1e6, 30, 25))
## target <- rep(c(0, 1), each = 1e6)
## mtr_auc_roc(target, preds)
## ModelMetrics::auc(target, preds)

## microbenchmark::microbenchmark(                            ##
##                     mtr = mtr_auc_roc(target, preds),      ##
##                     mm = ModelMetrics::auc(target, preds), ##
##                     times = 5                              ##
##                 )                                          ##


library(deldir)

cdat = data.frame(x=td$xCoord,y=td$yCoord)
meanrad = mean(sqrt(td$Area/(2*pi)))

del = deldir(cdat)

del$delsgs$dist =  sqrt((del$delsgs$x2-del$delsgs$x1)^2+(del$delsgs$y2-del$delsgs$y1)^2)

adj = matrix(0.0,nrow=nrow(cdat),ncol=nrow(cdat))
for(i in 1:length(del$delsgs$dist)){
  distance = del$delsgs$dist[i]
  if(distance>6*meanrad) distance = 0.0
  adj[del$delsgs$ind1[i],del$delsgs$ind2[i]] = distance
  adj[del$delsgs$ind2[i],del$delsgs$ind1[i]] = distance
}

adj = round(adj)

colnames(adj) = td$cell_id
rownames(adj) = td$cell_id

candidates = sample(td$cell_id)
unavailable = c()
sampled = c()

pdf("Samples.pdf",width=16,height=8)
while(length(candidates)>0){
 cellid = candidates[1]
 neighb_1 = td$cell_id[adj[,cellid]>0.0]
 neighb_2 = c()
 for(n in neighb_1){
   neighb_2 = unique(c(neighb_2,td$cell_id[adj[,n]>0.0]))
 }
 neighb_2 = neighb_2[neighb_2!=cellid]
 sampled = c(sampled, cellid)
 unavailable = unique(c(unavailable,neighb_1))
 #unavailable = unique(c(unavailable,neighb_1,neighb_2))
 candidates = candidates[!((candidates%in%unavailable)|(candidates%in%sampled))]
}

sdat=cdat[td$cell_id%in%sampled,]
udat=cdat[td$cell_id%in%unavailable,]
op = par(mfrow=c(1,2))
 prop = length(sampled)/length(cdat$x)
 mlab = paste("Proportion sampled:",formatC(100*prop,3),"(%)")
 rang = range(c(cdat$x,cdat$y),xlim=rang,ylim=rang)
 plot(del)
 points(sdat$x,sdat$y,pch=16,col="red",cex=0.5)
 points(udat$x,udat$y,pch=16,col="blue",cex=0.5)
 plot(cdat$x,cdat$y,pch=16,col="grey",xlab="x (px)",ylab="y (px)",cex.axis=1.45,cex.lab=1.45,xlim=rang,ylim=rang,main=mlab)
 points(sdat$x,sdat$y,pch=16,col="red",cex=0.5)
 points(udat$x,udat$y,pch=16,col="blue",cex=0.5)
par(op)

dev.off()


mammals <- read.csv('../data/MammalData.csv', stringsAsFactors = T)

#get logs of continuous variables
mammals$logLS <- log(mammals$LitterSize)
mammals$logCvalue <- log(mammals$meanCvalue)
mammals$logBM <- log(mammals$AdultBodyMass_g)

# reduce dataset to five key variables
mammals <- subset(mammals, select = c(logCvalue, logLS, logBM,
TrophicLevel, GroundDwelling))

# remove the row with missing data
mammals <- na.omit(mammals)

str(mammals)

model <- lm(formula = logCvalue ~ logLS * logBM * TrophicLevel * GroundDwelling, data = mammals)

model <- lm(logCvalue ~ (logLS + logBM + TrophicLevel + GroundDwelling)^2, data = mammals)

anova(model)

drop.scope(model)

drop.scope(y ~ a + b + c + a:b)

drop.scope(y ~ a + b + c + a:b + b:c + a:b:c)

# a simple model
f <- y ~ a + b + c + b:c

# remove b:c from the current model
update(f, . ~ . - b:c)

# model g as a response using the same explanatory variables.
update(f, g ~ .)

model2 <- update(model, . ~ . - TrophicLevel:GroundDwelling)

anova(model, model2)

anova(model2)

drop.scope(model2)


pcor_test <- function(x, y, z, use = "mat", method = "p", na.rm = TRUE) {
  # The partial correlation coefficient between x and y given z
  #
  # pcor.test is free and comes with ABSOLUTELY NO WARRANTY.
  #
  # x and y should be vectors
  #
  # z can be either a vector or a matrix
  #
  # use: There are two methods to calculate the partial correlation coefficient.
  # 	 One is by using variance-covariance matrix ("mat") and the other is by using recursive formula ("rec").
  # 	 Default is "mat".
  #
  # method: There are three ways to calculate the correlation coefficient,
  # 	    which are Pearson's ("p"), Spearman's ("s"), and Kendall's ("k") methods.
  # 	    The last two methods which are Spearman's and Kendall's coefficient are based on the non-parametric analysis.
  # 	    Default is "p".
  #
  # na.rm: If na.rm is T, then all the missing samples are deleted from the whole dataset, which is (x,y,z).
  #        If not, the missing samples will be removed just when the correlation coefficient is calculated.
  # 	   However, the number of samples for the p-value is the number of samples after removing
  # 	   all the missing samples from the whole dataset.
  # 	   Default is "T".

  x <- c(x)
  y <- c(y)
  z <- as.data.frame(z)

  if (use == "mat") {
    p.use <- "Var-Cov matrix"
    pcor <- pcor.mat(x, y, z, method = method, na.rm = na.rm)
  } else if (use == "rec") {
    p.use <- "Recursive formula"
    pcor <- pcor.rec(x, y, z, method = method, na.rm = na.rm)
  } else {
    stop("\'use\' should be either \"rec\" or \"mat\"!\n")
  }

  # print the method
  if (gregexpr("p", method)[[1]][1] == 1) {
    p.method <- "Pearson"
  } else if (gregexpr("s", method)[[1]][1] == 1) {
    p.method <- "Spearman"
  } else if (gregexpr("k", method)[[1]][1] == 1) {
    p.method <- "Kendall"
  } else {
    stop("\'method\' should be \"pearson\" or \"spearman\" or \"kendall\"!\n")
  }

  # sample number
  n <- dim(na.omit(data.frame(x, y, z)))[1]

  # given variables' number
  gn <- dim(z)[2]

  # p-value
  if (p.method == "Kendall") {
    statistic <- pcor / sqrt(2 * (2 * (n - gn) + 5) / (9 * (n - gn) * (n - 1 - gn)))
    p.value <- 2 * pnorm(-abs(statistic))
  } else {
    statistic <- pcor * sqrt((n - 2 - gn) / (1 - pcor^2))
    p.value <- 2 * pnorm(-abs(statistic))
  }

  data.frame(estimate = pcor, p.value = p.value, statistic = statistic, n = n, gn = gn, Method = p.method, Use = p.use)
}

# By using var-cov matrix
pcor.mat <- function(x, y, z, method = "p", na.rm = T) {
  x <- c(x)
  y <- c(y)
  z <- as.data.frame(z)

  if (dim(z)[2] == 0) {
    stop("There should be given data\n")
  }

  data <- data.frame(x, y, z)

  if (na.rm == T) {
    data <- na.omit(data)
  }

  xdata <- na.omit(data.frame(data[, c(1, 2)]))
  Sxx <- cov(xdata, xdata, m = method)

  xzdata <- na.omit(data)
  xdata <- data.frame(xzdata[, c(1, 2)])
  zdata <- data.frame(xzdata[, -c(1, 2)])
  Sxz <- cov(xdata, zdata, m = method)

  zdata <- na.omit(data.frame(data[, -c(1, 2)]))
  Szz <- cov(zdata, zdata, m = method)

  # is Szz positive definite?
  zz.ev <- eigen(Szz)$values
  if (min(zz.ev)[1] < 0) {
    stop("\'Szz\' is not positive definite!\n")
  }

  # partial correlation
  Sxx.z <- Sxx - Sxz %*% solve(Szz) %*% t(Sxz)

  rxx.z <- cov2cor(Sxx.z)[1, 2]

  rxx.z
}

# By using recursive formula
pcor.rec <- function(x, y, z, method = "p", na.rm = T) {
  #

  x <- c(x)
  y <- c(y)
  z <- as.data.frame(z)

  if (dim(z)[2] == 0) {
    stop("There should be given data\n")
  }

  data <- data.frame(x, y, z)

  if (na.rm == T) {
    data <- na.omit(data)
  }

  # recursive formula
  if (dim(z)[2] == 1) {
    tdata <- na.omit(data.frame(data[, 1], data[, 2]))
    rxy <- cor(tdata[, 1], tdata[, 2], m = method)

    tdata <- na.omit(data.frame(data[, 1], data[, -c(1, 2)]))
    rxz <- cor(tdata[, 1], tdata[, 2], m = method)

    tdata <- na.omit(data.frame(data[, 2], data[, -c(1, 2)]))
    ryz <- cor(tdata[, 1], tdata[, 2], m = method)

    rxy.z <- (rxy - rxz * ryz) / (sqrt(1 - rxz^2) * sqrt(1 - ryz^2))

    return(rxy.z)
  } else {
    x <- c(data[, 1])
    y <- c(data[, 2])
    z0 <- c(data[, 3])
    zc <- as.data.frame(data[, -c(1, 2, 3)])

    rxy.zc <- pcor.rec(x, y, zc, method = method, na.rm = na.rm)
    rxz0.zc <- pcor.rec(x, z0, zc, method = method, na.rm = na.rm)
    ryz0.zc <- pcor.rec(y, z0, zc, method = method, na.rm = na.rm)

    rxy.z <- (rxy.zc - rxz0.zc * ryz0.zc) / (sqrt(1 - rxz0.zc^2) * sqrt(1 - ryz0.zc^2))
    return(rxy.z)
  }
}


#' Auto-correlation function (ACF)
#'
#' @description Computes data of ACF ou CCF
#'
#' @param x
#' @param y
#'
#' @return tibble
#' @export
#'
#' @examples
#'
#'
#' x <- rnorm(100)
#'
#' y <- rexp(100)
#'
#' acf_data(x,y)
#'

acf_data <- function(x,y = NULL,...){

  if(is.null(y)){

    aux <- acf(x,plot = FALSE,...)

    out <- tibble::tibble(
      acf = unlist(aux[[1]][,1,1]),
      lag = unlist(aux[[4]][,1,1])
    )
  }else{

    aux <- ccf(x,y,plot = FALSE,...)

    out <- tibble::tibble(
      acf = unlist(aux[[1]][,1,1]),
      lag = unlist(aux[[4]][,1,1])
    )
  }

  return(out)
}


library(caTools)                                                                # Contains several basic utility functions including: moving (rolling, running) window statistic functions,
library(tidyquant)                                                              # Loads tidyquant, tidyverse, lubridate, quantmod, TTR, and xts
library(TTR)                                                                    # Technical Trading Rules package
# Date Processing --------------------------------------------------------------
#end <- ymd("2017-10-30")
end <-  today()
from <- today() - years(10)
start <- end - weeks(52)
# SPL Processing ---------------------------------------------------------------
SPL <- tq_get("SPL.AX")                                                         # Get SPL Stock Prices
SPL<-SPL[complete.cases(SPL),]                                                  # Delete NA
date <- SPL$date                                                                # Create date variable
# Example 1: Annual Returns ----------------------------------------------------
tblRetAnnual <- SPL %>%
  tq_transmute(select     = close,
               mutate_fun = periodReturn,
               period     = "yearly",
               type       = "arithmetic")
# Example 2: Use tq_mutate_xy to use functions with two columns required--------
# SPL %>%
#  tq_mutate_xy(x = close, y = volume, mutate_fun = EVWMA,
#               col_rename = "EVWMA")

# Example 2B: Getting Daily Log Returns-----------------------------------------
tblRetDailyLog <- SPL %>%
  tq_transmute(select     = adjusted,
               mutate_fun = periodReturn,
               period     = "daily",
               type       = "log",
               col_rename = "daily.returns")
# Example 3: MACD to Visualize Moving Average Convergence Divergence------------
tblMACD <- SPL %>%
  tq_mutate(select     = close,
            mutate_fun = MACD,
            nFast      = 12,
            nSlow      = 26,
            nSig       = 9,
            maType     = SMA) %>%
  mutate(diff = macd - signal) %>%
  select(-(open:volume))
# Example 4: Max and Min Price for Each Quarter---------------------------------
tblRetMaxByQtr <- SPL %>%
  tq_transmute(select     = adjusted,
               mutate_fun = apply.quarterly,
               FUN        = max,
               col_rename = "max.close") %>%
  mutate(year.qtr = paste0(year(date), "-Q", quarter(date))) %>%
  select(-date)

tblRetMinByQtr <- SPL %>%
  tq_transmute(select     = adjusted,
               mutate_fun = apply.quarterly,
               FUN        = min,
               col_rename = "min.close") %>%
  mutate(year.qtr = paste0(year(date), "-Q", quarter(date))) %>%
  select(-date)

tblRetByQtr <- left_join(tblRetMaxByQtr, tblRetMinByQtr,
                         by = c("year.qtr" = "year.qtr"))
# Example 5: Chaikan AD --------------------------------------------------------
# tblchaikanAD <- SPL %>%
#   tq_transmute(
#                mutate_fun = chaikinAD,
#                HLC = high:low:close,
#                volume = volume
#                )
# Delete Table NA --------------------------------------------------------------
tblMACD <-tblMACD[complete.cases(tblMACD),]                                      # Delete MACD NA
# Reformat Table ---------------------------------------------------------------
# tblchaikanAD
tblMACD <- data.frame("spl",tblMACD)                                            # Create MACD Table
tblRetAnnual <- data.frame("spl",tblRetAnnual)                                  # Create Annual Returns Table
tblRetDailyLog <- data.frame("spl",tblRetDailyLog)                              # Create Daily Log Returns Table
tblRetMaxByQtr <- data.frame("spl",tblRetMaxByQtr)                              # Create Max Returns by Quarter Table
tblRetMinByQtr <- data.frame("spl",tblRetMinByQtr)                              # Create Min Returns by Quarter Table
tblRetByQtr <- data.frame("spl",tblRetByQtr)                                    # Create Min Returns by Quarter Table
# Rename columns ---------------------------------------------------------------
colnames(tblMACD) <- c( "symbol", "date", "adjusted", "macd", "signal","diff")  # Rename tblMACD Table Columns
colnames(tblRetAnnual) <- c( "symbol", "date", "retAnnual")                     # Rename tblRetAnnual Table Columns
colnames(tblRetDailyLog) <- c( "symbol", "date", "retDaily")                    # Rename tblDailyLogReturns Table Columns
colnames(tblRetMaxByQtr) <- c( "symbol", "close", "dateYrQtr")                  # Rename tblRetMaxByQtr Table Columns
colnames(tblRetMinByQtr) <- c( "symbol", "close", "dateYrQtr")                  # Rename tblRetMinByQtr Table Columns
colnames(tblRetByQtr) <- c( "symbol", "closeMax", "dateYrQtr", "closeMin")      # Rename tblRetByQtr Table Columns
# Reorder  columns -------------------------------------------------------------
tblMACD <- tblMACD[, c(2, 1, 3, 4, 5, 6)]                                       # Reorder tblMACD columns
tblRetAnnual <- tblRetAnnual[, c(2, 1, 3)]                                      # Reorder tblRetAnnual columns
tblRetDailyLog <- tblRetDailyLog[, c(2, 1, 3)]                                  # Reorder tblDailyLogReturns columns
tblRetMaxByQtr <- tblRetMaxByQtr[, c(3, 1, 2)]                                  # Reorder tblRetMaxByQtr columns
tblRetMinByQtr <- tblRetMinByQtr[, c(3, 1, 2)]                                  # Reorder tblRetMinByQtr columns
tblRetByQtr <- tblRetByQtr[, c(3, 1, 2, 4)]                                     # Reorder tblRetByQtr columns


suppressPackageStartupMessages(library(float))
set.seed(1234)

tol = 1e-6
m = 10
n = 3

x = matrix(stats::rnorm(m*n), m, n)
s = fl(x)

type = "O"
test = dbl(norm(s, type))
truth = norm(x, type)
stopifnot(all.equal(test, truth, tol=tol))

type = "I"
test = dbl(norm(s, type))
truth = norm(x, type)
stopifnot(all.equal(test, truth, tol=tol))

type = "F"
test = dbl(norm(s, type))
truth = norm(x, type)
stopifnot(all.equal(test, truth, tol=tol))

type = "M"
test = dbl(norm(s, type))
truth = norm(x, type)
stopifnot(all.equal(test, truth, tol=tol))

type = "2"
test = dbl(norm(s, type))
truth = norm(x, type)
stopifnot(all.equal(test, truth, tol=tol))


library(Cairo)

params = read.table('data/cycleParams.csv',sep=',',header=T)
data   = read.table('data/log2DNA.csv',sep=',',header=T)

attach(params)

CairoSVG('cycleFit.svg',width=6,height=3)

par(mfrow=c(1,2))

s2p   = 1/sqrt(2*pi)
minFreq = .01

xlims = c(12.8,15)
ylims = c(0,2.5)

x=data$x
y=data$y

# SHOW EACH PIECE
plot( x, y, type='l',xlim=xlims, ylim=ylims,lwd=3,
      xlab='log2(DNA)',ylab='nuclei', col='gray')

G1.y = weight.1*s2p*(1/sd.1)*exp(-(x-mean.1)^2/(2*sd.1^2))
lines( x[G1.y>minFreq], G1.y[G1.y>minFreq], col='red',lty=3,lwd=2)

G2.y = weight.2*s2p*(1/sd.2)*exp(-(x-mean.2)^2/(2*sd.1^2))
lines( x[G2.y>minFreq], G2.y[G2.y>minFreq], col='dodgerblue',lty=3,lwd=2)

S.y  = (x>mean.1 & x<(mean.2))*v
lines( x[S.y>minFreq], S.y[S.y>minFreq], col='black',lty=3,lwd=2)

abline( v=mean.1, col='red' )
abline( v=mean.2, col='dodgerblue')

# COMBINED
plot( x, y, type='l', xlim=xlims, ylim=ylims,lwd=3,
      xlab='log2(DNA)',ylab='nuclei', col='gray')
all.y = G1.y + G2.y + S.y
lines( x[all.y>minFreq],all.y[all.y>minFreq], col='darkred',lty=3,lwd=2)

dev.off()


 E04NQJ Example Program Results

 QP problem contains   7 variables and   8 linear constraints

 Final objective value =  -1.848E+06
 Optimal X =      0.00    349.40    648.85    172.85    407.52    271.36    150.02


# Reading in Data
ds = read.csv('Social_Network_Ads.csv')
ds = ds[, 3:5]

# Scaling and splitting
library(caTools)

split = sample.split(ds$Purchased, SplitRatio = 0.75)
train = subset(ds, split == TRUE)
test = subset(ds, split == FALSE)

# Regressor
library(rpart)
clf = rpart(formula = Purchased ~.,
            data = train)

prob_pred = predict(clf, newdata = test[-3])
y_pred = ifelse(prob_pred > 0.5, 1, 0)

# Confusion matrix
cm = table(test[, 3], y_pred)

plot(clf, margin = 0.05, main='Decision Tree')
text(clf, cex = 0.5)

# Plot
library('ElemStatLearn')
set = train
X1 = seq(min(set[, 1]) - 1, max(set[, 1]) + 1, by = 0.01)
X2 = seq(min(set[, 2]) - 1, max(set[, 2]) + 1, by = 0.01)
grid_set = expand.grid(X1, X2)
colnames(grid_set) = c('Age', 'EstimatedSalary')
prob_set = predict(clf, newdata = grid_set)
y_grid = ifelse(prob_set > 0.5, 1, 0)

plot(set[, -3],
     main = 'Title',
     xlab = 'Age', ylab = 'Estimated Salary',
     xlim = range(X1), ylim = range(X2))
contour(X1, X2, matrix(as.numeric(y_grid), length(X1), length(X2)), add = TRUE)
points(grid_set, pch = '.', col = ifelse(y_grid == 1, 'springgreen3', 'tomato'))
points(set, pch = 21, bg = ifelse(set[, 3] == 1, 'green4', 'red3'))


construct_kernel <- function(data_in,data_out,sequence,gamma = 0.00000002) {
      K = matrix(0,nrow(data_in),length(sequence))
  for (i in 1:nrow(data_in)) {
          for (j in 1:length(sequence)) {
                    K[i,j] <- exp(-1*gamma*sum((data_in[i,] - data_out[sequence[j],])**2,na.rm = T))
      }
    }
    return(K)
}

project_points <- function(data_in,data_out,vectors) {
      sequence = 1:nrow(data_out)
  K <- construct_kernel(data_in,data_out,sequence)
    return (t(K) %*% vectors)
}

kernel_transform <- function(data) {
      sequence = 1:nrow(data)
  print("Constructing Kernel")
    K <- construct_kernel(data,data,sequence)
    I <- matrix(1,nrow(data),nrow(data))/nrow(data)
      K_centered <- K - I%*%K - K%*%I + I%*%K%*%I
      eig <- eigen(K_centered)
        vectors <- as.matrix(eig$vectors[,1:10])/ sqrt(eig$values[1:10])
        # final_data <- t(t(vectors) %*% t(X))
        # return(final_data)
        return(vectors)
}

data <- as.matrix(read.csv("Datasets/movement_libras_1.data",header = FALSE, sep = ",",fill = FALSE))
vect <- kernel_transform(data)
a <- project_points(data,data,vect)

kmL <- kmeans(a,centers=3,nstart=5)


ac_powerflow = function(
     file_name,
     v_fr = 1.0, v_to = 1.0,
     vd_ub = 0.2, vd_lb = -0.2,
     ad_ub = pi/6, ad_lb = -pi/6,
     y_m = 1.0, y_a = -1.45,
     t_m = 1.0, t_a = 0.0
     ) {

     g =  y_m*cos(y_a)
     b = y_m*sin(y_a)

     steps = 100

     v_to_delta_lb = vd_lb + v_fr - v_to
     v_to_delta_ub = vd_ub + v_fr - v_to

     v_to_delta = seq(v_to_delta_lb, v_to_delta_ub, (v_to_delta_ub-v_to_delta_lb)/(steps-1))
     vd_vals = (rep(v_to, steps) + v_to_delta) - rep(v_fr, steps)
     ad_vals = seq(ad_lb, ad_ub, (ad_ub-ad_lb)/(steps-1))

     stopifnot(vd_lb <= min(vd_vals)+0.000001)
     stopifnot(vd_ub >= max(vd_vals)-0.000001)

     pv = matrix(nrow = steps, ncol = steps)
     qv = matrix(nrow = steps, ncol = steps)

     for (i in 1:steps) {
          v1 = v_fr;
          v2 = v_to + v_to_delta[i];
          for (j in 1:steps) {
               ad = ad_vals[j];
               pv[i,j] =  g*v1^2/t_m^2 - g*v1/t_m*v2*cos(ad - t_a) - b*v1/t_m*v2*sin(ad - t_a)
               qv[i,j] = -b*v1^2/t_m^2 + b*v1/t_m*v2*cos(ad - t_a) - g*v1/t_m*v2*sin(ad - t_a)
          }
     }

     ps = 14
     pdf(file_name, pointsize=ps, width=14, height=7, bg="white")

     par(mfrow=c(1,2), oma=c(0,0,2.5,0))

     contour(
          x = vd_vals,
          y = ad_vals,
          pv,
          #color = terrain.colors,
          #levels = colorsteps,
          nlevels = 8,
          labcex=1.0,
          plot.title = title(main = "Active Power (p)",
          xlab = "Voltage Difference", ylab = "Angle Difference (rad)")
     )

     contour(
          x = vd_vals,
          y = ad_vals,
          qv,
          #color = terrain.colors,
          #levels = colorsteps,
          nlevels = 8,
          labcex=1.0,
          plot.title = title(main = "Reactive Power (q)",
          xlab = "Voltage Difference", ylab = "Angle Difference (rad)")
     )

     title("AC Power Flow Fields (from side, p.u.)", outer=TRUE)
     mtext(
          sprintf("v1 = %.3f, g = %.3f, b = %.3f, tr = %.3f, as = %.3f", v_fr, g, b, t_m, t_a),
          line=-1, outer=TRUE)

     dev.off()
}

ac_powerloss = function(
     file_name,
     v_fr = 1.0, v_to = 1.0,
     vd_ub = 0.2, vd_lb = -0.2,
     ad_ub = pi/6, ad_lb = -pi/6,
     y_m = 1.0, y_a = -1.45,
     t_m = 1.0, t_a = 0.0
     ) {

     g =  y_m*cos(y_a)
     b = y_m*sin(y_a)

     steps = 100

     v_to_delta_lb = vd_lb + v_fr - v_to
     v_to_delta_ub = vd_ub + v_fr - v_to

     v_to_delta = seq(v_to_delta_lb, v_to_delta_ub, (v_to_delta_ub-v_to_delta_lb)/(steps-1))
     vd_vals = (rep(v_to, steps) + v_to_delta) - rep(v_fr, steps)
     ad_vals = seq(ad_lb, ad_ub, (ad_ub-ad_lb)/(steps-1))

     stopifnot(vd_lb <= min(vd_vals)+0.000001)
     stopifnot(vd_ub >= max(vd_vals)-0.000001)

     pv_fr = matrix(nrow = steps, ncol = steps)
     qv_fr = matrix(nrow = steps, ncol = steps)

     pv_to = matrix(nrow = steps, ncol = steps)
     qv_to = matrix(nrow = steps, ncol = steps)

     for (i in 1:steps) {
          v1 = v_fr;
          v2 = v_to + v_to_delta[i];
          for (j in 1:steps) {
               ad = ad_vals[j];
               pv_fr[i,j] =  g*v1^2/t_m^2 - g*v1/t_m*v2*cos(ad - t_a) - b*v1/t_m*v2*sin(ad - t_a)
               qv_fr[i,j] = -b*v1^2/t_m^2 + b*v1/t_m*v2*cos(ad - t_a) - g*v1/t_m*v2*sin(ad - t_a)

               pv_to[i,j] =  g*v2^2 - g*v1/t_m*v2*cos(ad + t_a) - b*v1/t_m*v2*sin(ad + t_a)
               qv_to[i,j] = -b*v2^2 + b*v1/t_m*v2*cos(ad + t_a) - g*v1/t_m*v2*sin(ad + t_a)
          }
     }

     ps = 14
     pdf(file_name, pointsize=ps, width=14, height=7, bg="white")

     par(mfrow=c(1,2), oma=c(0,0,2.5,0))

     contour(
          x = vd_vals,
          y = ad_vals,
          pv_fr + pv_to,
          #color = terrain.colors,
          #levels = colorsteps,
          nlevels = 8,
          labcex=1.0,
          plot.title = title(main = "Active Power (p)",
          xlab = "Voltage Difference", ylab = "Angle Difference (rad)")
     )

     contour(
          x = vd_vals,
          y = ad_vals,
          qv_fr + qv_to,
          #color = terrain.colors,
          #levels = colorsteps,
          nlevels = 8,
          labcex=1.0,
          plot.title = title(main = "Reactive Power (q)",
          xlab = "Voltage Difference", ylab = "Angle Difference (rad)")
     )

     title("AC Power Loss Fields (p.u.)", outer=TRUE)
     mtext(
          sprintf("v1 = %.3f, g = %.3f, b = %.3f, tr = %.3f, as = %.3f", v_fr, g, b, t_m, t_a),
          line=-1, outer=TRUE)

     dev.off()
}

ac_dc_comparison = function(
     file_name,
     v_fr = 1.0, v_to = 1.0,
     ad_ub = 1.5*pi/2, ad_lb = -1.5*pi/2,
     y_m = 1.0, y_a = -1.45,
     t_m = 1.0, t_a = 0.0
     ) {

     g =  y_m*cos(y_a)
     b = y_m*sin(y_a)

     steps = 100

     ad_vals = seq(ad_lb, ad_ub, (ad_ub-ad_lb)/(steps-1))

     ac_p = rep(0.0, steps)
     dc_p = rep(0.0, steps)

      v1 = v_fr
      v2 = v_to
      for (i in 1:steps) {
           ad = ad_vals[i];
           ac_p[i] = g*v1^2/t_m^2 - g*v1/t_m*v2*cos(ad - t_a) - b*v1/t_m*v2*sin(ad - t_a)
           dc_p[i] = -b*v1/t_m*v2*(ad - t_a)
      }

     ps = 16
     pdf(file_name, pointsize=ps, width=7, height=7, bg="white")
         x_range = c(min(ad_vals), max(ad_vals))
         y_range = c(min(ac_p, dc_p), max(ac_p, dc_p))
         plot(x_range, y_range, type="n", xlab = "Voltage Angle Difference (rad)", ylab = "Active Power (p.u.)", main="AC vs DC Active Power Comparison")
         abline(h=0.0, col=rgb(0,0,0,0.5))
         abline(v=0.0, col=rgb(0,0,0,0.5))
         points(ad_vals, dc_p, type="l", lw=3, col="dodgerblue")
         points(ad_vals, ac_p, type="l", lw=3, col="darkorange")
         legend("topleft", legend=c("AC Power Flow", "DC Power Flow"), lty=1, lw=3, col=c("darkorange", "dodgerblue"), bg="white")
     dev.off()
}


data("warpbreaks")

library("rjags")

set.seed(83)

mod3_string = " model {
    for( i in 1:length(y)) {
        y[i] ~ dnorm(mu[woolGrp[i], tensGrp[i]], prec[woolGrp[i], tensGrp[i]])
    }

    for (j in 1:max(woolGrp)) {
        for (k in 1:max(tensGrp)) {
            mu[j,k] ~ dnorm(0.0, 1.0/1.0e6)
            prec[j,k] ~ dgamma(1.0/2.0, 1.0/2.0)
            sig[j,k]  = sqrt(1.0 / prec[j,k] )

        }
    }

} "

str(warpbreaks)

data3_jags = list(y=log(warpbreaks$breaks), woolGrp=as.numeric(warpbreaks$wool), tensGrp=as.numeric(warpbreaks$tension))

params3 = c("mu", "sig")

mod3 = jags.model(textConnection(mod3_string), data=data3_jags, n.chains=3)
update(mod3, 1e3)

mod3_sim = coda.samples(model=mod3,
                        variable.names=params3,
                        n.iter=5e3)
mod3_csim = as.mcmc(do.call(rbind, mod3_sim))

plot(mod3_sim, ask=TRUE)

## convergence diagnostics
gelman.diag(mod3_sim)
autocorr.diag(mod3_sim)
effectiveSize(mod3_sim)
raftery.diag(mod3_sim)

(dic3 = dic.samples(mod3, n.iter=1e3))


# Single Gerstner wave for plotting purposes only.
gerstner_wave <- function(p, t, d, A, Q, w, phi) {
    H <- A*sin((p%*%d)*w + t*phi)
    Gx <- d[1]*Q*A*cos((p%*%d)*w + t*phi)
    Gz <- d[2]*Q*A*cos((p%*%d)*w + t*phi)
    return(c(p[1] + Gx, H, p[2] + Gz))
}


## LOOP WHILE:

# Habiendo visto en la lección anterior el uso y ejemplos del loop for, haremos
# lo propio con el loop 'while', que requiere del cumplimiento de una o más
# condiciones para su ejecución.
# Como su nombre lo indica, 'while' (mientras) es un loop que se ejecutará
# solamente mientras la o las condiciones especificadas se cumplan, interrum-
# piéndose inmediatamente cuando dejen de hacerlo.
# Para ver la ayuda de R al respecto se pueden usar los comandos:
?Control
?"while"

## SINTÁXIS
# "while" es usado cuando el número de iteraciones deseado no es sabido de
# antemano por el programador, si no que depende de una condición que va a
# ir cambiando a medida que dichas iteraciones sean ejecutadas. Aquí veremos
# algunos ejemplos sencillos, sin ver necesariamente el caso más general.

# Usualmente un loop while se ve como esto (no ejecutar)
while (<condición>) {
  # Aquí
  # instrucciones
}

# Normalmente la condición (la expresión que está entre paréntesis)
# involucra a algún objeto que es sujeto a cambios en las instrucciones. Veamos
# un ejemplo sencillo:
x <- 1
while (x < 10) {
  print(x)
  x <- x + 2
}

# Podemos ver que aquí la expresión involucra a x ("x < 10") y que x es
# modificado en las instrucciones, sumando un +2 en cada iteración. Conviene
# observar también que aquí en la Preparación se definió x y que esto es
# fundamental, ya que si no es imposible evaluar la expresión entre paréntesis.
# Otra observación interesante es que en la consola se imprimieron todos los
# valores menos el último (11), ¿puede deducir por qué ocurre esto?

# Es importante entonces destacar que la expresión de la condición del loop
# debe involucrar a una variable que cambie con las iteraciones, y dicha
# variable debe eventualmente cambiar la condición a FALSE, porque de otra
# forma es posible generar un loop while que corra indefinidamente. Los
# siguientes son dos ejemplos (¡no ejecutar!):
# Ej. 1: x no cambia dentro de las instrucciones:
x <- 1
y <- 1
while (x < 10) {
  print(y)
  y <- y + 2
}
# Ej. 2: x cambia pero la condición nunca es FALSE:
x <- 1
while (x > 0) {
  print(x)
  x <- x + 2
}

# Veremos ahora un ejemplo más elaborado: la caminata del borracho.

# La caminata aleatoria o del borracho es un ejemplo típico en cursos de física
# o de matemática. Sirve para representar procesos aleatorios tales como la
# deriva génica o el movimiento browniano. En su versión más sencilla, la
# caminata ocurre sobre una recta (i.e.: tiene sólo 1 dimensión). El hombre
# alcoholizado se encuentra en una posición inicial (0 para nosotros) y se va
# a mover de forma aleatoria hacia izquierda o derecha en cada turno. Además la
# longitud de cada paso es también aleatoria. Entonces para determinar tanto
# dirección como longitud podemos tomar valores de una distribución normal o
# gaussiana centrada en cero. La función rnorm nos sirve para este propósito,
# por ejemplo:
rnorm(100)
# ... los valores pueden ser negativos o positivos y su valor absoluto tiene un
# desvío estándar de 1. Cada paso del borracho será un número obtenido con esta
# función.

# Pero la caminata sería infinita a menos que se imponga un límite arbitrario.
# En nuestra simulación determinaremos que el borracho dejará de caminar una
# vez que se haya movido una distancia mayor a 10 para cualquiera de las dos
# direcciones.

# Vamos a tener un valor llamado pos que será la posición instantánea del
# borracho, y un vector x en el cual vamos a almacenar toda la secuencia de
# posiciones en un vector llamado x. Sabemos que pos es 0 inicialmente, así
# que podemos empezar nuestro código con:
pos <- 0

# Para definir x tenemos que saber cuántos elementos debe tener ... ¡pero en
# verdad no lo sabemos! La caminata es aleatoria, por lo que es imposible saber
# exactamente cuándo se detendrá. Hay varias formas de solucionar el problema,
# pero la más sencilla (aunque ineficiente) es:
x <- 0 # ó
x <- pos

# Entonces sólo nos queda hacer el loop:
while (abs(pos) <= 10) {
  pos <- pos + rnorm(1)
  x <- c(x, pos)
}

# Veamos los distintos pasos ...

# 1. La condición:
# Como los límites de la caminata son 10 y -10, nos interesa evaluar si el
# valor absoluto de pos es el que está por debajo de la distancia elegida (abs
# es la función valor absoluto, por supuesto).
# 2. El paso del borracho:
# pos <- pos + rnorm(1), modifica la posición en base a la anterior. Nótese
# que pos se sobreescribe en este comando.
# 3. Almacenamiento de la nueva posición dentro de x:
# x <- c(x, pos), aquí estamos "agrandando x", de a un valor cada turno. Sin
# embargo en verdad estamos cambiando x por un x nuevo, pero eso es un detalle
# sin importancia.

# Podemos visualizar la caminata con el siguiente comando:
plot(x, xlab = "Nro. de iteración", ylab = "Posición del borracho",
     type = "o", pch = 20)

# Veamos varios ejemplos ...

# ========= caminata.R: inicio ========
# Preparación:
pos <- 0
x <- pos
# Loop:
while (abs(pos) <= 10) {
  pos <- pos + rnorm(1)
  x <- c(x, pos)
}
plot(x, xlab = "Nro. de iteración",
     ylab = "Posición del borracho",
     type = "o", pch = 20)
# ========= caminata.R: fin ===========

# Si guardamos estos comandos en un script llamado "caminata.R", podemos hacer
# varios intentos y ver como varían las caminatas, tanto en recorrido como en
# duración:

x11() # En una ventana nueva: conviene maximizarla
op <- par(mfcol = c(3, 2), oma = c(0, 0, 3, 0))
for (i in 1:6)
  source("caminata.R", encoding = "UTF-8") # Sólo funciona si
mtext("Seis ejemplos en uno", outer = TRUE, cex = 2)
par(op)

# Nota: el código que usamos aquí para la caminata no es la opción más
# eficiente. Al final de esta lección se muestran otras opciones más adecuadas
# para modelar este sistema.

## RESUMEN
# - La diferencia fundamental entre while y for es que en el primero no es
# necesario definir de antemano el número de iteracciones, dependiendo de una
# condición (una operación lógica) para ejecutar los comandos internos del
# loop (hasta que de FALSE).
# - Al igual que con for, es muy importante la preparación.
# - También es *fundamental* tener cuidado de no crear un loop infinito, usando
#   una condición coerente con las variables que están en juego.

## Caminata del borracho: opciones más eficientes (de menos a más)

# 1. Definir x de antemano:
pos <- 0
x <- numeric(1e4)
i <- 1
while (abs(pos) <= 10) {
  pos <- pos + rnorm(1)
  x[i] <- pos
  i <- i + 1
}
x <- x[1:(i - 1)]
# Debido a que el estar cambiando de tamaño del x es un proceso muy ineficiente
# del punto de vista computacional, es mejor crear un x al que le sobren
# elementos (aquí se estima que diez mil es más que suficiente) para luego
# eliminar las posiciones que sobren. Nótese que esto requiere definir la
# variable i en la preparación, la cual debe ser actualizada en cada turno.

# 2. Definir los valores aleatorios de antemano:
pos <- 0
x <- numeric(1e4)
r <- rnorm(1e4)
i <- 1
while (abs(pos) <= 10) {
  pos <- pos + r[i]
  x[i] <- pos
  i <- i + 1
}
x <- x[1:(i - 1)]
# La creación de números aleatorios es un proceso que puede ser lento si se
# hace de a uno por iteración. Es mejor siempre crear los valores aleatorios
# (el vector r) en la preparación. De esta forma alcanza con sumar el iésimo
# valor a pos en cada turno.
# Nuevamente, esta estrategia requiere que se hagan una cantidad sobrada de
# números aleatorios antes de empezar el loop.

# 3. Eliminar el loop
r <- rnorm(1e4)
x <- cumsum(r)
a <- which(abs(x) > 10)
x <- x[1:a[1]]
# Aquí recurrimos a la función cumsum, que sirve para vectorizar el cálculo
# (cumsum hace la suma acumulativa de r: x[1] == r[1], x[2] == r[1] + r[2],
# ... , x[n] == sum(r[1:n]). Luego con which identificamos todas las posiciones
# de x en las que el borracho se pasó de los límites y luego recortamos x,
# seleccionando la secuencia desde el x[1] hasta el primer x quese va de los
# límites.


require(forecast)

# Load data
weight_file <- "~/gdrive/sync-documents/data/weight.csv"
weightdf <- read.csv(weight_file)
names(weightdf) <- c('time', 'weight')
weightdf <- weightdf[, c('time', 'weight')]
weightdf$time <- as.Date(weightdf$time, format="%b %d, %Y %I:%M:%S %p")
# Remove an outlier (I measured that day with backpack and clothes on)
weightdf <- weightdf[-which(weightdf$time == "2020-01-30" & weightdf$weight == 153.0),]
# Aggregate with min measurements (assumed to be without any additional factors like food affecting measurement)
weightdf <- aggregate(list(weight = weightdf$weight), by=list(time = weightdf$time), FUN=min)

# Fit a line and plot data
ggplot(weightdf, aes(x=time, y=weight)) + geom_point() + geom_smooth(method="lm")
fit <-lm(weight ~ time, data=weightdf)
# Notice that there is significant autocorrelation for lags up to 10
# Breusch-Godfrey test shows p-value of < 2.2e-16 (very significant)
# There is additional patterns to mine from data
checkresiduals(fit)
# Residuals shows clear pattern
cbind(Fitted = fitted(fit),
      Residuals=residuals(fit)) %>%
  as.data.frame() %>%
  ggplot(aes(x=Fitted, y=Residuals)) + geom_point()

# Convert to timeseries
full_dates <- seq(min(weightdf$time), max(weightdf$time), by=1)
full_dates <- data.frame(time=full_dates)
weight_mins <- aggregate(weightdf, by=list("time"), FUN=min)
weightdf <-merge(full_dates, weightdf, by="time", all.x = TRUE)
weightts <- ts(weightdf$weight, start=min(weightdf$time), end=max(weightdf$time))
# Interp where I have data
weightts2 = c(na.interp(weightts[1:235]), weightts[236:288], na.interp(weightts[289:366]))


library(DirichletReg)

x<-c(0.1,1,2,3,4,5,10)
x<-x/sum(x)

n<-10
pSum<-17
alfa<-x*pSum
xx<-rdirichlet(n,alfa)

round(x,3)
round(xx,3)
apply(xx,1,sum)

ddirichlet(xx, x*pSum, log = T, sum.up = FALSE)
ddirichlet(xx, x*pSum, log = T, sum.up = T)

one<-xx[1,]
sum(one)

logSumP<-lgamma(sum(alfa))
loggamma<-sum(lgamma(one))
pPowStom<-sum((alfa-1)*log(one))

logLike<-logSumP-loggamma+pPowStom

logLike

-logLike