# COVID-19
#
# Estimación de los parametros de una exponecial/ logistica,  el factor de crecimiento
# También para los casos de contacto directo
#
# Fuente @msalnacion
#

require(dplyr)
require(readr)
require(lubridate)
cor <- read_csv("/home/leonardo/Academicos/GitProjects/covid19/coronavirus_ar.csv") %>% dplyr::select(fecha:comunitarios)
cor <- cor  %>% mutate(fecha=ymd(fecha), dias =as.numeric( fecha - min(fecha)))
#
# OJO, los casos en estudio = ? comunitarios no estan acumulados
#

require(ggplot2)

# g0 <- ggplot(cor,aes(x=dias,y=casos)) + geom_point() + theme_bw() + geom_smooth(method="glm",family=gaussian(link="log"))
# g1 <- g0 + expand_limits(x=c(0,240))+
#   geom_smooth(method="glm",family=gaussian(link="log"),
#               fullrange=TRUE)

# Comparación de distintos modelos utilizando el criterio de Akaike (lineal y exponencial nomas)
#
expmdl <- lm(log(casos)~ dias,data=cor)
summary(expmdl)
linmdl <- lm(casos~ dias,data=cor)
summary(linmdl)
AIC(linmdl,expmdl)

# Ajuste no-lineal del los parametros del modelo exponencial
#
model <- nls(casos ~ alpha * exp(beta * dias) , data =cor  , start=list(alpha=0.6,beta=0.4))
# Ajuste del modelo logístico
require(drc)
#
# f(x) = d / (1+exp(b(x - e)))
#
model1 <- drm(casos ~ dias, fct=L.3() , data = cor)
summary(model1)
capacidadcarga <- round(coef(model1)[2])
AIC(model,model1)
# Despues del dia 21 El ajuste del modelo logístico es mejor
# En el dia 21 todavia ajustaba mejor el modelo exponencial
#

# Extraigo los coeficientes para ponerlos en el gráfico
#
model <- nls(casos ~ alpha * exp(beta * dias) , data = filter(cor, dias<22)  , start=list(alpha=0.6,beta=0.4))

a <- round(coef(model)[1],2)
b <- round(coef(model)[2],2)
summary(model)
# Tiempo de duplicacion
#
tau <-  round(log(2)/b,2)

# Prediccion hasta 12/04
#
ldia <- as.numeric(ymd("2020-04-12") - min(cor$fecha))
predexp <-data.frame(pred=predict(model,newdata=data.frame(dias=0:ldia)),predlog = predict(model1,newdata=data.frame(dias=0:ldia))) %>% mutate(dias=0:ldia, fecha=min(cor$fecha)+dias)
predexp
# Estimación de R0
#
#
# Generation time from
# https://github.com/midas-network/COVID-19/tree/master/parameter_estimates/2019_novel_coronavirus
#
require(R0)
mGT<-generation.time("gamma", c(7.5, 3.4))
est.R0.EG(cor$casosdia,mGT,begin = 1,end=22)

tl <- est.R0.ML(cor$casosdia,mGT,begin = 1,end=22)
#plotfit(tl)
r <- round(tl$R,2)
r0 <- round(tl$conf.int,2)

col <- viridisLite::viridis(2)
# Casos totales
#
ggplot(cor, aes(x = fecha, y = casos) ) +
  geom_point() +
#  geom_ribbon( aes(ymin = lwr, ymax = upr), alpha = .15) +
  geom_line(data=predexp, aes(x=fecha,y = pred), size = .5, color= col[1]) +
  geom_line(data=predexp, aes(x=fecha,y = predlog), size = .5, color= col[2]) +  theme_bw() +
  annotate("text",x=ymd("20200330"), y=1, label="Fuente @msalnacion\n by @larysar",color="red",size=2) + scale_y_log10() +
  annotate("text", x=ymd("20200325"), y=3,label=paste("R0 =", r, "[", r0[1], ",", r0[2],"]"),size=3) +
  annotate("text", x=ymd("20200325"), y=2,label=paste("Capacidad de carga =", capacidadcarga),size=3)

ggsave("/home/leonardo/Academicos/GitProjects/covid19/coronaArTotalesLog.jpg",width=6,height=6,units="in",dpi=600)

# Growth Factor para casos totales
#
cor <- cor %>% mutate(delta=casos-lag(casos),deltaPrev=lag(delta),growthFactor= delta/deltaPrev)

ggplot(cor %>% filter(dias>3),aes(x=dias,y=growthFactor)) + geom_point() + theme_bw() + stat_smooth(method=lm,se=FALSE) +   labs(title = bquote("Growth Factor=" ~ Delta* N[t] / Delta* N[t-1] ))  + theme_bw() + annotate(geom="text", x=5, y=8, label="Fuente @msalnacion\n by @larysar",color="red",size=2)

# Nuevos casos vs casos totales en log
#

predexp <- predexp %>% mutate( preddia = pred - lag(pred))

ggplot(cor, aes(x = casos, y = casosdia) ) +
  geom_point() + geom_line() + scale_x_log10() + scale_y_log10() + theme_bw() + ylab("Nuevos casos") + xlab("Casos totales")+
  geom_line(data=predexp, aes(x=pred, y = preddia), size = .5, color= "blue") + coord_cartesian(xlim=c(9,max(predexp$pred)))+
  annotate(geom="text", x=1000, y=1, label="Fuente @msalnacion\n by @larysar",color="red",size=2)

ggsave("/home/leonardo/Academicos/GitProjects/covid19/coronaArNuevosVsTotales.jpg",width=6,height=6,units="in",dpi=600)

#  geom_line(data=predexp, aes(x=fecha,y = pred), size = .5, color= "blue")

#
# Contactos e Importados Comunitarios by group usando tidyverse
#
require(tidyr)
cor1 <- cor %>% gather(tipo,N,casos:comunitarios,importados) %>% filter(tipo %in% c("contactos","importados","comunitarios")) %>% mutate(N = ifelse(N==0,NA,N))

ggplot(cor1 ,aes(x=dias,y=N,color=tipo)) + geom_point() + theme_bw() + stat_smooth(method=lm, se=F) + scale_y_log10() + scale_color_viridis_d() + ylab("Casos")

ggplot(cor1,aes(x=dias,y=N,color=tipo)) + geom_point() + theme_bw() + scale_color_viridis_d() + scale_color_viridis_d() + scale_y_log10() + ylab("Casos") + geom_line()

mod <- cor1 %>% filter(N>0) %>% group_by(tipo) %>% do(mod=drm(N ~ dias, fct=L.3() , data = .) )
mod  %>% do(data.frame(max= coef(.$mod)[2],.$tipo))

newdat <- data.frame(dias = 0:ldia)
library(tidyverse)
predexp <- cor1 %>%
  group_by(tipo) %>%
  nest %>%
    mutate(mod  = purrr::map(.x = data, .f = ~ drm(N ~ dias, fct=L.3() , data = .))) %>%
#    mutate(mod  = purrr::map(.x = data, .f = ~ nls(N~ alpha*exp(dias*beta),start=c(alpha=1.4,beta=0.2),data=.))) %>%
  mutate(pred = purrr::map(.x = mod, ~ predict(., newdat))) %>%
  dplyr::select(tipo,pred) %>% unnest(cols=pred) %>% bind_cols(dias = rep(newdat$dias,3)) %>% mutate(fecha = min(cor1$fecha)+dias)

ggplot(cor1,aes(x=fecha,y=N,color=tipo)) + geom_point() + theme_bw() + scale_color_viridis_d() + scale_color_viridis_d() + ylab("Casos") + geom_line(data=predexp, aes(x=fecha,y = pred,color=tipo), size = .5)
#ggsave("/home/leonardo/Academicos/GitProjects/covid19/coronaArComparacion.jpg",width=6,height=6,units="in",dpi=600)

ggplot(cor1,aes(x=fecha,y=N,color=tipo)) + geom_point() + theme_bw() + scale_color_viridis_d() + scale_color_viridis_d() + scale_y_log10() + ylab("Casos") + geom_line(data=predexp, aes(x=fecha,y = pred,color=tipo), size = .5)
ggsave("/home/leonardo/Academicos/GitProjects/covid19/coronaArComparacionComunitarios.jpg",width=6,height=6,units="in",dpi=600)

#ggsave("/home/leonardo/Academicos/GitProjects/covid19/coronaArComparacionLog.jpg",width=6,height=6,units="in",dpi=600)

#
# Comparacion Casos GLobales Tasa de crecimiento vs Casos Totales
#
# Fuente:  Johns Hopkins University Center for Systems Science and Engineering.
#          https://systems.jhu.edu/research/public-health/ncov/
#
#

corg <- read_csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv")

corg <- corg %>% rename(country="Country/Region",province="Province/State")  %>% filter( country %in% c("US","Italy","Brazil", "Korea, South"))
require(tidyr)

# Umbral de casos a partir de los cuales se calcula la curva
#
umbral <- 100

cor1 <- corg %>% gather(date,N,5:ncol(corg) ) %>% arrange(country) %>% mutate(casosdia = N - lag(N)) %>%  filter(N>umbral, casosdia>0 ) %>% group_by(country) %>% mutate(fecha=mdy(date), dias =as.numeric( fecha - min(fecha)))

# Para argentina usa los datos de @minsal
#
cor1 <- bind_rows( cor1, cor %>% filter(casos>umbral) %>%dplyr::select(casos,casosdia,fecha) %>% mutate(country="Argentina",dias =as.numeric( fecha - min(fecha))) %>% rename(N=casos))

require(ggplot2)

ggplot(cor1, aes(x = N, y = casosdia, colour=country) ) + scale_y_log10() +  scale_x_log10() +
  geom_point() +  theme_bw() +  guides(fill=FALSE) + scale_color_viridis_d() + geom_line() + xlab("Casos Totales") + ylab( "Casos por Día") +
  annotate("text",x=1850, y=10, label="Fuente https://systems.jhu.edu/research/public-health/ncov/\n by @larysar",color="red",size=2) + theme(legend.position="bottom")
ggsave("/home/leonardo/Academicos/GitProjects/covid19/coronaGlobalNuevosVsTotales.jpg",width=6,height=6,units="in",dpi=600)


"
Ввести с клавиатуры число N. Подсчитать сумму 1 + 2 + ... + N.
Вывести на экран введенное число и результат расчета.
"
{
  N <- readline("Введите число N  -> ")

  sum <- 0
  for(i in 1:N){
    print(i)
    sum <- sum + i
  }

  print(paste("Сумма:",sum))
}


IsPrime <- function(n) {
    for (i in 2:(n/2)) {
        if ( n %% i == 0) {
            return(FALSE)
        }
    }
    return(TRUE)
}

for (i in 2:100)
    if (IsPrime(i))
        print(i)


# Install and load required packages --------------------------------------------------------------------------------------------------

install.packages("tidyverse")
install.packages("dagitty")
install.packages("ggdag")
install.packages("bnlearn")
install.packages("Rgraphviz")
install.packages("causaleffect")
install.packages("igraph")
install.packages("latex2exp")

library(tidyverse)
library(dagitty)
library(ggdag)
library(bnlearn)
library(Rgraphviz)
library(causaleffect)
library(igraph)
library(latex2exp)

# Slide 12. Common Effect example -----------------------------------------------------------------------------------------------------

talent <- rnorm(10000, 0, 1)
hardwork <- rnorm(10000, 0, 1)
df <- data.frame(talent, hardwork)

# Compute the correlation between the variables

df %>% summarize(correlation = cor(talent, hardwork))

# Success is equal to one if the sum of talent and hardwork is above the 80th percentile in the population -----------

x <- talent + hardwork
success <- 1*(x > quantile(x, c(.8)))
df <- cbind(df, success)

df %>% filter(success == 1) %>% summarize(correlation = cor(talent, hardwork))

# Slide 17. Correlation doesn't imply causation ---------------------------------------------------------------------

# Error terms

e_x <- rnorm(10000)
e_y <- rnorm(10000)
e_z <- rnorm(10000)

# Create nodes for the DAG: y <- x, y <- z, x <- z

z <- 1*(e_z > 0)
x <- 1*(z + e_x > 0.5)
y <- 1*(x + z + e_y > 2)
y_dox <- 1*(1 + z + e_y > 2)

# We see that P(y|do(x=1)) is not equal to P(y|x=1)

mean(y_dox)
mean(y[x==1])

# Slide 17. Visualizing DAGs with ggdag -----------------------------------------------------------------------------

coords <- data.frame(matrix(c("x",0,0,
                              "y",2,0,
                              "z",1,1,
                              "w",1,0), nrow=4, ncol=3, byrow=T))

colnames(coords) <- c("name","x","y")

# "y ~ w" means that w is a parent of y

dag <- ggdag:: dagify(y ~ w,
                      y ~ z,
                      w ~ x,
                      x ~ z,
              exposure = "x",
              outcome = "y",
              coords=coords)

# Plot the DAG

ggdag::ggdag(dag)

# Find all parents of outcome

ggdag:: ggdag_parents(dag, "y")

# Slide 20.Testable implications of graphs --------------------------------------------------------------------------

coords <- data.frame(matrix(c("A",0,0,
                              "B",0,1,
                              "C",1,2,
                              "D",2,1,
                              "E",2,0), nrow=5, ncol=3, byrow=T))

colnames(coords) <- c("name","x","y")

# "A ~ B" means that B is a parent of A

dag <- ggdag:: dagify(A ~ B,
                      C ~ A,
                      C ~ B,
                      E ~ A,
                      C ~ D,
                      E ~ C,
                      E ~ D,
                      exposure = "A",
                      outcome = "E",
                      coords=coords)

# Plot the DAG

ggdag::ggdag(dag)

# Find all d-separation relationships in a DAG

impliedConditionalIndependencies(dag)

# Slide 24. PC Algorithm --------------------------------------------------------------------------------------------

# Simulate data : z <- x, w <- x, w <- y, w <- z

x <- rnorm(10000, 0, 1)
y <- rnorm(10000, 0, 1)
z <- x + rnorm(10000, 0, 1)
w <- x + y + z + rnorm(1000, 0, 1)

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

# PC Algorithm

str <- pc.stable(df, test = "cor", alpha = 0.05, undirected = FALSE)

graphviz.plot(str)

# Slide 29. Backdoor Criterion --------------------------------------------------------------------------------------

coords <- data.frame(matrix(c("x",0,0,
                              "w",1,0,
                              "y",2,0,
                              "z",1,1), nrow=4, ncol=3, byrow=T))

colnames(coords) <- c("name","x","y")

# "x ~ z" means that z is a parent of x

dag <- ggdag:: dagify(x ~ z,
                      w ~ x,
                      y ~ w,
                      y ~ z,
                      exposure = "x",
                      outcome = "y",
                      coords=coords)

# Plot the DAG

ggdag::ggdag(dag)

# List all direct causal effects that are identifiable via backdoor adjustment

for(n in names(dag)){
  for(m in dagitty::children(dag,n)){
    a <- adjustmentSets(dag, n, m, effect="direct")
    if(length(a) > 0){
      cat("The causal effect of ",n," on ",m,
          " is identifiable controlling for:\n",sep="")
      print(a, prefix=" * ")
    }
  }
}

# Example

# Error terms

e_x <- rnorm(10000)
e_y <- rnorm(10000)
e_z <- rnorm(10000)

# Create nodes for the DAG: y <- x, y <- z, x <- z

z <- 1*(e_z > 0)
x <- 1*(z + e_x > 0.5)
y <- 1*(x + z + e_y > 2)

y_dox <- 1*(1 + z + e_y > 2)

mean(y_dox)

# Adjustment formula: P(y|do(x=1)) = P(y|x=1, z=1)*P(z=1) + P(y|x=1, z=0)*P(z=0)

mean(y[x==1 & z==1]) * mean(z==1) + mean(y[x==1 & z==0]) * mean(z==0)

# Do-Calculus ------------------------------------------------------------------------------------------------------

# The causaleffect package uses different syntax than "dagitty", note the +- instead of ~

dag <- graph.formula(y +- z5, y +- z6, y +- z1,
                     z6 +- x,
                     z5 +- z4,
                     z2 +- z3,
                     z1 +- z4, z1 +- z3,
                     x +- z2, x +- z1,
                     simplify = FALSE)

# Shpitser and Pearl (2006) algorithm for the rules of do-calculus. If the effect is identifiable, the function
# returns an expression for the causal effect.

ce_backdoor <- causal.effect(y = "y", x = "x", z = NULL, G = dag, expr = TRUE)
plot(TeX(ce_backdoor), cex=2)


f_logLikelihood <- function(M,x_train,uniform_dist,u,sigma)
{
  logLike <- sum(log(M[[1]]*uniform_dist + M[[2]]*dnorm(x_train, u, sqrt(sigma))))
  return (logLike)
}

f_updateResposibilities <- function(M,x_train,uniform_dist,u,sigma)
{
  uniformP <- uniform_dist
  gaussP <- dnorm(x_train, u, sqrt(sigma)) #stats.norm.pdf(x_train,u,sqrt(sigma))
  resposibilities <- cbind( (M[[1]]*uniformP / (M[[1]]*uniformP + M[[2]]*gaussP)), #.reshape(-1,1),
                                (M[[2]]*gaussP / (M[[1]]*uniformP + M[[2]]*gaussP)) ) # .reshape(-1,1) ))
  return (resposibilities)
}

f_updateMixtureParams <- function(resposibilities,M,x_train)
{
  M[[1]] <- sum(resposibilities[,1])/sum(resposibilities)
  M[[2]] <- sum(resposibilities[,2])/sum(resposibilities)
  u <- (sum(resposibilities[,2]*x_train))/sum(resposibilities[,2])
  sigma <- sum((x_train-u)**2*resposibilities[,2])/sum(resposibilities[,2])
  return (list("M" = M,
               #"uniform_dist" = uniform_dist,
               "u" = u,
               "sigma" = sigma))
}

f_calcCutoffs <- function(M,x_train,u,sigma)
{
  tmp <- sqrt(-2*sqrt(sigma)**2 * (log(M[[1]]/M[[2]]) - log(max(x_train)-min(x_train)) + log(sqrt(sigma)) + 0.5*log(2*pi)))
  cutoffs <- c("low" = u-tmp,
               "high" = u+tmp)
  return (cutoffs)
}

f_call_changes <- function(all_t_tests)
{
  # ignore DEAD and GHOST columns
  localization_cols <- colnames(all_t_tests)[ !colnames(all_t_tests) %in% c("GHOST", "DEAD")]
  tscores <- all_t_tests[ ,localization_cols ]

  localization_hits = list()
  Outlier_M <- 0.001
  for (loc in localization_cols)
  {
    x_train = tscores[,loc]
    ### remove BLANK
    x_train <- x_train[ grep("BLANK", names(x_train), invert=T)]
    ### end remove BLANK
    M <- c(Outlier_M, 1-Outlier_M)
    #randInd = np.random.rand(len(x_train))
    resposibilities <- cbind(0.5 * rep(1, length(x_train)),
                             0.5 * rep(1, length(x_train)))
    uniform_dist <- rep(1, length(x_train))/(max(x_train) - min(x_train))
    u <- 0
    sigma <- 0.1**2
    loglike_prev <- 1
    loglike <- 10
    i <- 0
    while (abs(loglike_prev-loglike) > 0.1)
    {
      loglike_prev <- loglike
      resposibilities <- f_updateResposibilities(M, x_train, uniform_dist, u, sigma)
      res_f_upd <- f_updateMixtureParams(resposibilities, M, x_train)
      u <- res_f_upd$u
      sigma <- res_f_upd$sigma
      #M = [Outlier_M, 1.-Outlier_M] # I do not update this parameter, therefore we do not need to reset it
      loglike <- f_logLikelihood(M, x_train, uniform_dist, u, sigma)
      i <- i+1
    }
    cutoffs <- f_calcCutoffs(M,x_train,u,sigma)
    localization_hits[[loc]] <- all_t_tests[ (all_t_tests[,loc] < cutoffs[["low"]]) |
                                          (all_t_tests[,loc] > cutoffs[["high"]]), ]
  }
  sapply(localization_hits, nrow)
  sum(sapply(localization_hits, nrow))
  sum(sapply(localization_hits, function(x) { length(grep("BLANK", row.names(x), invert=T)) }))
  df <- do.call("rbind", localization_hits)
  nrow(df)
  nrow(unique(df))
  nrow(unique(df[ grep("BLANK", row.names(df), invert = T),]))
  return (localication_hits)
}

f_get_significant_changes <- function(t_tests, Outlier_M = 0.001, VERBOSE=F)
{
  compartments <- colnames(t_tests)
  localization_hits = list()
  significant_changes <- list()
  significant_mut_higher <- list()
  significant_WT_higher <- list()
  cutoffs <- list()
  for (loc in compartments)
  {
    x_train = t_tests[,loc]
    M <- c(Outlier_M, 1-Outlier_M)
    resposibilities <- cbind(0.5 * rep(1, length(x_train)),
                             0.5 * rep(1, length(x_train)))
    uniform_dist <- rep(1, length(x_train))/(max(x_train) - min(x_train))
    u <- 0
    sigma <- 0.1**2
    loglike_prev <- 1
    loglike <- 10
    i <- 0
    while (abs(loglike_prev-loglike) > 0.1)
    {
      loglike_prev <- loglike
      resposibilities <- f_updateResposibilities(M, x_train, uniform_dist, u, sigma)
      res_f_upd <- f_updateMixtureParams(resposibilities, M, x_train)
      u <- res_f_upd$u
      sigma <- res_f_upd$sigma
      #M = [Outlier_M, 1.-Outlier_M] # I do not update this parameter, therefore we do not need to reset it
      loglike <- f_logLikelihood(M, x_train, uniform_dist, u, sigma)
      i <- i+1
    }
    cutoffs[[loc]] <- f_calcCutoffs(M,x_train,u,sigma)
    cutoffs[[loc]][["u"]] <- u
    cutoffs[[loc]][["sigma"]] <- sigma
    localization_hits[[loc]] <- t_tests[ (t_tests[,loc] < cutoffs[[loc]][["low"]]) |
                                         (t_tests[,loc] > cutoffs[[loc]][["high"]]), ,
                                         drop=FALSE]
    cutoffs[[loc]][["counts_changes"]] <- nrow(localization_hits[[loc]])
    cutoffs[[loc]][["counts_mut_higher"]] <- sum(t_tests[,loc] < cutoffs[[loc]][["low"]])
    cutoffs[[loc]][["counts_WT_higher"]] <- sum(t_tests[,loc] > cutoffs[[loc]][["high"]])
    significant_changes[[loc]] <- sort(row.names(localization_hits[[loc]]))
    significant_mut_higher[[loc]] <- sort(row.names(t_tests)[ t_tests[,loc] < cutoffs[[loc]][["low"]] ])
    significant_WT_higher[[loc]] <- sort(row.names(t_tests)[ t_tests[,loc] > cutoffs[[loc]][["high"]] ])
    if (VERBOSE) { cat(sprintf("%s\t%s\t%s\t%s\t%s\t%s\n", loc, u, sigma, cutoffs[[loc]][["low"]], cutoffs[[loc]][["high"]], sum((t_tests[,loc] < cutoffs[["low"]]) | (t_tests[,loc] > cutoffs[["high"]]) ) ) ) }
  }
  # table to return w/ all t-tests, and adding the significant change in each row (we only show rows w/ at least a significant change)
  df <- unique(as.data.frame(do.call("rbind", localization_hits),stringsAsFactors = F))
  tmp <- do.call("rbind", sapply(names(significant_changes), function(x) { cbind(x, significant_changes[[x]] )  }) )
  locs_per_ORF <- sapply(split(tmp[,1], tmp[,2]), function(x) { paste(x, collapse=",") })
  df$enriched_loc <- locs_per_ORF[ row.names(df) ]
  # summary
  df_summary <- as.data.frame(do.call("rbind", cutoffs), stringsAsFactors = F)
  df_summary$genes_changing <- sapply(significant_changes[ row.names(df_summary) ], function(x) { paste(x, collapse=",") })
  df_summary$genes_mut_higher <- sapply(significant_mut_higher[ row.names(df_summary) ], function(x) { paste(x, collapse=",") })
  df_summary$genes_WT_higher <- sapply(significant_WT_higher[ row.names(df_summary) ], function(x) { paste(x, collapse=",") })
  return (list("df" = df,
               "df_summary" = df_summary))
}


library(ggplot2)

#' @param k     The shape parameter of the Erlang distribution.
#' @param gamma The rate parameter of the Erlang distribution.
#' @return      A vector containing all p_i values, for i = 1 : n.
compute_erlang_discrete_prob <- function(k, gamma) {
    n_bin <- 0
    factorials <- 1    ## 0! = 1
    for (i in 1 : k) {
        factorials[i + 1] <- factorials[i] * i    ## factorial[i + 1] = i!
    }

    one_sub_cummulative_probs <- NULL
    cummulative_prob <- 0
    while (cummulative_prob <= 0.99) {
        n_bin <- n_bin + 1

        one_sub_cummulative_probs[n_bin] <- 0
        for ( j in 0 : (k - 1) ) {
            one_sub_cummulative_probs[n_bin] <-
                one_sub_cummulative_probs[n_bin]  +
                (
                    exp( -n_bin * gamma )
                    * ( (n_bin * gamma) ^ j )
                    / factorials[j + 1]    ## factorials[j + 1] = j!
                )
        }
        cummulative_prob <- 1 - one_sub_cummulative_probs[n_bin]
    }
    one_sub_cummulative_probs <- c(1, one_sub_cummulative_probs)

    density_prob <-
        head(one_sub_cummulative_probs, -1) - tail(one_sub_cummulative_probs, -1)
    density_prob <- density_prob / cummulative_prob

    return(density_prob)
}

#' @param initial_state A vector that contains 4 numbers corresponding to the
#'                      initial values of the 4 classes: S, E, I, and R.
#' @param parameters    A vector that contains 5 numbers corresponding to the
#'                      following parameters: the shape and the rate parameters
#'                      of the Erlang distribution that will be used to
#'                      calculate the transition rates between the E components
#'                      (i.e. k[E] and gamma[E]), the shape and the rate parameters
#'                      of the Erlang distribution that will be used to
#'                      calculate the transition rates between the I components
#'                      (i.e. k[I] and gamma[I]), and the base transmission rate
#'                      (i.e. beta).
#' @param max_time      The length of the simulation.
#' @return A data frame containing the values of S, E, I, and R over time
#'         (from 1 to max_time).
seir_simulation <- function(initial_state, parameters, max_time) {
    names(initial_state) <- c("S", "E", "I", "R")
    names(parameters) <- c( "erlang_shape_for_E", "erlang_rate_for_E",
                            "erlang_shape_for_I", "erlang_rate_for_I",
                            "base_transmission_rate" )

    population_size <- sum(initial_state)
    sim_data <- data.frame( time = c(1 : max_time),
                            S = NA, E = NA, I = NA, R = NA )
    sim_data[1, 2:5] <- initial_state

    ## Initialise a matrix to store the states of the exposed sub-blocks over time.
    exposed_block_adm_rates <- compute_erlang_discrete_prob(
        k = parameters["erlang_shape_for_E"],
        gamma = parameters["erlang_rate_for_E"]
    )
    n_exposed_blocks <- length(exposed_block_adm_rates)
    exposed_blocks <- matrix( data = 0, nrow = max_time,
                              ncol = n_exposed_blocks )
    exposed_blocks[1, n_exposed_blocks] <- sim_data$E[1]

    ## Initialise a matrix to store the states of the infectious sub-blocks over time.
    infectious_block_adm_rates <- compute_erlang_discrete_prob(
        k = parameters["erlang_shape_for_I"],
        gamma = parameters["erlang_rate_for_I"]
    )
    n_infectious_blocks <- length(infectious_block_adm_rates)
    infectious_blocks <- matrix( data = 0, nrow = max_time,
                                 ncol = n_infectious_blocks )
    infectious_blocks[1, n_infectious_blocks] <- sim_data$I[1]

    ## Run the simulation from time t = 2 to t = max_time
    for (time in 2 : max_time) {
        transmission_rate <-
            parameters["base_transmission_rate"] * sim_data$I[time - 1] /
            population_size
        exposure_prob <- 1 - exp(-transmission_rate)

        new_exposed <- rbinom(1, sim_data$S[time - 1], exposure_prob)
        new_infectious <- exposed_blocks[time - 1, 1]
        new_recovered  <- infectious_blocks[time - 1, 1]

        if (new_exposed > 0) {
            exposed_blocks[time, ] <- t(
                rmultinom(1, size = new_exposed,
                          prob = exposed_block_adm_rates)
            )
        }
        exposed_blocks[time, ] <-
            exposed_blocks[time, ] +
            c( exposed_blocks[time - 1, 2 : n_exposed_blocks], 0 )

        if (new_infectious > 0) {
            infectious_blocks[time, ] <- t(
                rmultinom(1, size = new_infectious,
                          prob = infectious_block_adm_rates)
            )
        }
        infectious_blocks[time, ] <-
            infectious_blocks[time, ] +
            c( infectious_blocks[time - 1, 2 : n_infectious_blocks], 0 )

        sim_data$S[time] <- sim_data$S[time - 1] - new_exposed
        sim_data$E[time] <- sum(exposed_blocks[time, ])
        sim_data$I[time] <- sum(infectious_blocks[time, ])
        sim_data$R[time] <- sim_data$R[time - 1] + new_recovered
    }

    return(sim_data)
}

sim <- seir_simulation( initial_state = c(S = 9999, E = 1, I = 0, R = 0),
                        parameters = c(5, 1, 10, 1, 0.25),
                        max_time = 300 )

# Plot
ggplot(sim, aes(time)) +
    geom_line(aes(y = S, colour = "Susceptible"), lwd = 1) +
    geom_line(aes(y = E, colour = "Exposed"), lwd = 1) +
    geom_line(aes(y = I, colour = "Infectious"), lwd = 1) +
    geom_line(aes(y = R, colour = "Recovered"), lwd = 1) +
    xlab("Time") + ylab("Number of Individuals")

set.seed(12345)
test_sim <- seir_simulation( initial_state = c(S = 9999, E = 1, I = 0, R = 0),
                        parameters = c(5, 1, 10, 1, 0.25),
                        max_time = 100 )
test_result <- as.matrix( tail(test_sim, 3) )

correct_result <- matrix( c( 98, 7384, 794, 1015, 807,
                             99, 7184, 864, 1068, 884,
                            100, 6986, 920, 1144, 950), nrow = 3, byrow = T )

n_correct_cells <- sum(correct_result == test_result)

cat("\n--------------------\n")
if (n_correct_cells == 15) {
    cat("    Test PASSED\n")
} else {
    cat("    Test FAILED\n")
}
cat("--------------------\n\n")


inputs <- c(1.2, 5.1, 2.1)
weights <- c(3.1, 2.1, 8.7)
bias <- 3

output <- inputs[1] * weights[1] + inputs[2] * weights[2] + inputs[3] * weights[3] + bias
output


# purpose: calculate the heterosis
# Jinliang Yang
# 2.1.2012

setwd("/Users/yangjl/Documents/Heterosis_GWAS/pheno2011");
ptrait <- read.csv("diallel_ptrait.csv")

p <- subset(ptrait, Note=="Founder")
f1 <- subset(ptrait, Note=="F1")

f1$KRN_HPH <- NA
f1$KRN_MPH <- NA
f1$CL_HPH <- NA
f1$CL_MPH <- NA
f1$CW_HPH <- NA
f1$CW_MPH <- NA
f1$CD_HPH <- NA
f1$CD_MPH <- NA
f1$AKW_HPH <- NA
f1$AKW_MPH <- NA
f1$TKW_HPH <- NA
f1$TKW_MPH <- NA
f1$KC_HPH <- NA
f1$KC_MPH <- NA

for (i in 1:nrow(f1)){
  p1 <- as.character(f1$p1[i]);
  p2 <- as.character(f1$p2[i]);
  f1$KRN_HPH[i] <- f1$KRN[i] - max(p[p$ped==p1, ]$KRN, p[p$ped==p2, ]$KRN);
  f1$KRN_MPH[i] <- f1$KRN[i] - mean(c(p[p$ped==p1, ]$KRN, p[p$ped==p2, ]$KRN), na.rm=T);
  f1$CL_HPH[i] <- f1$CL[i] - max(p[p$ped==p1, ]$CL, p[p$ped==p2, ]$CL);
  f1$CL_MPH[i] <- f1$CL[i] - mean(c(p[p$ped==p1, ]$CL, p[p$ped==p2, ]$CL), na.rm=T);
  f1$CW_HPH[i] <- f1$CW[i] - max(p[p$ped==p1, ]$CW, p[p$ped==p2, ]$CW);
  f1$CW_MPH[i] <- f1$CW[i] - mean(c(p[p$ped==p1, ]$CW, p[p$ped==p2, ]$CW), na.rm=T);
  f1$CD_HPH[i] <- f1$CD[i] - max(p[p$ped==p1, ]$CD, p[p$ped==p2, ]$CD);
  f1$CD_MPH[i] <- f1$CD[i] - mean(c(p[p$ped==p1, ]$CD, p[p$ped==p2, ]$CD), na.rm=T);
  f1$AKW_HPH[i] <- f1$AKW[i] - max(p[p$ped==p1, ]$AKW, p[p$ped==p2, ]$AKW);
  f1$AKW_MPH[i] <- f1$AKW[i] - mean(c(p[p$ped==p1, ]$AKW, p[p$ped==p2, ]$AKW), na.rm=T);
  f1$TKW_HPH[i] <- f1$TKW[i] - max(p[p$ped==p1, ]$TKW, p[p$ped==p2, ]$TKW);
  f1$TKW_MPH[i] <- f1$TKW[i] - mean(c(p[p$ped==p1, ]$TKW, p[p$ped==p2, ]$TKW), na.rm=T);
  f1$KC_HPH[i] <- f1$KC[i] - max(p[p$ped==p1, ]$KC, p[p$ped==p2, ]$KC);
  f1$KC_MPH[i] <- f1$KC[i] - mean(c(p[p$ped==p1, ]$KC, p[p$ped==p2, ]$KC), na.rm=T);
}
#########################################################################################
par(mfrow=c(2,4))
hist(f1$KRN_HPH, main="KRN HPH", xlab="row", cex.lab=1.5);
hist(f1$KC_HPH, main="KC HPH", xlab="count", cex.lab=1.5);
hist(f1$TKW_HPH, main="TKW HPH", xlab="weight (g)", cex.lab=1.5);
hist(f1$AKW_HPH, main="AKW HPH", xlab="weight (g)", cex.lab=1.5);
hist(f1$CL_HPH, main="CL HPH", xlab="length (mm)", cex.lab=1.5);
hist(f1$CW_HPH, main="CW HPH", xlab="weight (g)", cex.lab=1.5);
hist(f1$CD_HPH, main="CD HPH", xlab="diameter (mm)", cex.lab=1.5);

par(mfrow=c(2,4))
hist(f1$KRN_MPH, main="KRN HPH", xlab="row", cex.lab=2);
hist(f1$KC_MPH, main="KC HPH", xlab="count", cex.lab=2);
hist(f1$TKW_MPH, main="TKW HPH", xlab="weight (g)", cex.lab=2);
hist(f1$AKW_MPH, main="AKW HPH", xlab="weight (g)", cex.lab=2);
hist(f1$CL_MPH, main="CL HPH", xlab="length (mm)", cex.lab=2);
hist(f1$CW_MPH, main="CW HPH", xlab="weight (g)", cex.lab=2);
hist(f1$CD_MPH, main="CD HPH", xlab="diameter (mm)", cex.lab=2);

#################################################################################
diallel <- f1

diallel$p1 <- toupper(diallel$p1)
diallel$p2 <- toupper(diallel$p2)

parents <- read.table("nam_parents", header=TRUE)
parents$parent <- toupper(parents$parent)
B73 <- data.frame(pop="B73", pedigree="B73", parent="B73")
parents <- rbind(B73, parents)

diallel <- merge(diallel, parents[, c(1,3)], by.x="p1", by.y="parent")
diallel <- merge(diallel, parents[, c(1,3)], by.x="p2", by.y="parent")

diallel$FID <- paste(diallel$pop.x, diallel$pop.y, sep="x")
diallel$IID <- 1
diallel <- diallel[,c("FID", "IID", "KRN", "CL", "CW", "CD", "AKW", "TKW", "KC",
                      "KRN_HPH", "CL_HPH", "CW_HPH", "CD_HPH", "AKW_HPH", "TKW_HPH", "KC_HPH",
                      "KRN_MPH", "CL_MPH", "CW_MPH", "CD_MPH", "AKW_MPH", "TKW_MPH", "KC_MPH")];

####default --missing-phenotype -9
diallel[is.na(diallel)] <- -9

write.table(diallel, "diallel_PLINK_040412.txt", row.names=FALSE, col.names=FALSE, quote=FALSE)

########################### Specific Combining Ability##########################################


# Maddison and Kremer long-run evidence

#########################################################################
# Pull Maddison data into dataframe
mad <- read.csv("maddison2010.csv", header=TRUE)

mad <- mad[which(mad$year>1819),] # only 1820 and later

mad$lndenmark <- round(log(mad$denmark),digits=2)
mad$lnfrance <- round(log(mad$france),digits=2)
mad$lnusa <- round(log(mad$usa),digits=2)
mad$lnenglandgbuk <- round(log(mad$englandgbuk),digits=2)
mad$lnhollandnetherlands <- round(log(mad$hollandnetherlands),digits=2)

#########################################################################
# Figure for long-run GDP per capita
#########################################################################
fig <- plot_ly(mad, x = ~year)
fig <- fig %>% add_trace(y = ~lnfrance, name = 'France', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnusa, name = 'USA', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnhollandnetherlands, name = 'Holland/Netherlands', type = 'scatter', mode = 'lines+markers')
fig <- fig %>% add_trace(y = ~lnenglandgbuk, name = 'England/UK', type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Log GDP per capita in the long run', x=0),
              xaxis = list(title = 'Year', tick0=1820, dtick=20),
              yaxis = list (title = 'Log GDP per capita', range=c(6,11)),
              hovermode="x unified")
api_create(fig, filename = "mad-stable-lngdppc")

##########################################################################
# Pull Maddison world data in and figure for global GDP per capita and pop
#########################################################################
mad <- read.csv("maddison_world.csv", header=TRUE)

fig <- plot_ly(mad, x = ~ln_pop, y = ~ln_gdppc, text=~year,
               type = 'scatter', mode = 'markers',
               marker = list(size = 10),
               hovertemplate = paste("Year: %{text}
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Relationship of GDP p.c. and population', x=0),
              xaxis = list(title = 'Log global population'),
              yaxis = list(title = 'Log global GDP per capita')
              )
api_create(fig, filename = "mad-global-lngdppc-pop")

# Calculate average growth rates between Maddison observations
mad <- # lag the population
  mad %>%
  mutate(lag.ln_pop = dplyr::lag(ln_pop, n = 1, default = NA))
mad <- # lag the year
  mad %>%
  mutate(lag.year = dplyr::lag(year, n = 1, default = NA))
mad <- # lag the GDP per capita
  mad %>%
  mutate(lag.ln_gdppc = dplyr::lag(ln_gdppc, n = 1, default = NA))
mad$gy <- (mad$ln_gdppc - mad$lag.ln_gdppc)/(mad$year-mad$lag.year)
mad$gl <- (mad$ln_pop - mad$lag.ln_pop)/(mad$year-mad$lag.year)

#########################################################################
# Figure of growth rate of population and growth rate of GDP per capita
#########################################################################
fig <- plot_ly(mad, x = ~gl, y = ~gy, text=~year,
               type = 'scatter', mode = 'markers',
               marker = list(size = 10),
               hovertemplate = paste("Year: %{text}
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Population and GDP p.c. growth', x=0),
              xaxis = list(title = 'Global population growth'),
              yaxis = list(title = 'GDP p.c.')
)
api_create(fig, filename = "mad-global-gy-gl")

#########################################################################
# Figure of pop growth rate and GDP per capita
#########################################################################
fig <- plot_ly(mad, x = ~gl, y = ~ln_gdppc, text=~year,
               type = 'scatter', mode = 'markers',
               marker = list(size = 10),
               hovertemplate = paste("Year: %{text}
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Population growth and GDP p.c.', x=0),
              xaxis = list(title = 'Global population growth'),
              yaxis = list(title = 'Global GDP p.c.')
)
api_create(fig, filename = "mad-global-y-gl")

#########################################################################
# Pull in Kremer data and create figure
#########################################################################
kr <- read.csv("kremer.csv", header=TRUE)
fig <- plot_ly(kr, x = ~pop, y = ~n, text=~year,
               type = 'scatter', mode = 'markers',
               marker = list(size = 10),
               hovertemplate = paste("Year: %{text}
","%{yaxis.title.text}: %{y:.2f}
",
                                     "%{xaxis.title.text}: %{x:.2f}
")
)
fig <- layout(fig, title = list(text = 'Population level and growth', x=0),
              xaxis = list(title = 'Population (millions)'),
              yaxis = list(title = 'Population growth rate')
)
api_create(fig, filename = "kremer-pop-gl")


#  James Rekow

meanOverCurve = function(M, lambda){

  #  ARGS:
  #
  #  RETURNS: the expected value of the mean overlap of a DOC with M samples and exponentially distributed
  #           wait times between interactions with rate parameter lambda

  return(1 - exp(-100 * lambda / M))

} #  end meanOverCurve function


#' Evaluate the probability density function of a density approximation
#'
#' description
#' @param fit An mvd.density object obtained from one of the density fitting functions.
#' @param x Matrix or vector of positions at which to evaluate the density function.
#' @param log Boolean which specifies whether to return the probability density in log space.
#' @export
mvd.pdf <- function(fit, x, log = FALSE) {
    stopifnot(class(fit) == "mvd.density")

    if (fit$type == "kde") {
        return(.evaluate.kde(fit, x, log))
    } else if (fit$type == "kde.transformed") {
        transformed <- mvd.transform_to_unbounded(x, fit$transform.bounds)
        p <- .evaluate.kde(fit$kde, transformed, log = log)
        return(mvd.correct_p_for_transformation(x, fit$transform.bounds, p, log = log))
    } else if (fit$type == "gmm") {
        if (is.matrix(x)) {
            stopifnot(ncol(x) == ncol(fit$centers))

            p <- matrix(NA, nrow(x), fit$K)
            for (ki in 1:fit$K) {
                if (log) {
                    p[, ki] <- mvtnorm::dmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = TRUE) + log(fit$proportions[ki])
                } else {
                    p[, ki] <- mvtnorm::dmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = FALSE) * fit$proportions[ki]
                }
            }

            if (log) {
                return(apply(p, 1, .logsum))
            } else {
                return(apply(p, 1, sum))
            }
        } else {
            stopifnot(length(x) == ncol(fit$centers))

            p <- rep(NA, fit$K)
            for (ki in 1:fit$K) {
                if (log) {
                    p[ki] <- mvtnorm::dmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = TRUE) + log(fit$proportions[ki])
                } else {
                    p[ki] <- mvtnorm::dmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = FALSE) * fit$proportions[ki]
                }
            }

            if (log) {
                return(.logsum(p))
            } else {
                return(sum(p))
            }
        }
    } else if (fit$type == "gmm.transformed") {
        transformed <- mvd.transform_to_unbounded(x, fit$transform.bounds)
        p <- mvd.pdf(fit$gmm, transformed, log = log)
        return(mvd.correct_p_for_transformation(x, fit$transform.bounds, p, log = log))
    } else if (fit$type == "gmm.truncated") {
        if (is.matrix(x)) {
            stopifnot(ncol(x) == ncol(fit$centers))

            p <- matrix(NA, nrow(x), fit$K)
            for (ki in 1:fit$K) {
                if (log) {
                    p[, ki] <- tmvtnorm::dtmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = TRUE) + log(fit$proportions[ki])
                } else {
                    p[, ki] <- tmvtnorm::dtmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = FALSE) * fit$proportions[ki]
                }
            }

            if (log) {
                return(apply(p, 1, .logsum))
            } else {
                return(apply(p, 1, sum))
            }
        } else {
            stopifnot(length(x) == ncol(fit$centers))

            p <- rep(NA, fit$K)
            for (ki in 1:fit$K) {
                if (log) {
                    p[ki] <- tmvtnorm::dtmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = TRUE) + log(fit$proportions[ki])
                } else {
                    p[ki] <- tmvtnorm::dtmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = FALSE) * fit$proportions[ki]
                }
            }

            if (log) {
                return(.logsum(p))
            } else {
                return(sum(p))
            }
        }
    } else if (fit$type == "gp") {
        return(evaluate.gp(fit, x, log))
    } else if (fit$type == "vine.copula") {
        return(evaluate.vine.copula(fit, x, log))
    } else if (fit$type == "mfa") {
      return(evaluate.factor.mixture(fit, x, log))
    } else if (fit$type == "mfa.transformed") {
      transformed <- mvd.transform_to_unbounded(x, fit$transform.bounds)
      p <- mvd.pdf(fit$mfa, transformed, log = log)
      return(mvd.correct_p_for_transformation(x, fit$transform.bounds, p, log = log))
    } else {
        stop("Unknown type")
    }
}


G02BRJ Example Program Results

Number of variables (columns) = 3
Number of case      (rows)    = 9

Data matrix is:-

          1       2       3
  1     1.7000  1.0000  0.5000
  2     2.8000  4.0000  3.0000
  3     0.6000  6.0000  2.5000
  4     1.8000  9.0000  6.0000
  5     0.9900  4.0000  2.5000
  6     1.4000  2.0000  5.5000
  7     1.8000  9.0000  7.5000
  8     2.5000  7.0000  0.0000
  9     0.9900  5.0000  3.0000

Matrix of rank correlation coefficients:
Upper triangle -- Spearman's
Lower triangle -- Kendall's tau

          1       2       3
  1     1.0000  0.2941  0.4058
  2     0.1429  1.0000  0.7537
  3     0.2760  0.5521  1.0000

Number of cases actually used: 6


#' Print a Simplex Table
#'
#' Using the notation of Bazaraa et. al., given a table \code{x} and a
#' basis vector \code{Bs}, this will produce the LaTeX for a simplex
#' tableau.
#'
#' @param x
#' A matrix of values for the simplex table.
#' @param Bs
#' The indices of the current basis.
#' @param digits
#' The number of decimal digits to use in the table.
#'
#' @importFrom xtable xtable align
#'
#' @export
tableau <- function(x, Bs, digits=0)
{
  namedBs <- sapply(Bs, function(i) ifelse(is.na(i), NA, paste0("$a_", i, "$")))
  df <- data.frame(cbind(x, namedBs))
  colnames(df) <- c("$z$", paste0("$x_", 1:(ncol(x)-2), "$"), "RHS", "$B_s$")

  tabl <- xtable::xtable(df, digits=digits)

  align <- paste0("r|r|", paste0(rep("r", ncol(x)-2), collapse=""), "|r|r|")
  xtable::align(tabl) <- align

  cat("\\begin{center}")
  print(tabl, floating=FALSE, include.rownames=FALSE,
        hline.after=c(-1:1, nrow(x)), sanitize.text.function=function(x){x})
  cat("\\end{center}")

  invisible()
}


library(pomp)
library(magrittr)
library(plyr)
library(reshape2)
library(ggplot2)
library(scales)
library(dplyr)

# measurement model
dmeas <- Csnippet("lik =  dnbinom_mu(cases, 1/od, H, 1); ")
rmeas <- Csnippet("cases = rnbinom_mu(1/od,H);")

# transmission model is Markovian SIRS with 3 age classes, seasonal forcing and overdispersion
sir.step <- Csnippet("double rate[7];
                      double dN[7];
                      double Beta1;
                      double dW;

                      // compute the environmental stochasticity
                      dW = rgammawn(sigma,dt);

                      Beta1 = beta1*(1 + beta11 * cos(M_2PI/52*t + phi)) * dW/dt;
                      rate[0] = mu*N;
                      rate[1] = Beta1*I/N;
                      rate[2] = mu;
                      rate[3] = gamma;
                      rate[4] = mu;
                      rate[5] = omega;
                      rate[6] = mu;

                      dN[0] = rpois(rate[0]*dt); // births are Poisson
                      reulermultinom(2, S, &rate[1], dt, &dN[1]);
                      reulermultinom(2, I, &rate[3], dt, &dN[3]);
                      reulermultinom(2, R, &rate[5], dt, &dN[5]);
                      S += dN[0] - dN[1] - dN[2] + dN[5];
                      I += dN[1] - dN[3] - dN[4];
                      R += dN[3] - dN[6] - dN[5];
                      H += dN[1];
                      ")

# initializer
init <- function(params, t0, ...) {
  x0 <- c(S=0,I=0,R=0,H=0)
  x0["S"] <- 79807318
  x0["I"] <- 3683
  x0["R"] <- params["N"] - x0["I"] - x0["S"]
  round(x0)
}

# paramter vector with betas and inital data, unit is weeks
params <- c(beta1=1, beta11=0.17, phi=0.1, gamma=1, mu=1/(75*52), N=80000000,
            omega=1/(1*52), od=0.1, sigma=0.05)

# create an empty data frame
dat <- data.frame(times=seq(1:400), cases = rep(0, 400))

#pomp object; initalize at t0 before t=0 so system can equilibrate
pomp(data = dat,
     times="times",
     t0=-100,
     dmeasure = dmeas,
     rmeasure = rmeas,
     rprocess = euler.sim(step.fun = sir.step, delta.t = 1/10),
     statenames = c("S", "I", "R", "H"),
     paramnames = names(params),
     zeronames=c("H"),
     initializer=init,
     params = params
) -> sir

#simulate one trajectory from the pomp object
df <- simulate(sir, as.data.frame=TRUE, seed=123)
# delete first row of the df because this is the accumulation of cases from t0 until t=0
df <-df[-1,]
# delete the last column of the df because this is the number of simulation
df <- df[,-7]

# plotting the simulated trajectory
df <-df%>% melt(id="time")
df$variable <- factor(df$variable)

df %>% mutate(variable = recode(variable, cases = "Cases")) %>%
  mutate(variable = recode(variable, S = "Susceptible")) %>%
  mutate(variable = recode(variable, I = "Infectious")) %>%
  mutate(variable = recode(variable, R = "Recovered")) %>%
  mutate(variable = recode(variable, H = "True incidence")) %>%
  # Plot
  ggplot() +
  geom_line(aes(x = time, y = value)) +
  facet_wrap( ~variable, ncol=1, scales =  "free_y")+
  xlab("Time (years)") + ylab(" Number of individuals")


##### calculate the TSLS esitmators and covariance matrix estimator

para=function(ivmodel){
  output=list()
  fit1=lm(ivmodel$Dadj~ivmodel$Zadj-1)
  output$gamma=coef(fit1)
  names(output$gamma)=NULL
  output$beta=c(KClass(ivmodel, k=1)$point.est)
  hat_eps=ivmodel$Yadj-c(output$beta)*ivmodel$Dadj
  hat_eta=resid(fit1)
  output$sigmau=sqrt(sum(hat_eps^2)/(ivmodel$n-ivmodel$p))
  output$sigmav=sqrt(sum(hat_eta^2)/(ivmodel$n-ivmodel$p))
  output$rho=sum(hat_eta*hat_eps)/(ivmodel$n-ivmodel$p)/output$sigmau/output$sigmav
  return(output)
}


#main function and helper functions for pTFCE R package

#main function

#' pTFCE main function.
#'
#' The threshold-free cluster enhancement (TFCE) approach integrates cluster information into voxel-wise statistical inference to enhance detectability of neuroimaging signal. Despite the significantly increased sensitivity, the application of TFCE is limited by several factors: (i) generalization to data structures, like brain network connectivity data is not trivial, (ii) TFCE values are in an arbitrary unit, therefore, P-values can only be obtained by a computationally demanding permutation-test.
#' Here, we introduce a probabilistic approach for TFCE (pTFCE), that gives a simple general framework for topology-based belief boosting.
#' The core of pTFCE is a conditional probability, calculated based on Bayes' rule, from the probability of voxel intensity and the threshold-wise likelihood function of the measured cluster size. We provide an estimation of these distributions based on Gaussian Random Field (GRF) theory. The conditional probabilities are then aggregated across cluster-forming thresholds by a novel incremental aggregation method. Our approach is validated on simulated and real fMRI data.
#' pTFCE is shown to be more robust to various ground truth shapes and provides a stricter control over cluster "leaking" than TFCE and, in the most realistic cases, further improves its sensitivity. Correction for multiple comparison can be trivially performed on the enhanced P-values, without the need for permutation testing, thus pTFCE is well-suitable for the improvement of statistical inference in any neuroimaging workflow.
#'
#' @references
#' T. Spisák, Z. Spisák, M. Zunhammer, U. Bingel, S. Smith, T. Nichols, T. Kincses, Probabilistic TFCE: a generalized combination of cluster size and voxel intensity to increase statistical power, Neuroimage.
#'
#' https://github.com/spisakt/pTFCE
#'
#' @param img Nifti Z-score image to enhance ("nifti" class from "oro.nifti" package)
#' @param mask Mask
#' @param Rd Resel count (FSL smoothest: VOLUME*DHL)
#' @param V Number of voxels in mask (FSL smoothest: VOLUME)
#' @param resels Resel size (FSL smoothest: RESELS)
#' @param residual 4D residual data for a better estimate of image smoothness (optional)
#' @param dof Degrees of freedom (optional, but obligatory if residual is specified)
#' @param Nh Number of thresholds (not safe to change the default)
#' @param logpmin min threshold (not safe to change the default)
#' @param logpmax max threshold (not safe to change the default)
#' @param ZestThr Cluster-forming Z threshold below which P(h|c) is estimated as P(h), due to limitation of GRF theory. (default: 1.3, not safe to change)
#' @param verbose boolean: print progress bar and diagnostic messages if true (default)
#'
#' @details The function takes a Z-score image and a mask image (both "nifti" object of the oro.nifti package) as obligatory inputs.
#' Mask can be either binary or continous, in the latter case it will be thresholded at 0.5.
#' Parameters V (number of voxels) and Rd (voxels per RESEL, computed as V*RESELS from the smoothest outpout) are optional and are to be interpreted as in FSL "smoothest".
#' If you want pTFCE to compute FWER-based Z-threshold for correction of multiple comparisons, specify the parameter resels (resels field of smoothest), together with Rd and V.
#' If not specified, these values are estimated from the data, internally via the smoothest() function of this package, which is a direct port of the corresponding FSL function.
#' If Rd and/or V is not specified, and residual and dof is specified, image smoothness will be determined basedd on teh 4D residual data (more accurate, see ?smoothest()).
#' For more details on smoothness estimation, see https://github.com/spisakt/pTFCE/wiki/Some-important-notes-on-smoothness-estimation.
#' The default value of the parameter Nh should work with images having usual ranges of Z-scores. At low values, although the processing becomes faster, the estimation of the enhanced values might become inaccurate and the enhanced p-value distribution becomes increasingly non-uniform. It is not recommended to set it lower than 30.
#' The parameters logpmin and logpmax define the range of values the incremental thresholding procedure covers. By default, these are based on the input data and it is not recommended to cahnge them.
#'
#' @return An object of class "ptfce" is a list containing at least the following components:
#' \itemize{
#' \item{\strong{p} (uncorrected) pTFCE enhanced p-values}
#' \item{\strong{logp}  negative logarithm of pTFCE enhanced p-values}
#' \item{\strong{Z} pTFCE enhanced p-values converted to Z-scores}
#' \item{\strong{number_of_resels} number of resels (input for e.g. ptoz) }
#' \item{\strong{fwer0.05.Z} Z-score threshold corresponding to the corrected p<0.05 threshold, controlled for FWER}
#' }
#'
#' @export
#'
#' @examples \dontrun{Z=readNIfTI("Zmap.nii.gz");
#'
#' MASK=readNIfTI("mask.nii.gz");
#'
#' # OPTION 1: use standalone with Z-map-based smoothness estimation
#' pTFCE=ptfce(Z, MASK); # estimate smoothness based on the Z-score map
#' # (might be inaccurate, but still guarantees FWER)
#'
#' #OPTION 2: use smoothness estimation based oj residual data (more accurate)
#' RES4D=readNIfTI("res4D.nii.gz");
#' pTFCE=ptfce(Z, MASK, residual=RES4D) # a bit slow, currently...
#'
#' #OPTION 2: equivalent to option2, but faster (uses FSL)
#' # run FSL smoothest in the command line:
#' # smoothest -r res4d.nii.gz -d DOF -m mask.nii.gz > smoothness.txt
#'
#' smooth=read.table("smoothness.txt"); # output by FSL smoothest
#' pTFCE=ptfce(Z, V=smooth[2,2], Rd = smooth[1,2]*smooth[2,2], mask = MASK);
#'
#' # plot if you want
#' orthographic(pTFCE$Z)
#'
#' # save NIfTI image
#' writeNIfTI(pTFCE$Z, "pTFCE_Z")
#'
#' #See https://github.com/spisakt/pTFCE fro more examples
#' }
ptfce=function(img, mask, Rd=NA, V=NA, resels=NA, residual=NA, dof=NA,  logpmin=0, logpmax=-log(stats::pnorm(max(img), lower.tail = F)), ZestThr=1.3, Nh=100, verbose=T )
{
  if (length(img[is.na(img)])>0)
  {
    warning("NAs detected and replaced with zero!")
    img[is.na(img)] = 0
  }
  if (length(img[!is.finite(img)])>0)
  {
    warning("Infinite values detected and replaced with zero!")
    img[!is.finite(img)] = 0
  }
  autosmooth=F
  if (is.na(Rd) || is.na(V))
  {
    autosmooth=T
    if (!is.na(residual))
    {
        if (!is.na(dof))
        {
          warning("Smoothness estimatmion based on 4D residual data is suboptimal and might be slow! Consider using FSL smoothest instead!")
          smooth=smoothest(residual, mask, dof = dof,  verbose = verbose)
        }
        else
        {
          warning("Residual but no dof specified: defaulting back to Z-score map-based smoothnes estimation")
          smooth=smoothest(img, mask, verbose = verbose)
        }
    }
    else
    {
      smooth=smoothest(img, mask, verbose = verbose)
    }
    V=smooth$volume
    Rd=smooth$dLh*V
  }

  logp.thres=seq(logpmin, logpmax, length.out=Nh)
  dh=logp.thres[2]-logp.thres[1]
  p.thres=exp(-logp.thres)
  threshs=stats::qnorm(p.thres, lower.tail = F)
  threshs[1]=-9999999999 # exp(-Inf):=0 #TODO: machine minimum
  ndh = length(threshs)
  CLUST=array(NA, dim=c(dim(img), length(threshs)))
  PVC=array(1, dim=c(dim(img), length(threshs)))

  if (verbose) cat("* Performing pTFCE...\n")
  if (verbose) pb <- utils::txtProgressBar(style = 3)
  for (hi in 1:length(threshs))
  {
    if (verbose) utils::setTxtProgressBar(pb, hi/length(threshs))
    h=threshs[hi]
    thr=img
    thr[img>h]=1
    thr[img<=h]=0
    ccc=mmand::components(thr, kernel = mmand::shapeKernel(3, dim = 3, type = "diamond"))
    t=table(ccc)
    sizes=t[ccc]
    sizes=sizes*as.numeric(mask)

    CLUST[,,,hi]=sizes

    for (size in sort(unique(sizes)) )
    {
      if (size==0)
        next;
      PVC[,,,hi][sizes==size]=pvox.clust(V, Rd, size, h, ZestThr=ZestThr)
    }
    # plot if you want
    # orthographic(nifti(CLUST[,,, hi], datatype=16) )
  }
  # calculate pTFCE
  pTFCE=array(apply(PVC, c(1,2,3), function(x){exp( -aggregate_logpvals(-log(x), dh) )}), dim=dim(img))

  # copy nifit header information
  snames = methods::slotNames(img)
  snames = snames[ !snames %in% c(".Data", "dim_") ]
  pTFCE = oro.nifti::nifti(img = pTFCE, dim = dim(pTFCE))
  #BUG: this does not work if input is an array instead of nifti image
  class(pTFCE) = class(img)
  oro.nifti::datatype(pTFCE) = 16 # FLOAT32
  oro.nifti::bitpix(pTFCE) = 32 # FLOAT32
  pTFCE=oro.nifti::zero_trans(pTFCE)
  for (islot in snames) {
    methods::slot(pTFCE, islot) = methods::slot(img, islot)
  }
  # done copying header

  pTFCE[pTFCE==0]=.Machine$double.xmin #underflow
  pTFCE[pTFCE==1]=1-.Machine$double.neg.eps #underflow
  if (verbose) close(pb)
  if (autosmooth)
  {
    number_of_resels=smooth$volume / smooth$resels
    fwer0.05.Z=fwe.p2z(number_of_resels, 0.05)
  }
  else
  {
    if (is.na(resels))
    {
      warning("For GRF-based FWER correction, please specify resels, or use smoothness estimation based on the data, by not specifying Rd and V!")
      number_of_resels=NA
      fwer0.05.Z=NA
    }
    else
    {
      number_of_resels=V / resels
      fwer0.05.Z=fwe.p2z(number_of_resels, 0.05)
    }

  }
  Z=stats::qnorm(pTFCE, lower.tail = F)
  oro.nifti::datatype(Z) = 16 # FLOAT32
  oro.nifti::bitpix(Z) = 32 # FLOAT32
  Z=oro.nifti::zero_trans(Z)
  return(list(p=pTFCE,
              logp=-log(pTFCE),
              Z=Z,
              number_of_resels=number_of_resels,
              fwer0.05.Z=fwer0.05.Z
              )
         )
}

# helper functions

#' Aggregate logpvals by the "equidistant incremental logarithmic probability aggregation".
#'
#' @param logpvals vector of enhnaced -logP values correspoinding tho various thresholds
#' @param d delta -logP (giving the equidistant distribution in the log-space)
#'
#' @return aggregated -logP probability
#' @export
aggregate_logpvals=function(logpvals, d) #
{
  logpvals[is.infinite(logpvals)]=745
  s=sum(logpvals)
  return( 0.5*(sqrt(d*(8*s+d))-d) )
}

#' expected value of cluster size at threshold h in img of size V with RESEL count Rd
#' mainly ported from the source code of FSL (https://fsl.fmrib.ox.ac.uk/fsl/fslwiki)
#'
#' @param h image height, that is, Z score threshold
#' @param V Number of voxels
#' @param Rd Rd (dLh*V)
#'
#' @return Expected value of cluster size
Es=function(h, V, Rd)
{
  h2=h*h
  ret=  ( log(V)+stats::pnorm(h, log.p = T, lower.tail = F) )
  h2=h2[h>=1.1]
  ret[h>=1.1] = ret[h>=1.1] - ( log(Rd)+log(h2-1)-h2/2+-2*log(2*pi) ) # from FSL

  return( exp(ret) )

}

dvox=function(h) # PDF of Z threshold/voxel value
{
  stats::dnorm(h )
}

pvox=function(h) # p-value for voxel value
{
  stats::pnorm(h, lower.tail = F)
}

dclust=function(h, V, Rd, c, ZestThr=1.3, CONST=10^40) # PDF of cluster extent, given h thershold
{
  if (is.na(c))
    return(dvox(h))
  dcl=function(h, V, Rd, c)
  {
    lambda=(Es(h, V, Rd)/gamma(2.5) )^(-2/3)
    dclust=lambda*exp(-lambda*c^(2/3))
    #dclust[dclust==0]=.Machine$double.xmin # underflow happened
    dclust[h<ZestThr]=0
    dclust
  }
  # patch: the normalising constant can be ignored here as the expression will be normalised again later
  # So we spare a costly numarical integration and get much faster!
  # Tests still pass, with a tolearnce
  #dcl(h, V, Rd, c)#/integrate(function(x){dcl(x, V, Rd, c)}, -Inf, Inf)$value

  #bugfix (GitHUb Issue #8)
  # we can multiply to avoid underflow in the integration in dvox.clust
  # it will be normalised anyway
  dcl(h, V, Rd, c)*CONST
}

dvox.clust=function(h, V, Rd, c, ZestThr=1.3) # PDF of Z threshold value given cluster size
{
  if (is.na(c))
    #return(rep(0, length(h)))
    return(dvox(h))
  if (is.nan(dclust(h, V, Rd, c)[1])) # underflow
    return(dvox(h)*dclust(h, V, Rd, c))

  dvox(h)*dclust(h, V, Rd, c, ZestThr)/stats::integrate(function(x){dvox(x)*dclust(x, V, Rd, c, ZestThr)}, -Inf, Inf)$value
}

pvox.clust=function(V, Rd, c, actH, ZestThr=1.3) # p-value for Z threshold value given cluster size
{
  if (actH<=ZestThr)  # ZestThr: GRF theory might not apply at low thresholds
    return(pvox(actH))

  if (is.nan(dvox.clust(actH, V, Rd, c, ZestThr=ZestThr)[1])) # underflow
    return(exp(-745)) #TODO: make machnie independent

  stats::integrate(function(x){dvox.clust(x, V, Rd, c, ZestThr=ZestThr)}, actH, Inf)$value
}

#' Estimate global image smoothness.
#'
#' Ported form the C++ implementation of FSL.
#'
#' For mathematical background, see:
#' https://www.fmrib.ox.ac.uk/datasets/techrep/tr00df1/tr00df1/index.html
#'
#' @param img Z-score image or a 4D residual image, ("nifti" class from
#'   "oro.nifti" package)
#' @param mask image mask ("nifti" class from "oro.nifti" package)
#' @param dof degrees of freedom, obligatory if img is a 4D residual image
#' @param verbose boolean: print progress bar and diagnostic messages if true
#'   (default)
#'
#' @return An object of class "smoothness" is a list containing at least the
#'   following components:
#'   \itemize{
#'   \item \strong{volume}   volume of the mask used for estimating smoothness, in voxels
#'
#'   \item \strong{sigmasq}  sigma squared values in the x, y and z directions
#'
#'   \item \strong{FWHM}     full width at half maximum values of smoothness in the x, y and z
#'   direction (voxels)
#'
#'   \item \strong{dLh}      determininant of Lambda to the half (voxels^-3)
#'
#'   \item \strong{resels}   resel size (voxels per resel) }
#' @export
#'
#' @details The function takes two images (both "nifti" object of the oro.nifti
#'   package): (i) either a Z-score image or a 4D residual image together with
#'   the degrees of freedom, and (ii) a mask image as obligatory inputs. Mask
#'   can be either binary or continous, in the latter case it will be
#'   thresholded at 0.5.
#'
#'   For a Gaussian random field the smoothness is defined as  \deqn{W
#'   =|\Lambda|^{-1/2D} } where D is the dimensionality of the field and
#'   \eqn{\Lambda} the covariance matrix of it's first partial derivatives.
#'
#'   Using Z-score image is less optimal because:
#' \itemize{
#' \item Smoothness estimates need spatial derivatives, which are very noisy
#'   quantities and, for a single 3D map, can be computed just once on each
#'   direction.
#' \item The z-map may contain effects, and these affect smoothness.
#' }
smoothest=function(img, mask, dof=NA, verbose=T)
{
  if (verbose) cat("* Estimating smoothness based on the data...\n")
  if (verbose) pb <- utils::txtProgressBar(style = 3)

  stand = standardise(mask, img);
  mask_volume=stand$count
  mask=stand$mask
  img=stand$R
  N=0

  usez=T
  if (dim(img)[3] <= 1)
  {
    usez = F;
    warning("using 2d image mode, but it is not tested yet")
  }

  # Estimate the smoothness of the normalised residual field
  # see TR00DF1 for mathematical description of the algorithm.
  X = 1
  Y = 2
  Z = 3
  SSminus = c(0, 0, 0)
  S2 = c(0, 0, 0)

  # adjust zstart for 2d mode
  zstart=2
  if (!usez) zstart=1
  for (z in 2:dim(img)[3])
  {
    if (verbose) utils::setTxtProgressBar(pb, z/dim(img)[3])
    for (y in 2:dim(img)[2])
    {
      for (x in 2:dim(img)[1])
      {
        # Sum over N
        if( (mask[x, y, z]>0.5) &&
            (mask[x-1, y, z]>0.5) &&
            (mask[x, y-1, z]>0.5) &&
            ( (!usez) || (mask[x, y, z-1]>0.5) ) )
        {
          N=N+1

          if (!is.na(dim(img)[4])) # using res4D
          {
            for ( t in 1:dim(img)[4])
            {
              # Sum over M
              SSminus[X] =  SSminus[X] + img[x, y, z, t] * img[x-1, y, z, t]
              SSminus[Y] = SSminus[Y] + img[x, y, z, t] * img[x, y-1, z, t]
              if (usez) SSminus[Z] = SSminus[Z] + img[x, y, z, t] * img[x, y, z-1, t]

              S2[X] = S2[X] + 0.5 * (img[x, y, z, t]*img[x, y, z, t] + img[x-1, y, z, t]*img[x-1, y, z, t])
              S2[Y] = S2[Y] + 0.5 * (img[x, y, z, t]*img[x, y, z, t] + img[x, y-1, z, t]*img[x, y-1, z, t])
              if (usez) S2[Z] = S2[Z] + 0.5 * (img[x, y, z, t]*img[x, y, z, t] + img[x, y, z-1, t]*img[x, y, z-1, t])
            }
          }
          else # using Z-score map
          {
            SSminus[X] =  SSminus[X] + img[x, y, z] * img[x-1, y, z]
            SSminus[Y] = SSminus[Y] + img[x, y, z] * img[x, y-1, z]
            if (usez) SSminus[Z] = SSminus[Z] + img[x, y, z] * img[x, y, z-1]

            S2[X] = S2[X] + 0.5 * (img[x, y, z]*img[x, y, z] + img[x-1, y, z]*img[x-1, y, z])
            S2[Y] = S2[Y] + 0.5 * (img[x, y, z]*img[x, y, z] + img[x, y-1, z]*img[x, y-1, z])
            if (usez) S2[Z] = S2[Z] + 0.5 * (img[x, y, z]*img[x, y, z] + img[x, y, z-1]*img[x, y, z-1])

          }
        } # endif mask
      } #endz
    } #endy
  } #endx
  norm = 1.0/N
  v = dof # v - degrees of freedom (nu)
  if (!is.na(dim(img)[4])) # using res4D
  {
    print(paste("Non-edge voxels = ", N))
    print(paste("(v - 2)/(v - 1) = ", (v - 2)/(v - 1)))

    norm = (v - 2) / ((v - 1) * N * dim(img)[4]);
  }
  #print(paste("SSminus[X]", SSminus[X], "SSminus[Y]", SSminus[Y],"SSminus[Z]", SSminus[Z],"S2[X]", S2[X],"S2[Y]", S2[Y],"S2[Z]", S2[Z]))

  # for extreme smoothness
  if (SSminus[X]>=0.99999999*S2[X])
  {
    SSminus[X]=0.99999*S2[X]
    warning("Extreme smoothness detected in X - possibly biased global estimate.")
  }
  if (SSminus[Y]>=0.99999999*S2[Y])
  {
    SSminus[Y]=0.99999*S2[Y]
    warning("Extreme smoothness detected in Y - possibly biased global estimate.")
  }
  if (usez)
  {
    if (SSminus[Z]>=0.99999999*S2[Z])
    {
      SSminus[Z]=0.99999*S2[Z]
      warning("Extreme smoothness detected in Z - possibly biased global estimate.")
    }
  }

  # Convert to sigma squared
  sigmasq=rep(NA,3);

  sigmasq[X] = -1.0 / (4 * log(abs(SSminus[X]/S2[X])))
  sigmasq[Y] = -1.0 / (4 * log(abs(SSminus[Y]/S2[Y])))
  if (usez)
  {
    sigmasq[Z] = -1.0 / (4 * log(abs(SSminus[Z]/S2[Z])))
  }
  else
  {
    sigmasq[Z]=0
  }
  names(sigmasq)=c("x", "y", "z")

  # the following is determininant of Lambda to the half
  # i.e. dLh = | Lambda |^(1/2)
  # Furthermore, W_i = 1/(2.lambda_i) = sigma_i^2 =>
  #   det(Lambda) = det( lambda_i ) = det ( (2 W_i)^-1 ) = (2^D det(W))^-1
  #   where D = number of dimensions (2 or 3)
  if (usez)
  {
    dLh=((sigmasq[X]*sigmasq[Y]*sigmasq[Z])^-0.5)*(8^-0.5)
  }
  else
  {
    dLh=((sigmasq[X]*sigmasq[Y])^-0.5)*(4^-0.5)
  }
  #correcting for temporal DOF!!!!!
  if(!is.na(dim(img)[4]))
    dLh = dLh * interpolate(v);

  # Convert to full width half maximum
  FWHM=rep(NA,3)
  FWHM[X] = sqrt(8 * log(2) * sigmasq[X])
  FWHM[Y] = sqrt(8 * log(2) * sigmasq[Y])
  if (usez)
  {
    FWHM[Z] = sqrt(8 * log(2) * sigmasq[Z])
  }
  else
  {
    FWHM[Z]=0
  }
  names(FWHM)=c("x", "y", "z")

  resels = FWHM[X] * FWHM[Y]
  if (usez)
    resels = resels * FWHM[Z]

  if (verbose) close(pb)

  return(list(volume=mask_volume,
              sigmasq=sigmasq,
              FWHM=FWHM,
              dLh=dLh,
              resels=resels))
}

standardise=function(mask, R)
{
  M=dim(R)[4]
  if( !is.na(M) )
  {
    # For each voxel
    #    standardise data in 4th direction
    R=aperm(apply(R, c(1,2,3), scale), c(2,3,4,1))
    R[is.na(R)]=0
    std=apply(R, c(1,2,3), stats::sd)
    mask[std<=0]=0 #TODO_ready: updtae mask if it differs from the actual data

  }#endif 4d
  mask[is.na(mask)]=0

  count=sum(mask[mask>0.5])

  return(list(count=count, mask=mask, R=R))
}

interpolate=function(v)
{
  lut=rep(NA,500)
    lut[5]   = 1.5423138; lut[6]   = 1.3757105; lut[7]   = 1.2842680;
    lut[8]   = 1.2272151; lut[9]   = 1.1885232; lut[10]  = 1.1606988;
    lut[11]  = 1.1398000; lut[12]  = 1.1235677; lut[13]  = 1.1106196;
    lut[14]  = 1.1000651; lut[15]  = 1.0913060; lut[16]  = 1.0839261;
    lut[17]  = 1.0776276; lut[18]  = 1.0721920; lut[19]  = 1.0674553;
    lut[20]  = 1.0632924; lut[25]  = 1.0483053; lut[30]  = 1.0390117;
    lut[40]  = 1.0281339; lut[50]  = 1.0219834; lut[60]  = 1.0180339;
    lut[70]  = 1.0152850; lut[80]  = 1.0132621; lut[90]  = 1.0117115;
    lut[100] = 1.0104851; lut[150] = 1.0068808; lut[200] = 1.0051200;
    lut[300] = 1.0033865; lut[500] = 1.0020191;

  if (v<6) return(1.1) # ?? no idea - steve ??

  if (v>500)
  {
    retval=1.0321/v + 1
  }
  else
  {
    lut.low=lut[1:floor(v)]
    lut.high=lut[ceiling(v):length(lut)]

    j.first=which(lut==min(lut.low, na.rm = T))
    j.second=lut[j.first]

    i.first=which(lut==max(lut.high, na.rm = T))
    i.second=lut[i.first]

    retval = (j.second - i.second)/(j.first - i.first)*(v - i.first) + j.second
  }
  return(retval^0.5)

}

#' Convert Z-score value to FWER corrected p-value
#'
#' https://github.com/spisakt/pTFCE
#'
#' @param resel_count resel count
#' @param Z z-score value
#'
#' @details The Z-score value is converted to to p-value, corrected for multiple comparisons by controlling for famili-wise error rate
#' The parameter resel_count is the number of resels (resolution elements) in the image, and can be obtained e.g by smoothest() (see examples).
#'
#' @return FWER-corrected p-value
#'
#' @export
#'
#' @examples
#' \dontrun{
#' s=smoothest(zmap, mask)
#' fwe.z2p(resel_count=s$volume/s$resels, Z=2.3)
#'
#' pTFCE=ptfe(zmap, mask)
#' fwe.z2p(pTFCE$number_of_resels, Z=3.1)
#' }
fwe.z2p=function(resel_count, Z)
{
  # based on FSL
  #the probability of a family wise error is approximately equiv- alent to the expected Euler Characteristic
  if (Z<2)
    p=1 # Below z of 2 E(EC) becomes non-monotonic
  else
    p = resel_count * 0.11694 * exp(-0.5*Z*Z)*(Z*Z-1)  #/* 0.11694 = (4ln2)^1.5 / (2pi)^2 */
  return(min(p,1.0))
}

#' Get Z-score threshold for an FWER corrected p-value
#'
#' https://github.com/spisakt/pTFCE
#'
#' @param resel_count resel count
#' @param FWEP FWER corrected p-value
#'
#' @details The p-value, corrected for multiple comparisons by controlling for family-wise error rate, is converted to a Z-score threshold.
#' The parameter resel_count is the number of resels (resolution elements) in the image, and can be obtained e.g by smoothest() (see examples).
#'
#' @return Z-score threshold
#'
#' @export
#'
#' @examples
#' \dontrun{
#' s=smoothest(zmap, mask)
#' fwe.p2z(resel_count=s$volume/s$resels, FWEP=0.05)
#'
#' pTFCE=ptfe(zmap, mask)
#' fwe.p2z(pTFCE$number_of_resels, FWEP=0.05)
#' }
fwe.p2z=function(resel_count, FWEP=0.05)
{
  # based on FSL ptoz implementation
  p=FWEP/(resel_count*0.11694) #/* (4ln2)^1.5 / (2pi)^2 */

  #if (p<MINP) p=MINP;

  if (p>0.5)
    return(0)
  else
  {
      l=2
      u=100
      z=0
      while (u-l>0.001)
      {
        z=(u+l)/2
        pp=exp(-0.5*z*z)*(z*z-1)
        if (pp<p)
          u=z
        else
          l=z
      }

  }
  return(z)
}


# Master Thesis Project - Extreme Value Theory
# Plotting a sample of the Brownian Motions
# Killian Martin--Horgassan
# 23-04-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("./generalBM.r")

# Let the user enter the time horizon of the brownian motion
cat("Time increment ?")
h <- as.numeric(readline("h :\n"))

cat("Mean ?")
mu <- as.numeric(readline("mu :\n"))

cat("Standard deviation ?")
sigma <- as.numeric(readline("sigma :\n"))

# Generating the Brownian Motion
BM_vect <- generalBM(mu,sigma,h)

# Plot the Brownian Motion
quartz()

plot(BM_vect, type ='l')
abline(h = 0, col = "red")

# Some Data on the sum of the B(ti)
cat("Mean of sum :\n")
print(mean(BM_vect))
cat("\nVariance of sum :\n")
print(var(BM_vect))

# Now checking the increments respect a few properties of BM
cat("\nTime horizon T =\n")
print(ceiling(1/h))
cat("\nSelect two times a and b, 0 < a < b <=T\n")
a <- as.numeric(readline("Your a :\n"))
b <- as.numeric(readline("Your b :\n"))
cat("\na :\n")
print(a)
cat("\nb\n")
print(b)

Nbtries <- 1000
incr <- rep(0,Nbtries)

for (i in 1:Nbtries) {

	# Loop to gather data for a histogram
	# recovering B(a) and B(b)
	vect <- generalBM(mu,sigma,1/b)
	incr[i] <- vect[b] - vect[a]

}

hist(incr, main = "Density plot", freq = FALSE, col = "lightgreen")
curve(dnorm(x, mean = mean(incr), sd = sd(incr)), add = TRUE, col = "darkblue", lwd = 4)
curve(dnorm(x, mean = mu, sd = sigma*sqrt(b-a)), add = TRUE, col = "red", lwd = 4)

print(mean(incr))
print(sd(incr))


# system of ODEs

d_rho_pm <- function(rho, parms, z = 4) {
  with(parms,
       d * (rho[4] - rho[1] - rho[2]) +
         (rho[5] - rho[3] - rho[1]) *
         (delta*rho[4] + (z-1)/z * (1 - delta) *
            (rho[4] - rho[1] - rho[2])/(1 - rho[4] - rho[5]) ) *
         (b - c*rho[4]) -
         rho[1]*( r + f/z + (z-1)/z * f * rho[1]/rho[5] + m)
  )
}
d_rho_pp <- function(rho, parms, z = 4) {
  with(parms,
       2 * (rho[4] - rho[1] - rho[2]) *
         (delta*rho[4] + (1-delta)/z +(z-1)/z * (1 - delta) *
            (rho[4] - rho[1] - rho[2])/(1 - rho[4] - rho[5]) ) *
         (b - c*rho[4]) - 2*rho[2]*m
  )
}
d_rho_mm <- function(rho, parms, z = 4) {
  with(parms,
       2 * (rho[5] - rho[3] - rho[1]) -
         2*rho[3]*(r+(z-1)/z*f*rho[1]/rho[5])
  )
}
d_rho_p <- function(rho, parms, z = 4) {
  with(parms,
       (delta*rho[4] + (1 - delta) *
          (rho[4] - rho[1] - rho[2])/(1 - rho[4] - rho[5]) ) *
         (b-c*rho[4])*(1-rho[4]-rho[5])-m*rho[4]
  )
}

d_rho_m <- function(rho, parms, z = 4) {
  with(parms,
       d*(1-rho[4]-rho[5])-(r+f*rho[1]/rho[5])*rho[5]
  )
}

odesys <- function (t, rho, parms = model_parms) {
  list(c(
    d_rho_pm(rho, parms),
    d_rho_pp(rho, parms),
    d_rho_mm(rho, parms),
    d_rho_p(rho, parms),
    d_rho_m(rho, parms)
  ))
}


\name{test_linear_PA}
\alias{test_linear_PA}
\title{
 Fitting various distributions to a degree vector
}
\description{
This function implements the method in Handcock and Jones (2004) to fit various distributions to a degree vector. The implemented distributions are Yule, Waring, Poisson, geometric and negative binomial. The Yule and Waring distributions correspond to a preferential attachment situation. In particular, the two distributions correspond to the case of \eqn{A_k = k} for \eqn{k \ge 1} and \eqn{\eta_i = 1} for all \eqn{i} (note that, the number of new edges and new nodes at each time-step are implicitly assumed to be \eqn{1}).

Thus, if the best fitted distribution, which is chosen by either the Akaike Information Criterion (AIC) or the Bayesian Information Criterion (BIC), is NOT Yule or Waring, then the case of \eqn{A_k = k} for \eqn{k \ge 1} and  \eqn{\eta_i = 1} for all \eqn{i}  is NOT consistent with the observed degree vector.

The method allows the low-tail probabilities to NOT follow the parametric distribution, i.e., \eqn{P(K = k) = \pi_k} for all \eqn{k \le k_min} and \eqn{P(K = k) = f(k,\theta)} for all \eqn{k > k_min}. Here \eqn{k_min} is the degree threshold above which the parametric distribution holds, \eqn{\pi_k} are probabilities of the low-tail, \eqn{f(.,\theta)} is the parametric distribution with parameter vector \eqn{\theta}.

For fixed \eqn{k_min} and \eqn{f}, \eqn{\pi_k} and \eqn{\theta} can be estimated by Maximum Likelihood Estimation. We can choose the best \eqn{k_min} for each \eqn{f} by comparing the AIC (or BIC). More details can be founded in Handcock and Jones (2004).
}
\usage{
 test_linear_PA(degree_vector)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{degree_vector}{
    a degree vector
  }
}
\value{
  Outputs a \code{Linear_PA_test_result} object which contains the fitting of five distributions to the degree vector: Yule (\code{yule}), Waring (\code{waring}), Poisson (\code{pois}), geometric (\code{geom}) and negative binomial (\code{nb}). In particular, for each distribution, the AIC and BIC are calcualted for each \eqn{k_min}.
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\references{
  1. Handcock MS, Jones JH (2004). “Likelihood-based inference for stochastic models of sexual network formation.” Theoretical Population Biology, 65(4), 413 – 422. ISSN 0040-5809. \url{https://doi.org/10.1016/j.tpb.2003.09.006}. Demography in the 21st Century, \url{http://www.sciencedirect.com/science/article/pii/S0040580904000310}.
}
\examples{
\dontrun{
  library("PAFit")
  set.seed(1)
  net   <- generate_BA(n = 1000)
  stats <- get_statistics(net, only_PA = TRUE)
  u     <- test_linear_PA(stats$final_deg)
  print(u)
}
}

\concept{linear preferential attachment}
\concept{fitting degree distributions}


#==========================================================================================================================
#==========================================================================================================================

# 4. faza: Analiza podatkov

#==========================================================================================================================
#==========================================================================================================================

star_skup_60_64 <- starostne_skupine %>%  filter(starostne_skupine == "60-64 let")

g63 <- ggplot(star_skup_60_64) +
  aes(x = leto, y = stevilo) +
  geom_point() +
  geom_smooth(method = "gam", se = FALSE)

mgam1 <- gam(stevilo ~ leto ,
             data = star_skup_60_64)
leta1 <- data.frame(leto = seq(2021,2026))
napoved <- leta1 %>% mutate(stevilo = predict(mgam1, .))

tabela.napoved <- bind_rows(star_skup_60_64, napoved) %>% select(-starost)
tabela.napoved1 <- tabela.napoved[c(17:22),]

graf_napoved_60_64 <- ggplot(tabela.napoved,
                          aes(x = leto, y = stevilo)) +
  geom_point() +
  scale_x_continuous(name = "leto", breaks = seq(2005,2026,1)) +
  ylab("število delovno aktivnih") +
  ggtitle("Napoved števila delovno aktivnih v starostni skupini od 60 do 64 do leta 2026") +
  geom_smooth(method = 'gam', formula = y ~ x, se = FALSE, color="darkgoldenrod1") +
  theme(axis.text.x=element_text(angle=90, vjust=0.5, hjust=1))

novi_podatki <- data.frame(leto = seq(2021, 2026))
napoved <- novi_podatki %>% mutate(stevilo=predict(mgam1, .))

graf_napoved_60_64 <- graf_napoved_60_64 +
  geom_point(data=tabela.napoved1,
             aes(x=leto, y=stevilo),
             color="red")

#==========================================================================================================================

star_skup_25_29 <- starostne_skupine %>%  filter(starostne_skupine == "25-29 let")

g638 <- ggplot(star_skup_25_29) +
  aes(x = leto, y = stevilo) +
  geom_point() +
  geom_smooth(method = "gam", se = FALSE)

mgam2 <- gam(stevilo ~ leto ,
             data = star_skup_25_29)
napoved <- leta1 %>% mutate(stevilo = predict(mgam2, .))

tabela.napoved2 <- bind_rows(star_skup_25_29, napoved) %>% select(-starost)
tabela.napoved3 <- tabela.napoved2[c(17:22),]

graf_napoved_25_29 <- ggplot(tabela.napoved2) +
  aes(x = leto, y = stevilo) +
  geom_point() +
  scale_x_continuous(name = "leto", breaks = seq(2005,2026,1)) +
  ylab("število delovno aktivnih") +
  ggtitle("Napoved števila delovno aktivnih v starostni skupini od 25 do 29 let do leta 2026") +
  geom_smooth(method = 'gam', formula = y ~ x, se = FALSE, color="aquamarine2") +
  theme(axis.text.x=element_text(angle=90, vjust=0.5, hjust=1)) +
  expand_limits(y=0)

novi_podatki2 <- data.frame(leto = seq(2021, 2026))
napoved2 <- novi_podatki2 %>% mutate(stevilo=predict(mgam2, .))

graf_napoved_25_29 <- graf_napoved_25_29 +
  geom_point(data=tabela.napoved3,
             aes(x=leto, y=stevilo),
             color="red")


designBasedCont = function(gamma, outcome_vec, pcf_cat_vec, instid_vec){
	#' Compute Design Based Draper-Gittoes Z-Scores
	#'
	#'	\code{designBased} implements design based approach and
	#' computes O, E, and z vectors following Draper-Gittoes (2004)
	#'
	#' @param gamma Parameter in [0,1] controling pooling.
	#' Gamma = 1 is complete global pooling, gamma = 0 is complete local pooling.
	#' @param outcome_vec Vector with elements in {0,1} denoting the binary outcome.
	#' @param pcf_cat_vec Vector with unique values for each PCF category.
	#' @param instid_vec Vector with unique values for each institution.

	#Some of the inputs need to be factors
	pcf_cat_vec = as.factor(pcf_cat_vec)
	instid_vec = as.factor(instid_vec)
	instid_vec_i = as.integer(instid_vec)
	pcf_cat_vec_i = as.integer(pcf_cat_vec)

	#Summarize
	instid_unique = levels(instid_vec)
	instid_unique_i = as.integer(instid_unique)
	n = length(outcome_vec)
	n_u = length(levels(instid_vec))
	unique_cat = levels(pcf_cat_vec)
	n_cat = length(unique_cat)
	p_global = mean(outcome_vec)

	#Compute Table 2 in Draper-Gittoes
	y_mat = n_mat = s_mat = matrix(0, nrow =n_u, ncol = n_cat)

	for (i in 1:n){
    inst = as.integer(instid_vec[i])
    categ = as.integer(pcf_cat_vec[i])
    n_mat[inst,categ] = n_mat[inst,categ] + 1
    y_mat[inst, categ] = y_mat[inst, categ] + outcome_vec[i]
	}
	ybar_mat = y_mat / n_mat
	ybar_mat[n_mat == 0] = 0

	#Create variance mat.
	mean_mat2 = matrix(0, nrow = n_u, ncol = n_cat)
	for (i in 1:n_cat){
		for (j in 1:n_u){
			outcomes = outcome_vec[pcf_cat_vec_i == i & instid_vec_i == j]
			if (length(outcomes) > 0){
				mean_mat2[j,i] = mean(outcomes)
			}
			if (length(outcomes) > 1){
				s_mat[j,i] = var(outcomes)
				}
		}
	}

	s_global = var(outcome_vec)
	s_mat[n_mat == 1] = s_global

	#Compute marginals
	pcf_ybar_vec = apply(y_mat, 2, sum) / apply(n_mat, 2, sum)
	n_u_vec = apply(n_mat, 1, sum)
	n_cat_vec = apply(n_mat, 2, sum)

	#Equation (2) in Draper-Gittoes (2004)
	O = apply(y_mat, 1, sum) / apply(n_mat, 1, sum)
	#Equation (3) in D-G
	E = apply(t(t(n_mat) * pcf_ybar_vec), 1, sum) / n_u_vec
	#Equation (4) in D-G
	D = O - E

	#Variance
	lambdaFun = function(i,k,j){
		#Equation (7) in D-G. #Unchanged for continious
		if (i == k){
			return(n_mat[i,j]/n_u_vec[i] * (1 - (n_mat[i,j]/n_cat_vec[j])))
		} else{
			return( -1 * (n_mat[i,j] * n_mat[k,j]) / (n_u_vec[i] * n_cat_vec[j]) )
		}
	}

	vFun = function(k,j, gamma = 0.5){
		#Equation (11) in D-G #Changed for continous
		n = n_mat[k,j]
		if (n > 0){
			s_local = s_mat[k,j]
			s_use = gamma * s_global + (1-gamma) * s_local
			return(s_use/n)
		} else {
			return(0)
		}
	}
	computeVi = function(i, gamma){
		#Equation (8) in D-G #Unchanged for cnontnious
		v = 0
		for (k in 1:n_u){
			for (j in 1:n_cat){
				v = v + lambdaFun(i,k,j)^2 * vFun(k, j, gamma)
			}
		}
		return(v)
	}
	# #Now compute w/ lapply
	V = sapply(1:n_u, computeVi, gamma)
	SE = sqrt(V)

	out_df = data.frame(
			inst = as.numeric(as.character(instid_unique)),
			effect = O-E,
			O = O,
			E = E,
			D = D,
			SE = SE,
			Z = (O - E) / SE,
			n = n_u_vec
	)
	return( out_df[order(out_df$inst), ])
}


# 4. faza: Napredna analiza podatkov

#NAPOVED RASTI BRUTO MINIMALNE PLAČE V SLOVENIJI

slo_napoved <- min_place %>% filter(Drzava == 'Slovenia')
prileganje <- lm(data = slo_napoved, Placa ~ Leto)
g <- data.frame(Leto=seq(2016, 2020, 1))
napoved <- mutate(g, Placa=predict(prileganje, g))

graf_regresija <- ggplot(slo_napoved, aes(x=Leto, y=Placa)) +
  geom_point() + geom_smooth(method=lm, fullrange = TRUE, color = 'blue') +
  geom_point(data=napoved, aes(x=Leto, y=Placa), color='red', size=2) +
  ggtitle('Napoved nadaljne rasti minimalne bruto plače v Sloveniji') +
  ylab('Plača')

placa_v_2018 <- filter(napoved, Leto == 2018)
placa_v_2019 <- filter(napoved, Leto == 2019)
#Realna min. plača v 2018:  842,79€
#Realna min. plača v 2019: 886,63€


# Algorithms
# Source this file to load simulation algorithms for Ising model.
# Includes:
#  - Sumit's algorithm (AG algorithm for Ising model)
#  - Metropolis-Hastings
#  - Swendsen-Wang
#  - Wolff's algorithm
#  - Exact force
#
# Remark: this file uses functions in tools.r
# Source this file before running tests.

source("tools.r")

#####################################################################
## Sumit's algorithm (more formally, Auxiliary Gaussian algorithm
# for Ising model.
# Note: this algorithm is also proposed in Martens & Sutskever (2010))

sumit_sampler <- function (A, beta, B = 0, init, n_iter = 1000,
                           alpha_modif = 1e-7,
                           retain_alpha = FALSE,
                           perturb = TRUE) {
  # Simulate states from the Ising model, using an auxiliary
  # gaussian variable, q, for the Ising model.
  #
  # There are two options for setting alpha:
  # (i) alpha is the smallest absolute eigenvalue, plus
  # an 'infitinesimal' modifier. This modifier needs to
  # be large enough to be significant within floating point
  # precision. A default that seems to work is 1E-15.
  # The user can specify the modifier with alpha_modif.
  # (ii) the user specifies alpha directly with alpha_modif
  # argument, after setting retain_alpha = TRUE.
  #
  # Note: this algorithm requires x in {-1, 1}

  if (retain_alpha) { alpha = alpha_modif } else {
    # alpha = min(abs(eigen(A, symmetric = TRUE,
    #                       only.values = TRUE)$values))
    # CHECK ME!!!
    # alpha = min(abs(eigen(A, symmetric = TRUE,
    #                       only.values = TRUE)$values))
    alpha = abs(min(eigen(A, symmetric = TRUE,
                          only.values = TRUE)$values))
    alpha = alpha + alpha_modif
  }

  n_particles = nrow(A)
  C = beta * (A + alpha * diag(n_particles))
  # lower triangular Cholesky decomposition of Sigma
  L = t(chol(solve(C)))
  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x

  for (i in (1:n_iter - 1)) {
    # update q
    q = mvrnorm_cholesky(n = 1, mu = x, L = L)

    # update x
    q_C = q %*% C
    u = runif(n_particles, 0, 1)
    for (j in 1:n_particles) {
      p = 1 / (1 + exp(-2 * (q_C[j] + B)))
      if (p > u[j]) { x[j] = 1 } else { x[j] = -1 }
    }

    # Random perturbator.
    if (perturb) {
      prob_flip = exp(- 2 * B * sum(x))
      u = runif(1, 0, 1)
      perturbator = - 2 * (u <= prob_flip) + 1
      x = perturbator * x
      X[i + 1, ] = x
    } else {
      X[i + 1, ] = x
    }
  }
  X
}

##########################################################################
## Specialization of the lowrank AG Potts sampler for the Ising
# model case.

ag_ising_lowrank <- function (A, beta, init, n_iter, epsilon = 1e-12) {
  n_particles = nrow(A)
  alpha = abs(min(eigen(A, symmetric = TRUE,
                        only.values = TRUE)$values))
  C = beta * (A + alpha * diag(n_particles))
  spectral_decomposition = eigen(C, symmetric = TRUE)

  n_rank = length(
    spectral_decomposition$values[spectral_decomposition$values > epsilon])
  eigen_values_sqrt = sqrt(spectral_decomposition$values[1:n_rank])

  scaled_eigenvectors <- matrix(NA, nrow = n_particles, ncol = n_rank)
  for (i in 1:n_rank) {
    scaled_eigenvectors[, i] = spectral_decomposition$values[i] *
      spectral_decomposition$vectors[, i]
  }

  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x

  q = rep(NA, n_rank)

  for (i in 2:n_iter) {
    mu_q = t(spectral_decomposition$vectors[, 1:n_rank]) %*% x
    q = rnorm(n_rank) / eigen_values_sqrt + mu_q

    P = scaled_eigenvectors %*% q

    u = runif(n_particles, 0, 1)
    for (j in 1:n_particles) {
      # p = 1 / (1 + exp(-2 * scaled_eigenvectors[j, ] %*% q))
      p = 1 / (1 + exp(-2 * P[j]))
      if (p > u[j]) { x[j] = 1 } else { x[j] = -1 }
    }
    X[i, ] = x
  }

  X
}

#####################################################################
## Metropolis-Hastings

mh_sampler <- function (A, beta, B = 0,
                        init, n_iter, perturb = FALSE) {
  # CHECK ME - the Markov chain samples the same point when the
  # Metropolis proposal gets rejected??
  n_particles = nrow(A)
  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x

  kernel_x = ising_kernel(beta, A, x, B)

  for (i in 1:n_iter) {
    # randomly generate a new state.
    # x_new = sample(c(-1, 1), n_particles, replace = TRUE)

    # randomly flip one of the spins
    x_new = x
    index <- sample(length(x), 1)
    x_new[index] = - x[index]

    kernel_new = ising_kernel(beta, A, x_new, B)
    a = kernel_new / kernel_x

    # a = ising_kernel(beta, A, x_new, B) / ising_kernel(beta, A, x, B)
    u = runif(1, 0, 1)
    if (u < a) {
      x = x_new
      kernel_x = kernel_new
    }

    if (perturb) {
      prob_flip = exp(- 2 * B * sum(x))
      u = runif(1, 0, 1)
      perturbator = - 2 * (u < prob_flip) + 1
      x = perturbator * x
      kernel_x = exp(log(kernel_x) - 2 * B * sum(x))
    } else {
      x = x
    }

    X[i, ] = x
  }
  X
}

#####################################################################
## Heat bath -- for each iteration, attempt to update each node.

hb_sampler <- function(A, beta, B = 0, init, n_iter,
                       sub_sample = nrow(A),
                       is_potts = FALSE, n_states = 2) {
  n_particles = nrow(A)
  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x

  if (!is_potts) {
    kernel_x = ising_kernel(beta, A, x, B, log = T)
  } else {
    kernel_x = potts_log_kernel(beta = beta, A = A, x = x, B = B)
  }

  for (i in 1:n_iter) {
    # randomly sample which particles get updated
    update_particles = sample(1:n_particles, sub_sample, replace = FALSE)

    if (!is_potts) {  # Ising model with x in {-1, 1}
      for (j in update_particles) {
        x_new = x
        x_new[j] = - x_new[j]
        kernel_new = ising_kernel(beta, A, x_new, B, log = T)
        a = 1 / (1 + exp(kernel_x - kernel_new))
        u = runif(1, 0, 1)
        if (u < a) {
          x = x_new
          kernel_x = kernel_new
        }
      }
    } else {  # Potts model with x in {1, 2, ..., n_states}
      for (j in update_particles) {
        x_new = x
        other_states <- (1:n_states)[-x[j]]
        x_new[j] = other_states[sample(n_states - 1, 1)]
        kernel_new = potts_log_kernel(beta = beta, A = A, x = x_new,
                                      n_states = n_states)
        a = 1 / (1 + exp(kernel_x - kernel_new))
        u = runif(1, 0, 1)
        if (u < a) {
          x = x_new
          kernel_x = kernel_new
        }
      }
    }
    X[i, ] = x
  }
  X
}

#####################################################################
## Swendsen-Wang

sw_sampler <- function (A, beta, B = 0, init, n_iter, wolff = FALSE,
                        is_potts = FALSE, n_states = 2) {
  # Simulates samples from an ising model, using the
  # Swendsen-Wang algorithm. This algorithm introduces
  # an auxiliary random cluster.
  # The algorithm is written for a complete graph, meaning
  # every particle can be connected to any other particle,
  # when constructing the random cluster (i.e. the algorithm is
  # agnostic to whether we're sampling on a grid or not).
  #
  # If Wolff = TRUE, use Wolff's algorithm instead of SW.
  # That is, for each iteration, construct only one cluster,
  # started at a random point.
  #
  # The space of x is {-1, 1}, unless is_potts is TRUE,
  # in which case the space is {1, 2, ..., n_states}. Note
  # the Adjacency matrix needs to be adjusted to reduce to the
  # Ising model case.
  #
  # FIX ME - use a lower triangular matrix instead of a full
  # matrix for the edges. Could be done in C++ (with Eigen).
  n_particles = nrow(A)
  n_edges = n_particles * (n_particles - 1) / 2
  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x
  edges = matrix(NA, nrow = n_particles, ncol = n_particles)

  # Remark: p[i, j] = 0 if A[i, j] = 0.
  p = 1 - exp(-2 * beta * A)

  if (is_potts) p_states = 1 / n_states  # Assuming B = 0

  for (i in 1:(n_iter - 1)) {
    # Compute auxiliary random clusters.
    # j and k respectively index rows and columns in the
    # edge matrix.
    for (j in 2:n_particles) {
      for (k in 1:(j - 1)) {
        if (x[j] != x[k] | A[j, k] == 0) { edges[j, k] = 0
        } else {
          u = runif(1, 0, 1)
          if (u < p[j, k]) { edges[j, k] = 1 } else { edges[j, k] = 0 }
        }
      }
    }

    # Identify clusters and assign a spin.
    free_nodes = 1:n_particles
    j = 1
    if (wolff == T) wolff_node = sample(1:n_particles, 1)
    while (length(free_nodes) != 0) {
      if (wolff == T) j = wolff_node

      # Can only start a new cluster with a free node.
      cluster = c(j)
      cluster_grows = TRUE
      free_nodes = free_nodes[-match(j, free_nodes)]

      while (cluster_grows) {
        cluster_grows = FALSE
        potential_connection = free_nodes

        # Only expand the cluster if there are potential connections.
        if (length(potential_connection) != 0) {
          for (k in potential_connection) {
            if (edges[max(k, j), min(k, j)] == 1) {
              cluster = c(cluster, k)
              free_nodes = free_nodes[-match(k, free_nodes)]
            }
          }
        }
        if (length(cluster) > match(j, cluster)) {
          cluster_grows = T
          j = cluster[match(j, cluster) + 1]
        }
      }

      u = runif(1, 0, 1)

      if (!is_potts) {  # Ising model with x in {-1, 1}
        p_flip = 1 / (1 + exp(- 2 * length(cluster) * B))
        if (u < p_flip) { x[cluster] = 1 } else { x[cluster] = -1 }
        # print(paste0("cluster: ", cluster))  # use for tests
      } else {  # Potts models with x in {1, 2, ..., n_states}
        p_current = p_states
        state = 1
        while (u > p_current) {
          state = state + 1
          p_current = p_current + p_states
        }
        x[cluster] = state
      }

      if (length(free_nodes) != 0) j = min(free_nodes)
      if (wolff == T) break
    }

    X[i + 1, ] = x
  }
  X
}

wolff_sampler <- function (A, beta, B = 0, init, n_iter,
                           is_potts = FALSE, n_states = 2) {
  # Wolff algorithm. This is a variation of S-W that only
  # pertubs one cluster per iteration (and as a consequence,
  # it is easier to code).

  n_particles = nrow(A)
  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x

  # Remark: p[i, j] = 0 if A[i, j] = 0.
  p = 1 - exp(-2 * beta * A)

  if (is_potts) p_states = 1 / n_states  # Assuming B = 0

  for (i in 1:(n_iter - 1)) {
    source_node = sample(1:n_particles, 1)
    free_nodes = (1:n_particles)[-source_node]
    cluster = c(source_node)
    j = source_node
    cluster_grows = T

    while (cluster_grows) {
      cluster_grows = F
      for (k in free_nodes) {
        # compute whether there is an edge or not
        u = runif(1, 0, 1)
        edge = (x[j] == x[k]) & (u < p[j, k])
        if (edge) {
          # cluster_grows = T
          cluster = c(cluster, k)
          free_nodes = free_nodes[-match(k, free_nodes)]
        }
      }
      if (length(cluster) > match(j, cluster)) {
        cluster_grows = T
        j = cluster[match(j, cluster) + 1]
      }
      # if (cluster_grows) j = cluster[match(j, cluster) + 1]
    }
    u = runif(1, 0, 1)
    # p_flip = 1 / (1 + exp(- 2 * length(cluster) * B))
    if (!is_potts) {  # Ising model with x in {-1, 1}
      p_flip = exp(- 2 * B * sum(x[cluster]))
      if (u < p_flip) { x[cluster] = -x[cluster]}
    } else {  # Potts models with x in {1, 2, ..., n_states}
      p_current = p_states
      state = 1
      while (u > p_current) {
        state = state + 1
        p_current = p_current + p_states
      }
      x[cluster] = state
    }

    X[i + 1, ] = x
  }
  X
}

###############################################################################
## Potts sampler
potts_sampler <- function(A, theta, init, n_sample) {
  # Uses the R package Potts sampler by (Okabayashi, Johnson and Geyer, 2011)
  # Assume we have a squared grid.
  # Convert from {-1, 1} to {2, 1} to respect Potts convention.
  # NOTE -- we may be waisting time doing a lot of copying back
  # and forth, so don't use this measure algorithm run time.
  #
  # theta is canonical parameter, equals 2 * beta.
  ncolor <- as.integer(2)
  n_particles <- nrow(A)
  init_color <- init
  init_color[init_color == -1] <- 2
  x_init <- packPotts(matrix(init_color,
                             nrow = sqrt(n_particles),
                             ncol = sqrt(n_particles)),
                      ncolor = 2)

  samples <- matrix(NA, n_sample, n_particles)

  # set canonical parameter. No B-field, so "color parameters"
  # need to be equal.
  parameter <- c(rep(0, 2), theta)

  for (i in 1:n_sample) {
    if (i %% 100 == 0) print(paste0("iteration: ", i, " / ", n_sample))
    if (i == 1) out <- x_init
    out <- potts(out, parameter, nbatch = 1,
                 boundary = "free")

    samples[i, ] <- as.vector(t(unpackPotts(out$final)))
    samples[i, samples[i, ] == 2] <- -1
  }
  samples
}

###############################################################################
## Exact sampler

exact_sampler <- function (p, n_particles, n_iter) {
  # Takes in the exact probability for each state, ordered using
  # binary basis.

  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  for (i in 2:length(p)) p[i] = p[i - 1] + p[i]

  for (i in 1:n_iter) {
    u = runif(1, 0, 1)
    state = which(abs(p - u) == min(abs(p - u)))
    if (p[state] - u < 0) state = state + 1

    # remember we count states, starting at 0!
    X[i, ] = to_binary(state - 1, n_particles, ising_state = TRUE)
  }

  X
}