 # for clinic 1
r1=c(50,50)
c1=c(55,45)

# for clinic 2
r2=c(50,50)
c2=c(55,45)

# for clinic 3
r3=c(50,50)
c3=c(74,26)
nh=100
# The numerator of the CMH statistic
N=((40-((r1[1]*c1[1])/nh))+(35-((r2[1]*c2[1])/nh))+(43-((r3[1]*c3[1])/nh)))^2
print(N)

D=((r1[1]*r1[2]*c1[1]*c1[2])/(nh^2*(nh-1)))+((r2[1]*r2[2]*c2[1]*c2[2])/(nh^2*(nh-1)))+((r3[1]*r3[2]*c3[1]*c3[2])/(nh^2*(nh-1)))
print(D)

X2=N/D
print(X2)
# For df = 1, this result is significant at the p < .001 level. the drug-treated groups have consistently higher improvement rates than the placebo groups.


# https://github.com/ericgoolsby/Rphylopars/wiki

library(Rphylopars)
library(phytools) # for simulating pure-birth phylogenies
set.seed(21) # Set the seed for reproducible results
trait_cov <- matrix(c(4,2,2.2,2,3,1.5,2.2,1.5,2.5),nrow = 3,ncol = 3)
trait_cov # Phylogenetic trait covariance
tree <- pbtree(n = 20)
sim_data <- simtraits(v = trait_cov,tree = tree,nmissing = 10)

p_BM <- phylopars(trait_data = sim_data$trait_data,tree = sim_data$tree)

sim_data$trait_data[,2:4]

p_BM$anc_recon[1:20,] # Data with imputed species means
p_BM$anc_var[1:20,] # Variances for each estimate
p_BM$anc_recon[1:20,] - sqrt(p_BM$anc_var[1:20,])*1.96 # Lower 95% CI
p_BM$anc_recon[1:20,] + sqrt(p_BM$anc_var[1:20,])*1.96 # Upper 95% CI

plot.phylo(reorder(tree,"postorder"))
nodelabels()

p_BM$anc_recon[21:39,] # Reconstructed ancestral states for each trait
p_BM$anc_var[21:39,] # Variances for each estimate
p_BM$anc_recon[21:39,] - sqrt(p_BM$anc_var[21:39,])*1.96 # Lower 95% CI
p_BM$anc_recon[21:39,] + sqrt(p_BM$anc_var[21:39,])*1.96 # Upper 95% CI

p_lambda <- phylopars(trait_data = sim_data$trait_data,
                      tree = sim_data$tree,model = "lambda")
p_lambda # Estimated trait covariance and Pagel's lambda

p_star <- phylopars(trait_data = sim_data$trait_data,tree = sim_data$tree,model = "star")
p_star # Estimated trait covariance, fixed Pagel's lambda = 0

chi_square <- as.double(2*(logLik(p_lambda) - # 2*(logLik_alt - logLik_null)
                             logLik(p_star)))
degrees_freedom <- p_lambda$npars - p_star$npars # df = difference in # model parameters
pchisq(q = chi_square,df = degrees_freedom,lower.tail = FALSE) # p-value

p_OU <- phylopars(trait_data = sim_data$trait_data,tree = sim_data$tree,model = "OU")
p_OU # Estimated trait covariance, OU alpha, and stationary covariance

p_EB <- phylopars(trait_data = sim_data$trait_data,tree = sim_data$tree,model = "EB")
p_EB # Estimated trait covariance and EB rate parameter

AIC(p_BM)
AIC(p_OU)
AIC(p_EB)

BIC(p_BM)
BIC(p_OU)
BIC(p_EB)


##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))
}


# 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
    )
}


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)
  }
}


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()
}


# 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.


\name{generate_ER}
\alias{generate_ER}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Simulating networks from the Erdos-Renyi model}
\description{
  This function generates networks from the \enc{Erdős–Rényi}{Erdos-Renyi} model. In this model, the preferential attachment function is a constant function, i.e. \eqn{A_k = 1}, and node fitnesses are all equal to \eqn{1}. It is a wrapper of the more powerful function \code{\link{generate_net}}.
}
\usage{
  generate_ER(N              = 1000,
              num_seed       = 2   ,
              multiple_node  = 1   ,
              m              = 1)
}

%- maybe also 'usage' for other objects documented here.
\arguments{
\item{N}{
 Integer. Total number of nodes in the network (including the nodes in the seed graph). Default value is \code{1000}.
 }
\item{num_seed}{
 Integer. The number of nodes of the seed graph (the initial state of the network). The seed graph is a cycle. Default value is \code{2}.
}
\item{multiple_node}{
  Positive integer. The number of new nodes at each time-step. Default value is \code{1}.
}
\item{m}{
 Positive integer. The number of edges of each new node. Default value is \code{1}.
}
}

\value{
  The output is a \code{PAFit_net} object, which is a List contains the following four fields:
    \item{graph}{a three-column matrix, where each row contains information of one edge, in the form of \code{(from_id, to_id, time_stamp)}. \code{from_id} is the id of the source, \code{to_id} is the id of the destination.}
    \item{type}{a string indicates whether the network is \code{"directed"} or \code{"undirected"}.}
    \item{PA}{a numeric vector contains the true PA function.}
    \item{fitness}{fitness values of nodes in the network. The fitnesses are all equal to \eqn{1}.}
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\references{
  1. \enc{Erdös}{Erdos} P. & \enc{Rényi}{Renyi} A.. On random graphs. Publicationes Mathematicae Debrecen. 1959;6:290–297 (\url{http://snap.stanford.edu/class/cs224w-readings/erdos59random.pdf}).
}
\seealso{
For subsequent estimation procedures, see \code{\link{get_statistics}}.

For other functions to generate networks, see \code{\link{generate_net}}, \code{\link{generate_BA}}, \code{\link{generate_BB}} and \code{\link{generate_fit_only}}. }

\examples{
  library("PAFit")
  # generate a network from the ER model with N = 1000 nodes
  net <- generate_ER(N = 1000)
  str(net)
  plot(net)
}

% Add one or more standard keywords, see file 'KEYWORDS' in the
% R documentation directory.
\concept{ER model}


lm_curve = function(lr,Ms,p,ly,prod,rmin){
  r = 1/lr*(Ms/p - ly*prod)
  r[r < rmin] = rmin
  return(r)
}

RMPlot <- function(input,output,values){
    masse = seq(0,input$Mmax,length.out = 100)
    prod = seq(0,input$ymax,length.out = 100)
    to_plot = data.frame(money = masse, revenu = prod)
    fig = plot_ly(to_plot, x = ~money)

    fig = fig %>% add_segments(x = input$Ms, y = 0, xend = input$Ms, yend = 15, type = "scatter", mode = "lines", name = "$$M = M^s$$", color = I("blue"),
                                 hovertemplate = paste("Ms=%{x:.0f}","<extra></extra>"))
    fig = fig %>% add_trace(y = lm_curve(input$lr, masse,values$p,input$ly,values$eq$y, input$rmin), type = "scatter", mode = "lines", name = "$$M^d$$", color = I("red"),
                              hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
    fig = fig %>% add_segments(x = 0, y = values$eq$r, xend = input$Mmax, yend = values$eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                 hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

    if(values$shock & !is.na(input$new_value_LM)){
      if(input$shocked_var_LM == "Ms"){
        fig = fig %>% add_segments(x = values$shocked_params_LM["Ms"], y = 0, xend = values$shocked_params_LM["Ms"], yend = 15, type = "scatter", mode = "lines", name = "$$M = M^s$$", color = "rgb(0,20,200)",
                                     hovertemplate = paste("Ms=%{x:.0f}","<extra></extra>"))
        fig = fig %>% add_segments(x = 0, y = values$new_eq$r, xend = input$Mmax, yend = values$new_eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                     hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
      } else if(input$shocked_var_LM != "Ms"){
        fig = fig %>% add_trace(y = lm_curve(values$shocked_params_LM["lr"],masse,values$shocked_params_LM["p"]/100,values$shocked_params_LM["ly"],values$shocked_params_LM["ystar"],input$rmin), type = "scatter", mode = "lines", name = "$$M^d$$", color = "rgb(0,200,20)",
                                  hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
        fig = fig %>% add_segments(x = 0, y = values$new_eq$r, xend = input$Mmax, yend = values$new_eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                     hovertemplate = paste("Ms=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
      }
      new_eq = list(
        x = unname(values$shocked_params_LM["Ms"]),
        y = values$new_eq$r,
        text = paste0("r*=",round(values$new_eq$r,1))
      )
      fig = fig %>% layout(annotations = new_eq)
    } else{
      eq = list(
        x = input$Ms,
        y = values$eq$r,
        text = paste0("r*=",round(values$eq$r,1))
      )
      fig = fig %>% layout(annotations = eq)
    }

    f <- list(
      family = "Courier New, monospace",
      size = 18,
      color = "#7f7f7f"
    )
    money <- list(
      title = "Masse monétaire réelle, M/p",
      titlefont = f
    )
    interest <- list(
      title = "Taux d'intérêt, r",
      titlefont = f
    )
    fig = fig %>% layout(xaxis = money, yaxis = interest)
}

LMPlot <- function(input,output,values){
  masse = seq(0,input$Mmax,length.out = 100)
  prod = seq(0,input$ymax,length.out = 100)
  to_plot = data.frame(money = masse, revenu = prod)

  fig = plot_ly(to_plot, x = ~revenu)
  fig = fig %>% add_trace(y = lm_curve(input$lr, input$Ms, values$p, input$ly, prod, input$rmin), type = "scatter", mode = "lines", name = "$$LM_1$$", color = I("red"),
                            hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
  fig = fig %>% add_segments(0,values$eq$r,values$eq$y,values$eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$y,0,values$eq$y,values$eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                               hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))

  if(values$shock & !is.na(input$new_value_LM)){
    if(input$shocked_var_LM != "ystar"){
      fig = fig %>% add_trace(y = lm_curve(values$shocked_params_LM["lr"],values$shocked_params_LM["Ms"],values$shocked_params_LM["p"],values$shocked_params_LM["ly"],prod,input$rmin), type = "scatter", mode = "lines", name = "$$LM_2$$", color = "rgb(0,200,20)",
                                hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
    }
    fig = fig %>% add_segments(0,values$new_eq$r,values$shocked_params_LM["ystar"],values$new_eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                 hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
    fig = fig %>% add_segments(values$shocked_params_LM["ystar"],0,values$shocked_params_LM["ystar"],values$new_eq$r, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                                 hovertemplate = paste("y=%{x:.0f}","
r=%{y:.2f}","<extra></extra>"))
    lm_eq = list(
      x = unname(values$shocked_params_LM["ystar"]),
      y = values$new_eq$r,
      text = paste0("r*=",round(values$new_eq$r,1))
    )
    fig = fig %>% layout(annotations = lm_eq)
  } else{
    is_eq = list(
      x = values$eq$y,
      y = values$eq$r,
      text = paste0("r*=",round(values$eq$r,1))
    )
    fig = fig %>% layout(annotations = is_eq)
  }

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  revenu <- list(
    title = "Revenu, y",
    titlefont = f
  )
  interest <- list(
    title = "Taux d'intérêt, r",
    titlefont = f
  )
  fig = fig %>% layout(xaxis = revenu, yaxis = interest)
}


#' Title Partial Least Square Regression
#'
#' @param x matrix
#' @param y vector
#'
#' @return just loadings
#' @import stats
#' @export
#'

PLSR1 <- function(x,y){
  # 用5折交叉验证的方法确定偏最小二乘回归主成分的个数
  # 然后用全体x、y求解对应的w*
  # PLSR1
  x <- scale(x)
  y <- scale(y)
  pis <- round(length(y)/5)
  a <- vector(length = 6)
  a[1] <- 1
  for (i in 1:5){
    a[i+1] <- i*pis
  }
  a[6] <- length(y)
  k <- length(x[1,])
  rmse <- vector(length = k)
  rmse[is.na(rmse)] <- 0
  for (i in 1:5){
    xx <- x[-c((a[i]):(a[i+1]-1)),]
    xtest <- x[c((a[i]):(a[i+1]-1)),]
    yy <- y[-c((a[i]):(a[i+1]-1))]
    ytest <- y[c((a[i]):(a[i+1]-1))]
    ypre <- vector(length = length(ytest))
    ypre[is.na(ypre)] <- 0
    w <- matrix(nrow = k,ncol = k)
    r <- vector(length = k)
    p <- matrix(nrow = k,ncol = k)
    for (j in 1:k){
      xp <- xx
      yp <- yy
      mat <- t(xp)%*%yp%*%t(yp)%*%xp
      en <- eigen(mat)
      w[,j] <- as.numeric(en$vec[,1])
      t <- xp%*%w[,j]
      p[,j] <- (t(xp)%*%t)/sum(t^2)
      r[j] <- t(yp)%*%t/sum(t^2)
      xx <- xp-t%*%t(p[,j])
      yy <- yp-t*(r[j])
    }
    for (e in 1:k){
      if (e==1){
        y_hat <- xtest%*%(w[,c(1:1)]*r[1])
        rmse[e] <- rmse[e] + mean(abs((ytest-y_hat)/ytest))
      }
      if (e>1){
        y_hat <- xtest%*%(w[,c(1:e)]%*%(r[c(1:e)]))
        rmse[e] <- rmse[e] + mean(abs((ytest-y_hat)/ytest))
      }
    }
  }
  rmse <- rmse/5
  or <- which.min(rmse)
  ww <- matrix(nrow = k,ncol = or)
  pp <- matrix(nrow = k,ncol = or)
  rr <- vector(length = or)
  for (d in 1:or){
    mat <- t(x)%*%y%*%t(y)%*%x
    en <- eigen(mat)
    ww[,d] <- as.numeric(en$vec[,1])
    t <- x%*%ww[,d]
    pp[,d] <- (t(x)%*%t)/sum(t^2)
    rr[d] <- t(y)%*%t/sum(t^2)
    x <- x-t%*%t(pp[,d])
    y <- y-t*(rr[d])
  }
  loadings <- ww%*%solve(t(pp)%*%ww)
  return(list(rmse,loadings))
}


# Function to detect uncertainty in local peaks in a GAM and return the number and location of them after sampling from parameter uncertainty
# Arguments:
#	mod: the GAM model (produced by mgcv)
#	newdat: a data.frame of the new data on which to predict
#	xvar: the name of the variable over which peaks should be detected
#	xtol: the sliding window within which peaks are detected. Only one peak found per window. Width measured in # data points.
#	findmaxima: TRUE if goal is to find peaks. FALSE if goal is to find valleys.
# Returns a data.frame with

findPeaksGAM_CI <- function(mod, newdat, n, xvar, xtol, findmaxima=TRUE){
	library(mgcv)
	Xp <- predict(mod,newdat,type="lpmatrix") # prediction decomposed into the linear predictors
	br <- rmvn(n,coef(mod),mod$Vp) ## n replicate parameter vectors sampled with uncertainty
	res <- matrix(NA, ncol=n, nrow=nrow(newdat)) # to hold the predictions
	for(i in 1:n) res[,i] <- Xp %*% br[i,] ## replicate predictions

#	ord <- order(newdat[[xvar]]) # find order by xvar
#	yord <- newdat[[xvar]][ord] # order explanatory variable (xvar)
#	resord <- res[ord,] # order rows or res by xvar
	peaks <- data.frame(npeaks=rep(NA, n), peaklocs=I(vector('list', n)), y=I(vector('list', n))) # hold the number and location of peaks
	for(i in 1:n){
		temp <- find_peaks(res[,i], m=xtol, findmaxima)
		peaks$npeaks[i] <- length(temp)
		peaks$peaklocs[[i]] <- newdat[[xvar]][temp]
		peaks$y[[i]] <- res[,i]
	}
	return(peaks)
}

# Same function, but from the mean prediction (no uncertainty)
findPeaksGAM <- function(mod, newdat, xvar, xtol, findmaxima=TRUE){
	library(mgcv)
	res <- predict(mod,newdat) # prediction

	peaks <- data.frame(npeaks=rep(NA, 1), peaklocs=I(vector('list', 1)), y=I(vector('list', 1))) # hold the number and location of peaks
	temp <- find_peaks(res, m=xtol, findmaxima)
	peaks$npeaks <- length(temp)
	peaks$peaklocs[[1]] <- newdat[[xvar]][temp]
	peaks$y[[1]] <- res

	return(peaks)
}

## produce multivariate normal random deviates needed by findPeaksGAM
rmvn <- function(n,mu,sig) {
	L <- mroot(sig)
	m <- ncol(L)
	t(mu + L%*%matrix(rnorm(m*n),m,n))
}

# find peaks in a vector
# from https://stats.stackexchange.com/questions/22974/how-to-find-local-peaks-valleys-in-a-series-of-data
find_peaks <- function (x, m = 3, findmaxima=TRUE){
	shape <- diff(sign(diff(x, na.pad = FALSE)))
	if(findmaxima){
		pks <- sapply(which(shape < 0), FUN = function(i){
			z <- i - m + 1
			z <- ifelse(z > 0, z, 1)
			w <- i + m + 1
			w <- ifelse(w < length(x), w, length(x))
			if(all(x[c(z : i, (i + 2) : w)] <= x[i + 1])) return(i + 1) else return(numeric(0))
		})
	}
	if(!findmaxima){
		pks <- sapply(which(shape > 0), FUN = function(i){
			z <- i - m + 1
			z <- ifelse(z > 0, z, 1)
			w <- i + m + 1
			w <- ifelse(w < length(x), w, length(x))
			if(all(x[c(z : i, (i + 2) : w)] >= x[i + 1])) return(i + 1) else return(numeric(0))
		})
	}
	pks <- unlist(pks)
	return(pks)
}

# Example using findPeaksGAM
#library(mgcv)
#n <- 200
#sig <- 2
#dat <- gamSim(1,n=n,scale=sig) # an example dataset
#mod<-gam(y~s(x0)+s(I(x1^2))+s(x2)+offset(x3),data=dat) # fit a gam
#newdat <- data.frame(x0=(0:60)/60,x1=(0:60)/60,x2=(0:60)/60,x3=(0:60)/60) # new data for projection
#
#peaks <- findPeaksGAM(mod, newdat, 500, 'x0', 5)
#
#hist(peaks$npeaks) # almost all find 2 peaks
#
#
#plot(newdat$x0, predict(mod, newdat), type='l', ylim=range(res)) # plot the basic prediction
#for(i in 1:nrow(peaks)) lines(newdat$x0, peaks$y[[i]], col=rgb(0,0,0,0.05), lty=1) # plot the uncertainty
#
#
#plot(newdat$x0, predict(mod, newdat), type='l', ylim=range(res)) # plot the basic prediction
#inds <- which(peaks$npeaks == 1)
#for(i in 1:length(inds)) lines(newdat$x0, peaks$y[[inds[i]]], col=rgb(1,0,0,0.5), lty=1) # plot the lines with 1 peak
#inds <- which(peaks$npeaks == 3)
#for(i in 1:length(inds)) lines(newdat$x0, peaks$y[[inds[i]]], col=rgb(0,1,0,0.5), lty=1) # plot the lines with 3 peaks


#!/usr/bin/env Rscript

## Item Response Theory (IRT) - Partial Credit Model (PCM)
# Copyright 2021 Enrico Glerean
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

# In this script we fit the PCM for polytomous data as implemented
# by the R packages eRm
# We report
# 1. summary statistics for the fitted model
# 2. Item Characteristic Curves (ICC) for each item
# 3. Wright map
# 4. Item fit summary statistics and item map
# 5. Person fit summary statistics and person fit map
# 6. test for the unidimensionality of the data
# 7. test for local dependence of items

# We use the eRm package
library("eRm")

dfA <- read.table("../results/scores/scores_sorted.csv",header=TRUE, sep=',', colClasses = "integer")
dfA <- dfA + 1 # We have values from 0 to 2 as required by eRM packages with polytomous data

# 1. model fitting and summary statistics for the fitted model
PC_model <- PCM(df)
summary(PC_model)
th <- thresholds(PC_model)
th

# 2. Item Characteristic Curves (ICC) for each item
#    TODO: legends and title could be improved
lab <- labels(df)[[2]]
for(n in lab){
  print(paste("Plotting item ",n))
  # figures are stored in ../results/figures/
  pdf(paste('../results/figures/',n,'-ICC.pdf',sep=""))
  plotICC(PC_model,item.subset=n)
  dev.off()
}

# 3. Person-Item map (Wright map)
pdf('../results/figures/PImap.pdf')
plotPImap(PC_model)
dev.off()
pdf('../results/figures/PImap_C1.pdf')
plotPImap(PC_model,item.subset = c(1,2,3,4,5,6,7,8,9,10,11,12))
dev.off()
pdf('../results/figures/PImap_C2.pdf')
plotPImap(PC_model,item.subset = c(13,14,15,16,17,18,19,20,21,22))
dev.off()
pdf('../results/figures/PImap_C3.pdf')
plotPImap(PC_model,item.subset = c(23,24,25,26,27,28,29,30,31,32,33,34))
dev.off()
pdf('../results/figures/PImap_C4.pdf')
plotPImap(PC_model,item.subset = c(35,36,37,38,39,40))
dev.off()

# 4. Item fit summary statistics and item fit map
pres <- person.parameter(PC_model)
itfi <- itemfit(pres)
itfi
pdf('../results/figures/PW_itemMap.pdf')
plotPWmap(PC_model)
dev.off()

# 5. Person fit summary statistics and person fit map
pefi <- personfit(pres)
pdf('../results/figures/PW_personsMap.pdf')
plotPWmap(PC_model,pmap=TRUE, imap=FALSE)
dev.off()

# 6. test for the unidimensionality of the data
utest <- MLoef(PC_model)
utest

# 7. test for local dependence of items
res <- residuals(pres)
Q3 <- cor(res,method="pearson")
diag(Q3)<-NA
Q3star=Q3 - mean(Q3, na.rm = TRUE)
ii = which(abs(Q3star) > 0.2)
m = 40
for(ind in ii){
  rid = ((ind-1) %% m) + 1
  cid = floor((ind-1) / m) + 1
  print(paste(labels(df)[[2]][rid],labels(df)[[2]][cid],Q3star[rid,cid],sep=" "))
}


require(Hmisc)
if(FALSE) .Fortran('jrank', as.double(1:5), as.double(1:5), 5L,
                   double(5), double(5), double(5))
hoeffd(1:6, c(1,3,2,4,5,6))
y <- 1:20; y[3] <- 17; y[17] <- 3
hoeffd(1:20, y)$D
set.seed(5)
x <- runif(800); y <- runif(800)
hoeffd(x,y)$D

for(n in c(50,100,200,400,1000)) {
  set.seed(1)
  x <- seq(-10,10,length=n)
  y <- x*sign(runif(n,-1,1))
  h <- hoeffd(x,y)
  print(c(h$D[1,2], h$aad[1,2], h$maxad[1,2]))
}
#[1] 0.06812286   in old version (real*4 in places)
#[1] 0.04667929
#[1] 0.05657654
#[1] 0.07048487
#[1] 0.06323746

# From http://www.sciencemag.org/content/suppl/2011/12/14/334.6062.1518.DC1/Reshef.SOM.pdf
# Table S2: Definitions of functions used for Figure 2A in the Science article

w <- function(y) {
  ylab <- deparse(substitute(y))
  plot(x, y, ylab=substitute(y), type='l')
  h <- hoeffd(x, y)
  cat(ylab, '\n')
  print(c(D=h$D[1,2],P=h$P[1,2],aDif=h$aad[1,2],mDif=h$maxad[1,2]))
}

x <- seq(0, 1, length=320)
par(mfrow=c(3,3))
w(x)
w(4*(x-.5)^2)
w(128*(x-1/3)^3 -48*(x-1/3)^2 - 12*(x-1/3) + 2)
w(10^(10*x) - 1)
w(sin(10*pi*x) + x)
w(sin(16*pi*x))
w(sin(13*pi*x))
w(sin(7*pi*x*(1+x)))
w(runif(320))


Mean=c(2.2, 4.6 ,21.2 ,31.4)
Standard_deviation=c(1.476,2.119,4.733,5.52)
s_min=min(Standard_deviation)
s_max=max(Standard_deviation)
# test statistic
F=s_max^2/s_min^2
print(F)
# The critical value of F > F.alpha
#  we reject the hypothesis of homogeneity
#of the population variances.

distance_1km=c(1,5,2,1,2,2,4,3,0,2)
distance_5km=c(4,8,2,3,8,5,6,4,3,3)
distance_10km=c(20,26,24,11,28,20,19,19,21,24)
distance_20km=c(37,30,26,24,41,25,36,31,31,33)
print(Standard_deviation[1]^2/Mean[1])
print(Standard_deviation[2]^2/Mean[2])
print(Standard_deviation[3]^2/Mean[3])
print(Standard_deviation[4]^2/Mean[4])
i=1
while(i<11){
  distance_1km[i]=sqrt(distance_1km[i]+0.375)
  i=i+1
}
i=1
while(i<11){
  distance_5km[i]=sqrt(distance_5km[i]+0.375)
  i=i+1
}
i=1
while(i<11){
  distance_10km[i]=sqrt(distance_10km[i]+0.375)
  i=i+1
}
i=1
while(i<11){
  distance_20km[i]=sqrt(distance_20km[i]+0.375)
  i=i+1
}
combined_group=data.frame(cbind(distance_1km,distance_5km,distance_10km,distance_20km))
combined_group


library("MASS")
data("OME")

dat = subset(OME, OME != "N/A")
dat$OME = factor(dat$OME) # relabel OME
dat$ID = as.numeric(factor(dat$ID)) # relabel ID so there are no gaps in numbers (they now go from 1 to 63)

## Original reference model and covariate matrix
mod_glm = glm(Correct/Trials ~ Age + OME + Loud + Noise, data=dat, weights=Trials, family="binomial")
X = model.matrix(mod_glm)[,-1]

## Original model (that needs to be extended)
mod_string = " model {
	for (i in 1:length(y)) {
		y[i] ~ dbin(phi[i], n[i])
		logit(phi[i]) = a[ID[i]] + b[1]*Age[i] + b[2]*OMElow[i] + b[3]*Loud[i] + b[4]*Noiseincoherent[i]
	}

    for (k in 1:max(ID)){
        a[k] ~ dnorm(a0, tau_prec)
    }

	a0 ~ dnorm(0.0, 1.0/10.0^2)
    tau_prec ~ dgamma(1.0/2.0, 1.0/2.0)
    tau = 1.0/tau_prec

	for (j in 1:4) {
		b[j] ~ dnorm(0.0, 1.0/4.0^2)
	}

} "

data_jags = as.list(as.data.frame(X))
data_jags$y = dat$Correct
data_jags$n = dat$Trials
data_jags$ID = dat$ID

library("rjags")

set.seed(113)

params = c("a0", "tau", "a", "b")

mod = jags.model(textConnection(mod_string), data=data_jags, n.chains=3)
update(mod, 1e3)

mod_sim = coda.samples(model=mod,
                       variable.names=params,
                       n.iter=5e3)
mod_csim = as.mcmc(do.call(rbind, mod_sim))

## convergence diagnostics
plot(mod_sim)

gelman.diag(mod_sim)
autocorr.diag(mod_sim)
autocorr.plot(mod_sim)
effectiveSize(mod_sim)

## compute DIC
dic = dic.samples(mod, n.iter=1e3)


## The function to calculate the likelihood values.

Calculation<-function(Simulation,Measurement,Variance)
{
Constant=10000;
#A constant to amplify the likelihood values in case of beyond computer precision becasue the vasues may be very small.

Likelihood<-Constant*(1/sqrt(2*pi*Variance))*exp(-(Measurement-Simulation)^2/(2*Variance));
# The likelihood function derived from the normal distribution.

return(Likelihood);

}