lp = function(trainingset, testset, column, upperBound = 1e16){

    matrixA = subset(trainingset, select = column)
    effort = trainingset$Effort
    nV = length(column)

    nConstrains = 2*length(column) + 4*dim(trainingset)[1]
    nVar = length(column) + 2*dim(trainingset)[1]
    mat1 = matrix(NA, ncol = nVar, nrow = dim(trainingset)[1])
    mat2 = matrix(NA, ncol = nVar, nrow = dim(trainingset)[1])
    mat3 = matrix(NA, ncol = nVar, nrow = dim(trainingset)[1])
    mat4 = matrix(0, ncol = nVar, nrow = nV)
    mat5 = matrix(0, ncol = nVar, nrow = nV)
    mat6 = matrix(0, ncol = nVar, nrow = dim(trainingset)[1])

    tzip = (1:dim(mat1)[1]*2+nV-1)
    cVec = rep(0, nVar)
    cVec[tzip] = 1
    for(i in 1:dim(matrixA)[1]){
      for(j in 1:dim(matrixA)[2]){
        mat1[i,j] = matrixA[i,j]
      }
    }
    mat1[is.na(mat1)] = 0
    b1 = rep(0, dim(mat1)[1])
    mat2 = mat1

    tzip= cbind((1:dim(mat2)[1]), (1:dim(mat2)[1]*2+nV-1))
    mat2[tzip] = -1
    effzip= cbind((1:dim(mat2)[1]), (1:dim(mat2)[1]*2+nV))
    mat2[effzip] = -1
    b2 = rep(0, dim(mat2)[1])

    mat3 = mat2
    tzip= cbind((1:dim(mat3)[1]), (1:dim(mat3)[1]*2+nV-1))
    mat3[tzip] = 1
    b3 = rep(0, dim(mat3)[1])

    diag(mat4) = 1
    b4 = rep(0, dim(mat4)[1])
    diag(mat5) = 1

    b5 = rep(upperBound, dim(mat5)[1])
    effzip= cbind((1:dim(mat6)[1]), (1:dim(mat6)[1]*2+nV))
    mat6[effzip] = 1
    b6 = effort
    A = rbind(mat1,mat2,mat3,mat4,mat5,mat6)
    constr = c(rep(">", dim(mat1)[1]), rep("<=", dim(mat2)[1]), rep(">=", dim(mat3)[1]), rep(">=", dim(mat4)[1]), rep("<=", dim(mat5)[1]), rep("=", dim(mat6)[1]))
    B = c(b1,b2,b3,b4,b5,b6)
    solSimplex = solveLP(cVec, B, A, const.dir = constr,lpSolve = TRUE, zero = 1e-16, tol = 1E-3)
    variablesValue = solSimplex$solution[1:nV]
    matrixATest = subset(testset, select = column)
    measured = testset$Effort

    prediction = rowSums(sweep(matrixATest, MARGIN = 2, variablesValue, `*`))

    return(list(data.frame(prediction,measured), variablesValue))
}


score <- function(input) {
    return((((((((((((((36.367080746577244) + ((input[1]) * (-0.10861311354908008))) + ((input[2]) * (0.046461486329936456))) + ((input[3]) * (0.027432259970172148))) + ((input[4]) * (2.6160671309537777))) + ((input[5]) * (-17.51793656329737))) + ((input[6]) * (3.7674418196772255))) + ((input[7]) * (-0.000021581753164971046))) + ((input[8]) * (-1.4711768622633645))) + ((input[9]) * (0.2956767140062958))) + ((input[10]) * (-0.012233831527259383))) + ((input[11]) * (-0.9220356453705304))) + ((input[12]) * (0.009038220462695552))) + ((input[13]) * (-0.542583033714222)))
}


# percentile of normal distribution using r
# we will use qnorm function
# 10 th percentile of Normal distribution Mean = 70 and SD=13
qnorm(0.10,70,13)


## Dati

rigasopra <- c(-2.22, -0.53, 0.81)
rigaverticale <- c(-4.1, -1.46, -0.16)

prob <- c(7,4,5,
                 8,3,9,
                 6,2,1)

library(MASS)

k <- fractions(1/sum(prob))
marginale_x <-c((prob[1]+prob[2]+prob[3])*k,
                (prob[4]+prob[5]+prob[6])*k,
                (prob[7]+prob[8]+prob[9])*k)

marginale_y <-c((prob[1]+prob[4]+prob[7])*k,
                (prob[2]+prob[5]+prob[8])*k,
                (prob[3]+prob[6]+prob[9])*k)

atteso_x <- sum(marginale_x *rigaverticale)

varianza_y <- sum(marginale_y * (rigasopra)^2) - sum(marginale_y * (rigasopra))^2

print(k)
print(marginale_x)
print(marginale_y)
print(atteso_x)
print(varianza_y)


rm(list = ls()) # clear console

# ADETAYO ADEGOKE
# WEEK 01 Homework - Logic, using Boolean Algebra and Finite Fields
# Due: February 05, 2020
# Mathematics E-23c, Spring 2020

# Questions 1 (a), (b) and (c)

# (p & q) IMPLIES (r | s) is equivalent to [not(p & q) | (r | s)]
# the le column represents this logical expression
eg <- expand.grid(c(TRUE, FALSE), c(TRUE, FALSE), c(TRUE, FALSE), c(TRUE, FALSE)); eg
ttbl <- data.frame(eg[,c(4:1)]); ttbl # reverse the columns
colnames(ttbl) <- c('p', 'q', 'r', 's'); ttbl #change the column names to match variable names, and display the truth table

# Had trouble with attach :(
# Construct the columns that will be used to compute the logical expression
ttbl$pq <- (ttbl$p & ttbl$q)
ttbl$notpq <- (!(ttbl$p & ttbl$q))
ttbl$rors <- (ttbl$r | ttbl$s)
ttbl$le <- (ttbl$notpq | ttbl$rors); ttbl # logical expression column

# The constructive normal form (aka cnf column below)for the LE looking at the truth table is
# (!p | !q | r | s)
ttbl$cnf <- (!(ttbl$p) | !(ttbl$q) | ttbl$r | ttbl$s); ttbl # voila, column le and cnf match in the truth table!

rm(list = ls()) # clear console

# Questions 2(a)

# setwd("/Users/adegade/OneDrive/Documents/Education/Harvard/Software Engineering/Spring-2020-MATH-E-23C/Homework")
Gssl <- read.csv("GSSLogical.csv") # load the input file
head(Gssl) # test that it and review columns
attach(Gssl)
index <- which(!is.na(Male) & !is.na(Republican) & !is.na(GunOwner) &
                 (Male == "FALSE") & (Republican == "FALSE") & (GunOwner == "TRUE")); index
length(index) # 37 = number of participants in the survey who were female democrats who owned guns

# Clean Up!
detach(Gssl)
rm(list = ls()) # clear console

# Questions 2(b)

# setwd("/Users/adegade/OneDrive/Documents/Education/Harvard/Software Engineering/Spring-2020-MATH-E-23C/Homework")
Redsox <- read.csv("RedSox2013.csv") # load the input file
head(Redsox) # test that it and review columns
attach(Redsox)
TRuns <- R + RA # create a new column that totals up runs
HRuns <- subset(Redsox, TRuns >= 10); HRuns # get a subset of data with for games with 10 runs or more
min(HRuns$Duration)

# Question 2(c)

boxplot(R ~ DayNight) # display box plot of runs in day and night Red Sox games

# Question 2(d)

tbl <- table(WonLost, Away); tbl # create the table for observed WonLost and Away comparison
Expected <- outer(rowSums(tbl), colSums(tbl))/sum(tbl); Expected # create the table for expected WonLost and Away comparison
chisq.test(tbl, Expected) # there is a 16.73% chance that the discreptancy b/w expected and observed comparison between WonLost and Away
# is not statistically relevant, assuming the null hypothesis of independence.  The dataset does not provide enough evidence to support
#  the null hypothesis of independence (0.1673 > 0.05).  Red Sox did not seem to have an advantage in Home or Away games.

tbl <- table(WonLost, DayNight); tbl # create the table for observed WonLost and Away comparison
Expected <- outer(rowSums(tbl), colSums(tbl))/sum(tbl); Expected # create the table for expected WonLost and Away comparison
chisq.test(tbl, Expected) # there is a 43.8% chance that the discreptancy b/w expected and observed comparison between WonLost and DayNight
# is not statistically relevant, assuming the null hypothesis of independence.  The dataset does not provide enough evidence to support
#  the null hypothesis of independence (0.438 > 0.05).  Red Sox did not seem to have an advantage in Home or Away games.

# Clean Up!
detach(Redsox)
rm(list = ls()) # clear console

# Question 3(a)

attach(airquality) # attach the data frame
head(airquality) # display the first few rows of the data frame
boxplot(Ozone ~ Month) # display box plot of how Ozone depends on Month
boxplot(Solar.R ~ Month) # display box plot of how Solar Radiation depends on Month
boxplot(Wind ~ Month) # display box plot of how Wind depends on Month
boxplot(Temp ~ Month) # display box plot of how Temperature depends on Month

# Question 3(b)

aq <- get("airquality"); head(airquality) # get and display the airquality data frame
attach(aq)

plot(Temp, Solar.R) # create a plot of Temperature versus Solar Radiation
model <- lm(Solar.R ~ Temp) # create a Model
abline(model$coefficients[1], model$coefficients[2]) # draw the regression line on the plot
# data points in the plot are widely dispersed, as such temperature does not seem to be good predictor for solar radiation

plot(Temp, Ozone) # create a plot of Temperature versus Ozone
model <- lm(Ozone ~ Temp) # create a Model
abline(model$coefficients[1], model$coefficients[2]) # draw the regression line on the plot
# data points in the plot are relatively close together with a strong positive linear relationship, as such temperature
# does seem to be good predictor for solar radiation

# Question 3(c)

# Define new logical vectors while accounting for the NA data points in the set
smoggy <- Ozone > mean(Ozone, na.rm = TRUE); head(smoggy)
windy <- Wind> mean(Wind, na.rm = TRUE); head(windy)
sunny <- Solar.R > mean(Solar.R, na.rm = TRUE); head(sunny)
hot <- Temp > mean(Temp, na.rm = TRUE); head(hot)

# Select the days where all four logical vectors defined above are true
subset(airquality, (smoggy == TRUE) & (windy == TRUE) & (sunny == TRUE) & (hot == TRUE))

# Question 3(d)

chisq.test(smoggy, windy) # there is a 4.29 x 10^(-4)% chance that observed dependencies between the two factors being compared
# happened by chance.  Since this is a lot less than 5%, we will reject the null hypothesis of independence between the
# two variables and propose that they are both probably dependent
# smoggy and windy are probably dependent variables

chisq.test(windy, sunny) # there is a 68.23% chance that observed dependencies between the two factors being compared
# happened by chance.  Since this is a lot more than 5%, we will fail to reject the null hypothesis of independence between the
# two variables and propose that they are both probably independent
# windy and sunny are probably independent variables

#Clean Up!
detach(airquality)
rm(list = ls()) # clear console


# test statistic
t=.26528/.10127
print(t)
df=17
t1value=qt(1-0.01,df)
t2value=qt(1-0.005,df)
print(t1value)
print(t2value)
  #  Thus, H0 would be rejected at the alpha= .01 level but not at the alpha=  .005 level
pvalue =pt(-t, df)
print(pvalue)


change.base <- function(n, base)
{
  ret <- integer(as.integer(logb(x=n, base=base))+1L)

  for (i in 1:length(ret))
  {
    ret[i] <- n %% base
    n <- n %/% base

  }

  return(ret)
}

sum.digits <- function(n, base=10)
{
  if (base < 2)
    stop("base must be at least 2")

  return(sum(change.base(n=n, base=base)))
}

sum.digits(1)
sum.digits(12345)
sum.digits(123045)
sum.digits(0xfe, 16)
sum.digits(0xf0e, 16)


library(combinat)

permute.me <- c("A", "B", "C", "D")
perms  <- permn(permute.me)  # list of all permutations
perms2 <- matrix(unlist(perms), ncol=length(permute.me), byrow=T)  # matrix of all permutations
perms3 <- apply(perms2, 1, paste, collapse="")  # vector of all permutations

incomplete <- c("ABCD", "CABD", "ACDB", "DACB", "BCDA", "ACBD", "ADCB", "CDAB",
                "DABC", "BCAD", "CADB", "CDBA", "CBAD", "ABDC", "ADBC", "BDCA",
                "DCBA", "BACD", "BADC", "BDAC", "CBDA", "DBCA", "DCAB")

setdiff(perms3, incomplete)


# Expectation-Maximizaton to fins clusters and alpha, beta, tau parameters
# of each cluster
#
# author: Alberto Lumbreras
library(data.table)
library(neldermead)
library(dfoptim)
#source('optimization.r')

update_responsabilities <- function(df.trees, u, pis, alphas, betas, taus){
  # Compute E(z_uk) over the posterior distribution p(z_uk | X, theta)

  K <- length(alphas) # number of clusters
  Xu <- filter(df.trees, user==u) # all posts from user

  logfactors <- rep(0,K)
  for (k in 1:K){
    logfactors[k] <- log(pis[k]) + sum(apply(Xu, 1, likelihood.post, alphas[k], betas[k], taus[k]))
  }

  logfactors <- logfactors - max(logfactors) # avoid numerical underflow
  denominator <- sum(exp(logfactors))
  responsabilities_u <- exp(logfactors)/denominator
  responsabilities_u
}

# Likelihood computation using the dataframe
likelihood.post <- function(row, alpha, beta, tau){
  c(as.matrix(
       log(alpha * row['popularity'] + beta*(row['parent']==1) + tau^row['lag']) -
       log(2*alpha*(row['t']-1)   + beta + tau*(tau^row['t']-1)/(tau-1))
       )
    )
}

Qopt <- function(params, resp_k, df.trees){
  # sum of E[lnp(X,Z|\theta)] likelihoods for all clusters and all users
  # given the current responsabilities
  # Note that the optimizations can be done separatedly
  a <- resp_k[df.trees$user]
  b <- apply(df.trees, 1, function(x) likelihood.post(x, params[1], params[2], params[3]))
  sum(a*b) # each likelihood b is weighted according to how much dos the user belong to the cluster
}

# Wrapper for the optimization function
# so that the only parameters are the ones to optimize
#cost.function <- function(params){
#  -1*Qopt(alpha=params[1], beta=params[2], tau=params[3], responsabilities[,k], df.trees)
#}

#Qopt.prima <- function(alpha, beta, tau, resp_k, df.trees){
#  sum(apply(df.trees, 1, likelihood.post, alpha, beta, tau))
#}

EM <-function(df.trees, alphas, betas, taus){
  # Expectation-Maximizationo to find groups of users with different
  # alpha, beta, tau parameters
  # Arguments:
  #   trees: a list of igraph objects representing discussion threads
  #   alphas, betas, taus: initial assignment of users to clusters
  K <- length(alphas)
  users <- unique(df.trees$user)
  U <- length(users)

  responsabilities <- matrix(nrow = U, ncol = K)
  pis <- rep(1/ncol(responsabilities), ncol(responsabilities))

  niters <- 10
  traces <- matrix(0, nrow=niters, ncol=K)
  for(iter in 1:niters){
      cat("\n**********ITERATION**********: ", iter, "\n")
      # EXPECTATION
      # Given the parameters of each cluster, find the responsability of each user in each cluster
      #################################################################
      # (this can be parallelizable)
      for (u in 1:U){
        responsabilities[u,] <- update_responsabilities(df.trees, u, pis, alphas, betas, taus)
      }

      #print(responsabilities)
      cat("Best vectors:\n", apply(responsabilities, 1, which.max))

      # MAXIMIZATION
      # Given the current responsabilities and pis, find the best parameters for each cluster
      ################################################################
      for(k in 1:K){
        # Optimization for cluster k
        # neldermead::fminbnd does not deal well with boundaries
        # nlminb and nmkb give the same solution.
        # nmkb is a little bit faster
        # sol <- nlminb(c(alphas[k],betas[k],taus[k]), cost.function,
        #              scale = 1, lower=c(0,0,0), upper=c(Inf, Inf, 1))
        sol <- nmkb(c(alphas[k], betas[k], taus[k]), Qopt,
                    lower = c(0,0,0), upper = c(Inf, Inf, 1),
                    control = list(maximize=TRUE),
                    resp_k = responsabilities[,k], df.trees = df.trees)
        alphas[k] <- sol$par[1]
        betas[k]  <-  sol$par[2]
        taus[k]   <-  sol$par[3]
        traces[iter,k] <- sol$value
      }

      # Update pis
      pis <- colSums(responsabilities)/nrow(responsabilities)

      ###############################################################
      # EVALUATION OF FULL LIKELIHOOD p(X, Z | \theta)
      ###############################################################
      cat("\n\nalphas:", alphas)
      cat("\nbetas:", betas)
      cat("\ntaus:", taus)
  }

  list(alphas=alphas,
       betas=betas,
       taus=taus,
       z=z,
       traces=traces)

}

if(TRUE){
  #load('trees.Rda')

  # True parameters
  alphas <- c(0.1, 0.5, 1)
  betas <- c(1, 6, 3)
  taus <- c(0.7, 0.1, 0.2)

  # The first two posts of every thread are trivial since they have no choice
  df.trees <- filter(df.trees, t>2)

  # Expectation-Maximization
  res <- EM(df.trees, alphas, betas, taus)
  plot(rowSums(res$traces))

  #-7840
  #-7839
  #-7893

}


orderBalancedTree <- Vectorize(function(r, h) {
  #  computes the number of vertices in a balanced tree of breadth "r" and height "h"
  #
  #  Args:
  #     r:  The breadth (branching factor) of the balanced tree
  #     h:  The height of the balanced tree
  #
  #  Returns:
  #     The number of vertices in a balanced tree
  #

  total <- 0
  hseq <- seq.int(0, h)
  total <- sum(r ^ hseq)

  return(total)
})


Dragon<-function(Iters){
  Rotation<-matrix(c(0,-1,1,0),ncol=2,byrow=T) ########Rotation multiplication matrix
  Iteration<-list() ###################################Set up list for segment matrices for 1st
  Iteration[[1]] <- matrix(rep(0,16), ncol = 4)
  Iteration[[1]][1,]<-c(0,0,1,0)
  Iteration[[1]][2,]<-c(1,0,1,-1)
  Moveposition<-rep(0,Iters) ##########################Which point should be shifted to origin
  Moveposition[1]<-4
  if(Iters > 1){#########################################where to move to get to origin
    for(l in 2:Iters){#####################################only if >1, because 1 set before for loop
      Moveposition[l]<-(Moveposition[l-1]*2)-2#############sets vector of all positions in matrix where last point is
    }}
  Move<-list() ########################################vector to add to all points to shift start at origin
for (i in 1:Iters){
half<-dim(Iteration[[i]])[1]/2
half<-1:half
for(j in half){########################################Rotate all points 90 degrees clockwise
  Iteration[[i]][j+length(half),]<-c(Iteration[[i]][j,1:2]%*%Rotation,Iteration[[i]][j,3:4]%*%Rotation)
}
Move[[i]]<-matrix(rep(0,4),ncol=4)
Move[[i]][1,1:2]<-Move[[i]][1,3:4]<-(Iteration[[i]][Moveposition[i],c(3,4)]*-1)
Iteration[[i+1]]<-matrix(rep(0,2*dim(Iteration[[i]])[1]*4),ncol=4)##########move the dragon, set next Iteration's matrix
for(k in 1:dim(Iteration[[i]])[1]){#########################################move dragon by shifting all previous iterations point
  Iteration[[i+1]][k,]<-Iteration[[i]][k,]+Move[[i]]###so the start is at the origin
}
xlimits<-c(min(Iteration[[i]][,3])-2,max(Iteration[[i]][,3]+2))#Plot
ylimits<-c(min(Iteration[[i]][,4])-2,max(Iteration[[i]][,4]+2))
plot(0,0,type='n',axes=FALSE,xlab="",ylab="",xlim=xlimits,ylim=ylimits)
s<-dim(Iteration[[i]])[1]
s<-1:s
segments(Iteration[[i]][s,1], Iteration[[i]][s,2], Iteration[[i]][s,3], Iteration[[i]][s,4], col= 'red')
}}#########################################################################


#' Loads the necessary libraries, which are: huge, MASS, thav.glasso, scalreg, igraph, matrixcalc, genscore, scio, stargazer, glasso
#'
#' @export
load_libraries <- function()
{
  libraries <- c("huge", "MASS", "thav.glasso", "scalreg", "igraph", "matrixcalc", "genscore", "scio", "stargazer", "glasso")
  lapply(libraries, library, character.only=TRUE)
}

#' Turns a covariance matrix into the correlation matrix
#'
#' @param theta Covariance matrix
#' @return Correlation matrix
#' @export
normalize_theta <- function(theta)
{
  for(j in 1:dim(theta)[1])
  {
    for(i in 1:dim(theta)[1])
    {
      theta[i,j] <- theta[i,j] / (sqrt(theta[i,i]) * sqrt(theta[j, j]))
    }
  }
  return(theta)
}

#' Computes the adaptive validation graphical lasso
#'
#' @param data Data matrix of size n x d
#' @param C constant C that is used to calibrate the AV regularization parameter
#' @return The selected regularization parameter
#' @return The resulting graphical lasso estimate
#' @examples
#' theta <- generateGraph(d=100)[[1]]
#' Sigma <- solve(theta)
#' data <- scale(mvrnorm(n=200, mu=rep(0, 100), Sigma=Sigma))
#' av <- av_glasso(data)
#' av_tp <- av$TuningParameter
#' av_est <- av$Thetahat
#' @export
av_glasso <- function(data, C=0.7)
{
  empvar <- var(data)

  # Automatically set max(seq_r) <- tp that sets all offdiagonal entries to zero
  max_r <- max( abs(empvar[upper.tri(empvar)]))
  seq_r <- seq(0.05, max_r, length.out = 40)

  r <- max(seq_r)
  estimates <- list()

  #calculate glasso[max(r)] and setup the warm start
  glasso <- glasso(empvar, rho=r, penalize.diagonal=FALSE)
  warm <- list(glasso$wi, glasso$w)
  estimates[[length(seq_r)]] <- normalize_theta(warm[[1]]) #warm[[1]] #

  counter_r <- length(seq_r) #used to fill the list estimates with corresponding estimates
  while(r > min(seq_r))
  {
    #compute glasso[r] using a warm start
    counter_r <- counter_r - 1
    r <- seq_r[counter_r]
    newwarm <- glasso(empvar, rho=r, penalize.diagonal=FALSE, start="warm", wi.init=warm[[1]], w.init=warm[[2]])
    estimates[[counter_r]] <- normalize_theta(newwarm$wi)
    warm <- list(newwarm$wi, newwarm$w)

    counter_r_dash <- length(seq_r)
    r_dash <- seq_r[counter_r_dash]
    while(r_dash > r)
    {
      #if l(...) > Cr_dash + Cr
      if(avtest(estimates, seq_r, counter_r, counter_r_dash, C))
      {
        return(list(TuningParameter=seq_r[counter_r + 1], Thetahat=estimates[[counter_r + 1]]))
      }
      counter_r_dash <- counter_r_dash - 1
      r_dash <- seq_r[counter_r_dash]
    }
  }
  estimates[[1]] <- normalize_theta(glasso(empvar, rho=min(seq_r), penalize.diagonal=FALSE, start="warm", wi.init=warm[[1]], w.init=warm[[2]])$wi)
  return(list(TuningParameter=seq_r[1], Thetahat=estimates[[1]]))
}

#' Computes the test that is used in the AV calibration scheme
#'
#' @param estimates List of the graphical lasso estimators so far
#' @param seq_r List of possible regularization paraeters
#' @param counter_r position of the current r in r_seq (see algorithm)
#' @param counter_r_dash position of the current r_dash in seq_r (see algorithm)
#' @param C constant C that is used for the AV calibration
#' @return TRUE if l(...) > Cr_dash + Cr, else FALSE
#' @export
avtest <- function(estimates, seq_r, counter_r, counter_r_dash, C)
{
  infloss(estimates[[counter_r]], estimates[[counter_r_dash]]) > C * (seq_r[counter_r] + seq_r[counter_r_dash])
}

#' Thresholds the AV estimator
#'
#' @param av List AV containing the regularization parameter and the estimator, which is obtained by applying the av_glasso function
#' @param C Constant C that was used to calibrate the AV
#' @param lambda Threshold factor lambda: We threshold the AV solution by lambda*C*av$TuningParameter
#' @return The thresholded AV estimator
#' @export
threshold <- function( av, C=0.7, lambda=1)
{
  return( apply( av$Thetahat, c(1,2), function(x) if( abs(x) <= lambda*C*av$TuningParameter){ return(0)} else{ return(x)}))
}

#' Computes the thAV estimator
#'
#' @param data Data matrix of size n x d
#' @param C constant C that is used to calibrate the AV regularization parameter
#' @param lambda Threshold factor lambda: We threshold the AV solution by lambda*C*av$TuningParameter
#' @param mute If FALSE, the method prints the selected AV regularization parameter. The default value is TRUE.
#' @return The thresholded AV estimator
#' @examples
#' theta <- generateGraph(d=100)[[1]]
#' Sigma <- solve(theta)
#' data <- scale(mvrnorm(n=200, mu=rep(0, 100), Sigma=Sigma))
#' thav <- thAV.estimator(data)
#' @export
thAV.estimator <- function( data, C=0.7, lambda=1, mute=TRUE)
{
  av <- av_glasso(data, C)

  if(!mute)
  {
    print(paste0("Selected Regularization Parameter: ", round(av$TuningParameter,2)))
  }
  return( threshold(av, C, lambda))
}

#' Computes the rSME via eBIC
#'
#' @param data Data matrix of size n x d
#' @param gamma Parameter that is used in the eBIC criterion. Usually gamma=0.5 or gamma=1. The default value is set to 1.
#' @return rSME estimator that is tuned via eBIC
#' @export
score_ebic <- function(data, gamma=1)
{
  d <- dim(data)[2]
  domain <- make_domain("R", p=d)
  elts <- get_elts(NULL, data, "gaussian", domain)
  max_r <- lambda_max(elts, "symmetric")
  seq_r <- seq(0.05, max_r, length.out = 40)
  best_eBIC <- 10^5
  for(j in 1:length(seq_r))
  {
    result <- get_results(elts, "symmetric", seq_r[j])
    if(eBIC(result, elts, gammas=gamma)[1] < best_eBIC)
    {
      ebic_est <- result$K
      best_eBIC <- eBIC(result, elts, gammas=gamma)[1]
    }
  }
  return(ebic_est)
}

#' Computes the adaptive validation regularized score matching estimator rSME (AV)
#'
#' @param data Data matrix of size n x d
#' @param C constant C that is used to calibrate the AV regularization parameter
#' @return The selected regularization parameter
#' @return The resulting AV regularized score matching estimator rSME (AV)
#' @export
av_rsme <- function(data, C=2)
{
  empvar <- var(data)
  seq_r <- seq(5e-4, 0.3, length.out = 40)
  #initialization
  r <- max(seq_r)

  domain <- make_domain("R", p=dim(empvar)[1])
  estimates <- estimate(data, "gaussian", domain, scale="sd", return_raw=TRUE, lambda1s=seq_r,
                        verbose=FALSE, verbosetext=FALSE)$raw_estimate
  estimates <- rev(estimates) # genscore implementation returns a list of estimates
                              # where the first entry corresponds to the largest TP estimate
  # normalize each theta
  for(j in 1:40)
  {
    estimates[[j]] <- normalize_theta(estimates[[j]])
  }
  counter_r <- length(seq_r) #used to fill the list estimates with corresponding estimates
  while(r != min(seq_r))
  {
    counter_r <- counter_r - 1
    r <- seq_r[counter_r]

    counter_r_dash <- length(seq_r)
    r_dash <- seq_r[counter_r_dash]
    while(r_dash > r)
    {
      #if l(...) > Cr_dash + Cr
      if(avtest(estimates, seq_r, counter_r, counter_r_dash, C))
      {
        return(list(TuningParameter=seq_r[counter_r + 1], Thetahat=estimates[[counter_r + 1]]))
      }
      counter_r_dash <- counter_r_dash - 1
      r_dash <- seq_r[counter_r_dash]
    }
  }
  return(list(TuningParameter=seq_r[1], Thetahat=estimates[[1]]))
}

#' Computes the trace of a matrix
#'
#' @param matrix Matrix
#' @return Trace of matrix
#' @export
tr <- function(matrix)
{
  return(sum(diag(matrix)))
}

#' Computation of the Bregman loss as defined in "Weidong Liu, Xi Luo, Fast and adaptive sparse precision matrix estimation in high dimensions, Journal of Multivariate Analysis, Volume 135, 2015, Pages 153-162"
#'
#' @param sigma Covariance matrix Sigma
#' @param theta Precision matrix Theta
#' @return Bregman loss
bregman_loss <- function(sigma, theta)
{
  return(tr(sigma %*% theta) - log(det(theta)))
}

#' Computation of the Sparse Columnwise Inverse Operator (SCIO) estimator tuned via the Bregman loss: We pick the regularization parameter that minimizes the Bregman loss.
#'
#' @param data Data matrix of size n x d
#' @return SCIO estimator
#' @export
scio_bregman <- function(data)
{
  empvar <- var(data)
  seq_r <- seq(0.05, max(abs(empvar[upper.tri(empvar)])), length.out = 40)

  bregman <- rep(0, length(seq_r))
  for(j in 1:length(seq_r))
  {
    bregman[j] <- bregman_loss(empvar, scio(empvar, lambda=seq_r[j])$w)
  }
  best_r <- seq_r[which.min(bregman)]
  return(scio(empvar, lambda=best_r)$w)
}

#' Computation of the adaptive validation SCIO
#'
#' @param data Data matrix of size n x d
#' @param C constant C that is used to calibrate the AV regularization parameter
#' @return The selected regularization parameter
#' @return The resulting AV-SCIO estimate
#' @export
av_scio <- function(data, C=0.7)
{
  empvar <- var(data)
  max_r <- max(abs(empvar[upper.tri(empvar)]))
  seq_r <- seq(0.05, max_r, length.out = 40)
  #initialization
  r <- max(seq_r)
  estimates <- list()

  estimates[[length(seq_r)]] <- normalize_theta(scio(empvar, lambda=r)$w)

  counter_r <- length(seq_r) #used to fill the list estimates with corresponding estimates
  while(r != min(seq_r))
  {
    counter_r <- counter_r - 1
    r <- seq_r[counter_r]
    estimates[[counter_r]] <- normalize_theta(scio(empvar, lambda=r)$w)

    counter_r_dash <- length(seq_r)
    r_dash <- seq_r[counter_r_dash]
    while(r_dash > r)
    {
      #if l(...) > Cr_dash + Cr
      if(avtest(estimates, seq_r, counter_r, counter_r_dash, C))
      {
        return(list(TuningParameter=seq_r[counter_r + 1], Thetahat=estimates[[counter_r + 1]]))
      }
      counter_r_dash <- counter_r_dash - 1
      r_dash <- seq_r[counter_r_dash]
    }
  }
  return(list(TuningParameter=seq_r[1], Thetahat=estimates[[1]]))
}

#' Computes the reweighted l1 regularization to compute the graphical lasso with power law regularization (Liu & Ihler(2011)).
#'
#' @param est Estimation of Theta from the previous iteration
#' @param alpha Regularization parameter
#' @return The reweighted penalties as a dxd matrix.
#' @export
penalty_matrix <- function(est, alpha)
{
  d <- dim(est)[1]
  eps <- diag(est)
  lambda <- matrix(rep(0, d*d), ncol=d)
  for(j in 1:(d-1))
  {
    for(i in j:d)
    {
      if(i==j)
      {
        lambda[i, i] <- 0
      }
      else
      {
        lambda[i, j] <- lambda[j, i] <- alpha * ( 1/(sum(abs(est[i, ])) + eps[i]) + 1/(sum(abs(est[j, ])) + eps[j]))
      }
    }
  }
  return(lambda)
}

#' Computes the graphical lasso with power law regularization sf_glasso (Liu & Ihler(2011)).
#'
#' @param data Data matrix of size n x d
#' @param alpha Regularization parameter
#' @return Graphical lasso with power law regularization
#' @export
sf_glasso <- function(data, alpha)
{
  d <- dim(data)[2]
  est <- diag(d)
  empvar <- var(data)
  for(j in 1:3)
  {
    rho <- penalty_matrix(est, alpha)
    est <- glasso(empvar, rho=rho)$wi
  }
  return(est)
}

#' Computes the graphical lasso with power law regularization and regularization parameter tuned via adaptive validation sf_glasso (AV).
#'
#' @param data Data matrix of size n x d
#' @param C Constant C used to tune the thAV. Default value is 1.5
#' @return Graphical lasso with power law regularization and regularization parameter tuned via adaptive validation
#' @export
av_sf_glasso <- function(data, C=1.5)
{
  empvar <- var(data)
  max_r <- 0.8#max(abs(empvar[upper.tri(empvar)]))
  seq_r <- seq(0.01, max_r, length.out = 40)
  #initialization
  r <- max(seq_r)
  estimates <- list()

  estimates[[length(seq_r)]] <- normalize_theta(sf_glasso(data, r))

  counter_r <- length(seq_r) #used to fill the list estimates with corresponding estimates
  while(r != min(seq_r))
  {
    counter_r <- counter_r - 1
    r <- seq_r[counter_r]
    estimates[[counter_r]] <- normalize_theta(sf_glasso(data, r))

    counter_r_dash <- length(seq_r)
    r_dash <- seq_r[counter_r_dash]
    while(r_dash > r)
    {
      #if l(...) > Cr_dash + Cr
      if(avtest(estimates, seq_r, counter_r, counter_r_dash, C))
      {
        return(list(TuningParameter=seq_r[counter_r + 1], Thetahat=estimates[[counter_r + 1]]))
      }
      counter_r_dash <- counter_r_dash - 1
      r_dash <- seq_r[counter_r_dash]
    }
  }
  return(list(TuningParameter=seq_r[1], Thetahat=estimates[[1]]))
}


# Generates artificial threads with models of Gomez 2010 and Gomez 2013
# author: Alberto Lumbreras
################################

library(igraph)
library(dplyr)
source('R/plotting.r')

gen.thread.Gomez2011 <- function(n=100, alpha.root=1, alpha.c = 1, beta.root = 1){
  # Generate synthetic thread according to Gomez 2011
  # Args:
  #    n: number of posts
  #    alpha:  preferential attachement exponent
  #    beta: root bias
  g <- graph.empty(n=1)

  # First post has no choice
  g <- add_vertices(g, 1)
  g <- add_edges(g, c(2,1))

  for (i in 3:n){
    alphas <- c(alpha.root, rep(alpha.c, i-2))
    betas <- c(beta.root, rep(1, i-2))
    popularities <- 1 + degree(g, mode="in")

    # Probability of choosing every node (only one is chosen)
    probs <- (betas*popularities)^alphas
    probs <- probs/sum(probs)
    j <- sample(1:length(probs), 1, prob=probs)

    # Add new vertex attached to the chosen node
    g <- add_vertices(g, 1)
    g <- add_edges(g, c(i,j))
  }
  g
}

gen.thread.Gomez2013 <- function(n=100, alpha=1, beta = 1, tau=0.75){
  # Generate synthetic thread according to Gomez 2011
  # Args:
  #    n: number of posts
  #    alpha:  preferential attachement exponent
  #    beta: root bias
  g <- graph.empty(n=1)

  # First post has no choice
  g <- add_vertices(g, 1)
  g <- add_edges(g, c(2,1))

  for (i in 3:n){
    betas <- c(beta, rep(0, i-2))
    lags <- (i-1):1
    popularities <- 1 + degree(g, mode="in") # even root starts with degree 1

    # Probability of choosing every node (only one is chosen)
    probs <- alpha*popularities + betas + tau^lags
    probs <- probs/sum(probs)
    j <- sample(1:length(probs), 1, prob=probs)

    # Add new vertex attached to the chosen node
    g <- add_vertices(g, 1)
    g <- add_edges(g, c(i,j))
  }
  V(g)$user <- 1 # for compatibility with Lumbreras
  g
}

gen.thread.Lumbreras2016 <- function(n=100, z=c(1,2,3), alphas = c(1,2,3), betas = c(1,2,3), taus = c(0.25, 0.5, 0.75)){
  # Generate threads like in Gomez 2013 but from a mixture model where users
  # in one component have different parameters (alpha, beta, tau)  than users in the
  # other component
  # then for each post chose a random user and then pick the parameters of its group
  # Args:
  #    n: number of posts
  #    alpha:  preferential attachement exponent
  #    beta: root bias
  nusers <- length(z)
  g <- graph.empty(n=1)

  # First post has no choice
  g <- add_vertices(g, 1)
  g <- add_edges(g, c(2,1))

  # the user of the two first posts is irrelevant for us
  V(g)$user <- 1

  for (i in 3:n){
    # choose random user
    u <- sample(nusers, 1)
    cluster <- z[u]
    alpha <- alphas[cluster]
    beta <- betas[cluster]
    tau <- taus[cluster]

    bs <- c(beta, rep(0, i-2))
    lags <- (i-1):1
    popularities <- 1 + degree(g, mode="in") # even root starts with degree 1

    # Probability of choosing every node (only one is chosen)
    probs <- alpha*popularities + bs + tau^lags
    probs <- probs/sum(probs)

    j <- sample(1:length(probs), 1, prob=probs)

    # Add new vertex attached to the chosen node
    g <- add_vertices(g, 1, attr=list('user'= u))
    g <- add_edges(g, c(i,j))
  }
  g
}

tree.to.data <- function(g, thread=0){
  # Creates a dataframe with a row per post
  # and columns "degree of parent", "is_parent_root", "lag to parent", and "t"
  # With the model parameters, the three first columns are used to compute the numerator the likelihood
  # and 't' to compute the denominator of the likelihood
  parents <- get.edgelist(g)[,2] # parents vector without the first two posts
  authors <- V(g)$user[-1] # remove first post
  popularities <- c(1,sapply(2:length(parents), function(t) 1 + sum(parents[1:(t-1)]==parents[t])))
  #popularities[parents==1] <- popularities[parents==1]-1 # the root node has no parent
  posts <- 2:(length(parents)+1)
  data <- data.frame(thread = rep(thread, length(posts)),
                     user = authors,
                     post = posts,
                     t = 1:(length(parents)),
                     parent = parents,
                     popularity = popularities)

  data <- mutate(data, lag=t-parent+1)
  data
}

# Generate a synthetic dataset of trees
#######################################
if(FALSE){
  n <- 100

  alpha.root <- 0.734
  alpha.c <- 0.683
  beta.root <- 1.302
  trees <- replicate(n,  gen.thread.Gomez2011(n=20, alpha.root=alpha.root, alpha.c=alpha.c, beta.root=beta.root), simplify = FALSE)

  alpha <- 1
  beta <- 0.68
  tau <- 0.75
  trees <- replicate(100, gen.thread.Gomez2013(n=100, alpha=alpha, beta=beta, tau=tau), simplify = FALSE)

  # Synthetic trees for Lumbreras 2016
  set.seed(1)
  alphas <- c(1,2,3)
  betas <- c(1,2,3)
  taus <- c(0.25, 0.5, 0.75)
  z <- c(1,2,3,1,2,3,1,2,3,1,2,3)
  trees <- replicate(1000,  gen.thread.Lumbreras2016(n=100, z=z, alphas=alphas, betas=betas, taus=taus), simplify = FALSE)

  # Very simple synthetic trees for Lumbreras 2016
  set.seed(1)
  alphas <- c(0.1,0.5)
  betas <- c(0.1,0.5)
  taus <- c(0.1, 0.5)
  z <- c(1,2)

  set.seed(1)
  alphas <- c(0.1, 0.5, 1)
  betas <- c(1, 5, 10)
  taus <- c(0.1, 0.5, 0.99)
  z <- do.call(c, lapply(1:length(alphas), function(x) rep(x,10000)))

  # the parallel way
  library(parallel)
  cl <- makeCluster(detectCores()-2)
  clusterEvalQ(cl, {library(igraph); source('thread_generator.r')})
  clusterExport(cl, c("alphas", "betas", "taus", "z"))
  trees <- parLapply(cl, 1:20000, function(i) gen.thread.Lumbreras2016(n=25, z=z, alphas=alphas, betas=betas, taus=taus) )
  stopCluster(cl)

  save(trees, file='trees.Rda')

  # Create dataframe from a set of trees
  ############################################################
  # Prepare all the information needed into a nice dataframe
  library(parallel)
  ncores <- detectCores() - 2
  cl<-makeCluster(ncores, outfile="", port=11439)
  clusterEvalQ(cl, {library(igraph); library(dplyr)})
  data.parlapply <- parLapply(cl, trees, tree.to.data)
  stopCluster(cl)

  # join results adding thread id
  for (i in 1:length(data.parlapply)){
    data.parlapply[[i]]$thread <- i
  }
  data.parlapply <- rbindlist(data.parlapply)
  df.trees <- data.frame(thread = data.parlapply$thread,
                         user = data.parlapply$user,
                         post = data.parlapply$post,
                         t = data.parlapply$t,
                         parent = data.parlapply$parent,
                         popularity = data.parlapply$popularity,
                         lag = data.parlapply$lag)

  save(df.trees, file='df.trees.Rda')

}

# Generate and plot some synthetic tree
########################################
TEST <- FALSE
if(TEST){
  # Values reported in Gomze 2010 (Table 2)
  # Slashdot:
  alpha.root <- 0.734
  alpha.c <- 0.683
  beta.root <- 1.302

  # Barrapunto
  alpha.root <- 0.665
  alpha.c <- -0.116
  beta.root <- 0.781

  # Meneame
  alpha.root <- 0.856
  alpha.c <- 0.196
  beta.root <- 1.588

  # Wikipedia
  alpha.root <- 0.884
  alpha.c <- -1.684
  beta.root <- 0.794

  trees <- replicate(4,  gen.thread.Gomez2011(n=100, alpha.root=alpha.root, alpha.c=alpha.c, beta.root=beta.root), simplify = FALSE)

  alpha <- 1
  beta <- 0.68
  tau <- 0.75
  trees <- replicate(4,  gen.thread.Gomez2013(n=100, alpha=alpha, beta=beta, tau=tau), simplify = FALSE)

  trees <- replicate(4,  gen.thread.Lumbreras2016(n=100), simplify = FALSE)

  par(mfrow=c(2,2))
  for (i in 1:length(trees)){
    g <- trees[[i]]
    root = which(degree(g, mode='out')==0)
    V(g)$color <- 'black'
    V(g)$color[root] <- 'red'
    V(g)$size <- 1
    V(g)$size[root] <- 3
    g.un <- as.undirected(g)
    la = layout_with_fr(g.un)
    plot(g.un, layout = la, vertex.label = NA, edge.arrow.size=0.6)
  }
}


### The idea is to get score residuals from the score vector ###

# a function to get score residiuals from the fitted model
# (the code are taking directly from `orm.fit`)
func_score <- function(fit){

  # coefficients
  coef <- fit$coefficients

  # convert y to ordered category
  y <- match(fit$y, fit$yunique)
  # x
  x <- fit$x

  # some useful numbers
  kint <- length(fit$yunique) - 1L
  nx <- dim(x)[2L]
  n <- length(y)
  p <- as.integer(kint + nx)

  # store results - matrix
  u <- matrix(0, nrow = n, ncol=p)

  # functions
  f   <- fit$trans$cumprob
  fp  <- fit$trans$deriv

  xb <- fit$x %*% coef[-(1L : kint)]
  ints <- c(1e100, coef[1:kint], -1e100)
  xby <- xb + ints[y]; xby1 <- xb + ints[y + 1L]
  fa <- f(xby)
  fb <- f(xby1)
  P <- fa - fb
  fpa  <- fp(xby,   fa)
  fpb  <- fp(xby1,  fb)

  # score for alpha
  for(m in 1:kint){
    for(j in 1:n){
      u[j, m] <-  (fpa[j]*(y[j]-1==m) - fpb[j]*(y[j]==m)) / P[j]
    }
  }

  # score for beta
  for(m in (kint+1):p){
    for(j in 1:n){
      u[j, m] <- (fpa[j] - fpb[j]) * x[j,m-kint] / P[j]
    }
  }

  return(u)

}

func_robcov <- function(fit, cluster){
  var   <- vcov(fit, intercepts='all')
  vname <- dimnames(var)[[1]]

  # X <- as.matrix(residuals(fit, type="score"))
  X <- func_score(fit) # get score residuals

  n <- nrow(X)

  cluster <- as.factor(cluster)

  p <- ncol(var)
  j <- is.na(X %*% rep(1, ncol(X)))
  if(any(j)) {
    X       <- X[! j,, drop=FALSE]
    cluster <- cluster[! j, drop=TRUE]
    n       <- length(cluster)
  }

  j <- order(cluster)
  X <- X[j, , drop=FALSE]
  clus.size  <- table(cluster)
  # if(length(clusterInfo)) clusterInfo$n <- length(clus.size)
  clus.start <- c(1, 1 + cumsum(clus.size))
  nc <- length(levels(cluster))
  clus.start <- clus.start[- (nc + 1)]
  storage.mode(clus.start) <- "integer"

  # dyn.load("robcovf.so")
  W <- matrix(.Fortran("robcovf", n, p, nc, clus.start, clus.size, X,
                       double(p), double(p * p), w=double(p * p))$w, nrow=p)

  ##The following has a small bug but comes close to reproducing what robcovf does
  # W <- tapply(X,list(cluster[row(X)],col(X)),sum)
  # W <- t(W) %*% W

  #The following logic will also do it, also at great cost in CPU time
  # W <- matrix(0, p, p)
  # for(j in levels(cluster)){
  #   s <- cluster==j
  #   if(sum(s)==1){
  #     sx <- X[s,,drop=F]
  #   }else {sx <- apply(X[s,,drop=F], 2, sum); dim(sx) <- c(1,p)}
  #   W <- W + t(sx) %*% sx
  # }

  adjvar <- var %*% W %*% var

  return(adjvar)
}

### test ###
if(FALSE) {
# generate longitudinal data
library(mvtnorm)
library(rms)
data_gen <- function(n=100, m=10, b=beta, a0=0.7){
  # correlation matrix - exchangeable structure
  G <- matrix(rep(a0, m*m), nrow=m)
  diag(G) <- 1

  stdevs <- rep(1,m)
  e <- rmvnorm(n, mean = rep(0,m),
               sigma = G * matrix(outer(stdevs, stdevs), nrow=m, byrow=TRUE))

  # x1: gender (0: female, 1: male)
  x1 <- rep(c(rep(0,round(n/2)), rep(1,n-round(n/2))), m)

  # x2: time
  x2 <- rep(c(1:m), each=n)

  y <- b[1] + b[2] * x1 + b[3] * x2 + e

  dat <- data.frame(y=c(y),
                    x1=c(x1),
                    x2=c(x2),
                    id=rep(1:n, m))

  return(dat)
}

# data
dat <- data_gen(n=50, m=10, b=beta, a0=0.7)
# model
mod_orm <- orm(y ~ x1 + x2,
               data = dat,
               x=T, y=T)
# robcov
rob.cov <- robcov(fit = mod_orm,
                  cluster = dat$id)
rob.cov
}


closestPair<-function(x,y)
  {
  distancev <- function(pointsv)
    {
    x1 <- pointsv[1]
    y1 <- pointsv[2]
    x2 <- pointsv[3]
    y2 <- pointsv[4]
    sqrt((x1 - x2)^2 + (y1 - y2)^2)
    }
  pairstocompare <- t(combn(length(x),2))
  pointsv <- cbind(x[pairstocompare[,1]],y[pairstocompare[,1]],x[pairstocompare[,2]],y[pairstocompare[,2]])
  pairstocompare <- cbind(pairstocompare,apply(pointsv,1,distancev))
  minrow <- pairstocompare[pairstocompare[,3] == min(pairstocompare[,3])]
  if (!is.null(nrow(minrow))) {print("More than one point at this distance!"); minrow <- minrow[1,]}
  cat("The closest pair is:\n\tPoint 1: ",x[minrow[1]],", ",y[minrow[1]],
                          "\n\tPoint 2: ",x[minrow[2]],", ",y[minrow[2]],
                          "\n\tDistance: ",minrow[3],"\n",sep="")
  c(distance=minrow[3],x1.x=x[minrow[1]],y1.y=y[minrow[1]],x2.x=x[minrow[2]],y2.y=y[minrow[2]])
  }


conv <- function(a, b) {
	p <- length(a)
	q <- length(b)
	n <- p + q - 1
	r <- nextn(n, f=2)
	y <- fft(fft(c(a, rep(0, r-p))) * fft(c(b, rep(0, r-q))), inverse=TRUE)/r
	y[1:n]
}

deconv <- function(a, b) {
	p <- length(a)
	q <- length(b)
	n <- p - q + 1
	r <- nextn(max(p, q), f=2)
	y <- fft(fft(c(a, rep(0, r-p))) / fft(c(b, rep(0, r-q))), inverse=TRUE)/r
	return(y[1:n])
}


#' Bootstrap Methods
#'
#' @param x numeric vector.
#' @param weights numeric vector of weight
#' @param boot how many bootstrap sample is generated?
#' @param alpha significant value to construct confidential interval
#' @param seed seed value
#' @param bca logical. use bias corrected and accelerated (BCa) bootstrap
#'   to construct confidential intervals.
#'
#' @importFrom stats na.omit
#' @importFrom stats sd
#' @importFrom stats quantile
#' @importFrom stats qnorm
#' @importFrom stats pnorm
#' @examples
#' \dontrun{
#' x <- rnorm(100)
#' bootstrap(x, boot = 1000)
#' }
#'
bootstrap <- function(x,
                      weights,
                      boot = 100,
                      alpha = 0.05,
                      seed = 120511,
                      bca = FALSE) {
  # output list
  output <- list()
  # observation information
  x <- na.omit(x)
  n <- length(x)
  output$n <- n
  if (missing(weights)) weights <- rep(1, n)
  output$mu <- mean(x * weights) / mean(weights)

  # bootstrap
  set.seed(seed)
  bootmu <- lapply(seq_len(boot), function(i) {
    pick <- sample(seq_len(n), size = n, replace = TRUE)
    bx <- x[pick]
    bw <- weights[pick]
    mean(bx * bw) / mean(bw)
  })
  bootmu <- unlist(bootmu)
  output$boot$distribution <- bootmu

  # bootstrap standard error
  output$boot$se <- sd(bootmu)

  # bootstrap CI
  output$boot$ci$alpha <- alpha
  if (!bca) {
    # quantile bootstrap
    output$boot$ci$method <- "quantile"
    output$boot$ci$interval <- quantile(
      bootmu, probs = c(alpha / 2, 1 - alpha / 2)
    )
  } else {
    # Bias corrected and accelerated (BCa) bootstrap
    # reference: https://www.erikdrysdale.com/bca_python/
    output$boot$ci$method <- "BCa"

    # bias-correction factor
    z0 <- qnorm(mean(bootmu < output$mu), lower.tail = TRUE)

    # acceleration factor by jackknife
    jack <- lapply(seq_len(n), function(i) mean(x[-i]))
    jack <- unlist(jack)
    jack_mean <- mean(jack)
    a <- sum((jack_mean - jack)^3) / (6 * sum((jack_mean - jack)^2)^(3 / 2))

    # quantile point of normal distribution
    za1 <- qnorm(alpha, lower.tail = TRUE)
    za2 <- qnorm(1 - alpha, lower.tail = TRUE)
    # bias corrected quantile point
    a1 <- pnorm(
      z0 + (z0 + za1) / (1 - a * (z0 + za1))
    )
    a2 <- pnorm(
      z0 + (z0 + za2) / (1 - a * (z0 + za2))
    )

    output$boot$ci$correction.factor <- z0
    output$boot$ci$acceleration.factor <- a
    output$boot$ci$interval <- quantile(bootmu, probs = c(a1, a2))
  }
  output
}

#' Permutation test
#'
#' @param y numeric vector of outcome
#' @param d numeric vector of treatment indicator (contain 1 and 0 only)
#' @param weights numeric vector of weights
#' @param boot how many re-randomization are generated
#' @param seed seed value
#'
#' @examples
#' \dontrun{
#' y1 <- 2 + rnorm(20, sd = 4)
#' y0 <- rnorm(20, sd = 4)
#' d <- sample(c(1, 0), replace = TRUE, size = 40)
#' y <- ifelse(d == 1, y1, y0)
#' permutation(y, d, boot = 200)
#' }
#'
permutation <- function(y,
                        d,
                        weights,
                        boot = 100,
                        seed = 120511) {
  # check same length of outcome and treatment vector
  if (length(y) != length(d)) stop("Same length of y and d")

  # check binary treatment indicator
  if (!(all(unique(d) %in% c(1, 0)))) {
    stop("d must be binary indicator of treated.")
  }

  # create weight vector if missing
  weights <- rep(1, length(y))

  # check missing values
  na_y <- !is.na(y)
  na_d <- !is.na(d)
  na_w <- !is.na(weights)
  keep <- na_y & na_d & na_w

  # use vector
  y <- y[keep]
  w <- weights[keep]
  d <- d[keep]

  y1 <- y[d == 1]
  y0 <- y[d == 0]
  w1 <- w[d == 1]
  w0 <- w[d == 0]

  # output list
  output <- list()

  # information
  n1 <- sum(d == 1)
  n0 <- sum(d == 0)
  output$treat$N <- n1
  output$control$N <- n0

  mean_y1 <- mean(y1 * w1) / mean(w1)
  mean_y0 <- mean(y0 * w0) / mean(w0)
  obs_diff_mean <- mean_y1 - mean_y0

  output$treat$mean <- mean_y1
  output$control$mean <- mean_y0
  output$ate$estimate <- obs_diff_mean

  # re-randomization
  output$ate$method <- "permutation test"
  set.seed(seed)
  bootdiff <- lapply(seq_len(boot), function(i) {
    sim_treated <- sample(seq_len(n1 + n0), size = n1)
    simd <- rep(0, n1 + n0)
    simd[sim_treated] <- 1

    simy1 <- y[simd == 1]
    simy0 <- y[simd == 0]
    simw1 <- w[simd == 1]
    simw0 <- w[simd == 0]

    sim_mean_y1 <- mean(simy1 * simw1) / mean(simw1)
    sim_mean_y0 <- mean(simy0 * simw0) / mean(simw0)
    sim_mean_y1 - sim_mean_y0
  })
  bootdiff <- unlist(bootdiff)
  output$ate$re.random <- bootdiff

  # exact test
  pval <- mean(abs(bootdiff) >= abs(obs_diff_mean))
  output$ate$p.value <- pval

  output
}


# ......................................................................................
# ................Cvičení 6 - Vybraná rozdělení spojité náhodné veličiny................
# ..................Martina Litschmannová, Adéla Vrtková, Michal Béreš..................
# ......................................................................................

# Nezobrazuje-li se vám text korektně, nastavte File \ Reopen with Encoding... na UTF-8
# Pro zobrazení obsahu skriptu použijte CTRL+SHIFT+O
# Pro spouštění příkazů v jednotlivých řádcích použijte CTRL+ENTER

#  Přehled rozdělení a jejich funkcí ####
# * Úvod: Hustota pravděpodobnosti, Distribuční funkce a Kvantilová funkce ####
# ** Hustota pravděpodobnosti ####
# - začíná písmenkem **d**: p = d...(x, ...)
#
# ** Distribuční funkce ####
# - začíná písmenkem **p**: $p = P(X < x)$: p = p...(x, ...)
#
# ** Kvantilová funkce ####
# - začíná písmenkem **q**:  najdi x pro zadané p: $p = F(x) \rightarrow x = F^{-1}(p)$:
# x = q...(p, ...)

# * Rovnoměrné rozdělení: $X \sim Ro(a, b)$ ####
# - náhodná veličina nabývá pouze hodnot větších než a a menších než b
# - všechny hodnoty mají stejnou hustotu výskytu -> hustota pravděpodobnosti je
# konstantní mezi a a b, jinde nulová

# Hustota pravděpodobnosti f(x)
a = 2   # odkud
b = 4   # kam
x = 3
dunif(x, a, b)

# vykreslíme si Hustotu pravděpodobnosti
x = seq(from = 0, to = 6, by = 0.01)
f_x = dunif(x, a, b)
plot(x, f_x, cex = 0.1) # cex je velikost markerů
grid()

# Distribuční funkce F(x) = P(X < x)
a = 2   # odkud
b = 4   # kam
x = 3
punif(x, a, b)

# vykreslíme si Distribuční funkci
x = seq(from = 0, to = 6, by = 0.01)
F_x = punif(x, a, b)
plot(x, F_x, type = 'l')
grid()

# kvantilová funkce F^(-1)(p) = x: P(X<x)=p
a = 2   # odkud
b = 4   # kam
p = 0.75
qunif(p, a, b)

# vykreslení - kvantilová funkce F^(-1)(p) = x
p = seq(from=0, to=1, by=0.01)
x = qunif(p, a, b)
plot(p, x, type = 'l')
grid()

# * Exponenciální rozdělení: $X \sim Exp(\lambda)$ ####
# - doba do 1. události, doba mezi událostmi (pouze v období stabilního života -
# Poissonův proces)
# - parametr $\lambda$ je tentýž co v Poissonově rozdělení
# - střední hodnota je: $E(X)=1 / \lambda$

# Hustota pravděpodobnosti f(x)
lambda = 2
x = 1
dexp(x, lambda)

# vykreslíme si Hustotu pravděpodobnosti
x = seq(from = 0, to = 6, by = 0.01)
f_x = dexp(x, lambda)
plot(x, f_x, type='l')
grid()

# Distribuční funkce F(x) = P(X < x)
lambda = 2
x = 1
pexp(x, lambda)

# vykreslíme si Distribuční funkci
x = seq(from = 0, to = 6, by = 0.01)
F_x = pexp(x, lambda)
plot(x, F_x, type = 'l')
grid()

# kvantilová funkce F^(-1)(p) = x: P(X<x)=p
lambda = 2
p = 0.5
qexp(p, a, b)

# vykreslení - kvantilová funkce F^(-1)(p) = x
p = seq(from=0, to=1, by=0.001)
x = qexp(p, lambda)
plot(p, x, type = 'l')
grid()

# * Weibullovo rozdělení: $X \sim W(\theta,\beta)$ ####
# - doba do 1. události (poruchy)(vhodná volba β umožuje použití v libovolném období
# intenzity poruch)
# - rozšíření exponenciálního rozdělení Exp(λ) = W(Θ=1/λ, β=1)

# Hustota pravděpodobnosti f(x)
theta = 1/2 # ekvivalent 1/lambda u exp. rozdělení
beta = 1  # beta = 1 -> exponenciální rozdělení
x = 5
dweibull(x,shape=beta, scale=theta)

# vykreslíme si Hustotu pravděpodobnosti
x = seq(from = 0, to = 6, by = 0.01)
f_x = dweibull(x,shape=beta, scale=theta)
plot(x, f_x, type='l')
grid()

# Distribuční funkce F(x) = P(X < x)
theta = 3 # ekvivalent 1/lambda u exp. rozdělení
beta = 2  # beta = 1 -> exponenciální rozdělení
x = 5
pweibull(x,shape=beta, scale=theta)

# vykreslíme si Distribuční funkci
x = seq(from = 0, to = 6, by = 0.01)
F_x = pweibull(x,shape=beta, scale=theta)
plot(x, F_x, type = 'l')
grid()

# kvantilová funkce F^(-1)(p) = x: P(X<x)=p
theta = 3 # ekvivalent 1/lambda u exp. rozdělení
beta = 2  # beta = 1 -> exponenciální rozdělení
p = 0.5
qweibull(p,shape=beta, scale=theta)

# vykreslení - kvantilová funkce F^(-1)(p) = x
p = seq(from=0, to=1, by=0.01)
x = qweibull(p,shape=beta, scale=theta)
plot(p, x, type = 'l')
grid()

# * Normální rozdělení: $X \sim N(\mu,\sigma^2)$ ####
# - rozdělení modelující např. chyby měření, chování součtu/průměru mnoha jiných
# náhodných veličin
# - viz. Centrální limitní věta
# - $\mu$ je přímo střední hodnota rozdělení: $E(X)=\mu$
# - $\sigma$ je přímo směrodatná odchyla rozdělení: $D(X)=\sigma^2$
# - s parametry $\mu=0,\sigma=1$ se nazývá normované Normální rozdělení

# Hustota pravděpodobnosti f(x)
mu = 2
sigma = 3
x = 4
dnorm(x, mean=mu, sd=sigma)

# vykreslíme si Hustotu pravděpodobnosti
x = seq(from = -5, to = 10, by = 0.01)
f_x = dnorm(x, mean=mu, sd=sigma)
plot(x, f_x, type='l')
grid()

# Distribuční funkce F(x) = P(X < x)
mu = 2
sigma = 3
x = 4
pnorm(x, mean=mu, sd=sigma)

# vykreslíme si Distribuční funkci
x = seq(from = -5, to = 10, by = 0.01)
F_x = pnorm(x, mean=mu, sd=sigma)
plot(x, F_x, type = 'l')
grid()

# kvantilová funkce F^(-1)(p) = x: P(X<x)=p
mu = 2
sigma = 3
p = 0.5
qnorm(p, mean=mu, sd=sigma)

# vykreslení - kvantilová funkce F^(-1)(p) = x
p = seq(from=0, to=1, by=0.01)
x = qnorm(p, mean=mu, sd=sigma)
plot(p, x, type = 'l')
grid()

#  Příklady ####

# * Příklad 1. ####
# Výška v populaci chlapců ve věku 3,5-4 roky má normální rozdělení se střední hodnotou
# 102 cm a směrodatnou odchylkou 4,5 cm. Určete, jaké procento chlapců v uvedeném věku
# má výšku menší nebo rovnou 93 cm.

# X ... výška chlapců ve věku 3.5 až 4 roky (cm)
# X ~ N(mu = 102, sd = 4.5)

mu = 102
sigma = 4.5

# P(X<=93)=F(93)
pnorm(93, mean=mu, sd=sigma)

# * Příklad 2. ####
# Průměrná životnost strojní součástky je 30 000 hodin. Předpokládejme, že součástka je
# v období
# stabilního života. Určete:

# X ... životnost součástky (h)
# X ~ Exp(lambda), kde E(X)=1/lambda

lambda = 1/30000

# ** a) ####
# pravděpodobnost, že součástka nevydrží více než 2 000 hodin,

#a) P(X<2000)=F(2000)
pexp(2000, lambda)

# ** b) ####
# pravděpodobnost, že součástka vydrží více než 35 000 hodin,

#b) P(X>35000)=1-F(35000)
1 - pexp(35000, lambda)

# ** c) ####
#  dobu, do níž se porouchá 95 % součástek.

#c) P(X<t)=0,95 -> F(t)=0,95 -> t… 95% kvantil
qexp(0.95, lambda)

# * Příklad 3. ####
# Výrobní zařízení má poruchu v průměru jednou za 2000 hodin. Veličina Y představující
# dobu čekání na poruchu má exponenciální rozdělení. Určete dobu T0 tak, aby
# pravděpodobnost, že přístroj bude pracovat delší dobu než T0, byla 0,99.

# X ... doba čekání na poruchu (h)
# X ~ Exp(lambda), kde E(X)=1/lambda
lambda = 1/2000

#P(X>t)=0,99 -> 1-F(t)=0,99 -> F(t)=0,01 -> t… 1% kvant.
qexp(0.01, lambda)

# * Příklad 4. ####
# Výsledky měření jsou zatíženy jen normálně rozdělenou chybou s nulovou střední
# hodnotou a se směrodatnou odchylkou 3 mm. Jaká je pravděpodobnost, že při 3 měřeních
# bude alespoň jednou chyba v intervalu (0 mm; 2,4mm)?

# Y… velikost chyby měření (mm)
# Y ~ N(mu = 0,sigma = 3)

mu = 0
sigma = 3

# pp… pravd., že chyba měření bude v int. 0,0-2,4mm
pp = pnorm(2.4,mean=mu,sd=sigma) - pnorm(0,mean=mu,sd=sigma)
pp

# X … počet chyb měření v int. 0 mm -2,4 mm ve 3 měř.
# X ~ Bi(n = 3,p = pp)
n = 3
p = pp

# P(X>=1)=1-P(X=0)
1 - dbinom(0, n, p)

# * Příklad 5. ####
# Ve velké počítačové síti se průměrně přihlašuje 25 uživatelů za hodinu. Určete
# pravděpodobnost,
# že:
# ** a)  ####
# se nikdo nepřihlásí během 14:30 - 14:36,

# X … počet uživatelů přihlášených za 6 minut
# X ~ Po(lt = 2.5)

lambda = 25/60
t = 6
lt = lambda*t

# P(X=0)
dpois(0, lt)

# ** b)  ####
# do dalšího přihlášení uběhnou 2-3 minuty.

# Y … doba do dalšího přihlášení
# Y ~ Exp(lambda = 25/60), kde E(X)=1/lambda
lambda = 25/60

# P(2<Y<3)=F(3)-F(2)
pexp(3, lambda) - pexp(2, lambda)

# ** c) ####
# Určete maximální délku časového intervalu tak, aby pravděpodobnost, že se nikdo
# nepřihlásí byla alespoň 0,90.

# P(Y>t)=0,90 -> 1-F(t)=0,90 -> F(t)=0,10 -> t…10% kv.

qexp(0.10, lambda)*60

# * Příklad 6. ####
# Náhodná veličina X má normální rozdělení N(µ; σ). Určete:
# ** a) ####
# P(µ − 2σ < X < µ + 2σ),

# P(µ − 2σ < X < µ + 2σ) = F(µ + 2σ) - F(µ - 2σ)
# X~N(µ,σ)
# je jedno jaké hodnoty zvolíme
mu = -105.5447
sigma = 2.654

pnorm(mu + 2*sigma, mean=mu, sd=sigma) -
pnorm(mu - 2*sigma, mean=mu, sd=sigma)

# ** b) ####
# nejmenší k ∈ Z, tak, aby P(µ − kσ < X < µ + kσ) > 0,99.

# normální rozdělení je symetrické
# P(µ − kσ < X < µ + kσ) =
# = 1 - (P(X < µ − kσ ) + P(X > µ + kσ)) =
# = 1 - 2*P(X > µ + kσ) = 0.99 -> P(X > µ + kσ) = 0.005
# -> P(X < µ + kσ) = 0.995

# x = µ + kσ
x = qnorm(0.995, mean=mu, sd=sigma)
(x - mu)/sigma

for(k in 1:5){
    p = pnorm(mu + k*sigma, mean=mu, sd=sigma) -
        pnorm(mu - k*sigma, mean=mu, sd=sigma)
    print(paste0(k,":",p))
}

# * Příklad 7. ####
# Na prohlídce výstavy je promítán doprovodný film o životě autora vystavovaných děl.
# Jeho projekce začíná každých 20 minut. Určete pravděpodobnost, že pokud náhodně
# přijdete do promítacího sálu,

# Y … doba do začátku další projekce
# Y ~ Ro(a=0, b=20)

a = 0
b = 20

# ** a) ####
# nebudete na začátek filmu čekat víc než 5 minut,

# P(X<5)
punif(5, a, b)

# ** b) ####
# budete čekat mezi 5 a 10 minutami,

# P(5<X<10)
punif(10, a, b) - punif(5, a, b)

# ** c) ####
# střední hodnotu a směrodatnou odchylku doby čekání na začátek filmu.

E_X = (a + b)/2
E_X

D_X = (a - b)^2/12
D_X

sigma_X = sqrt(D_X)
sigma_X

# * Příklad 8. ####
# Při kontrole jakosti přebíráme součástku pouze tehdy, jestliže se její rozměr pohybuje
# v mezích 26-27 mm. Rozměry součástek mají normální rozdělení se střední hodnotou 26,4
# mm a směrodatnou odchylkou 0,2 mm. Jaká je pravděpodobnost, že rozměr součástky
# náhodně vybrané ke kontrole bude v požadovaných mezích?

# X ... rozměr součástky (mm)
# X ~ N(mu =  26.4,sigma = 0.2)

mu = 26.4
sigma = 0.2

#P(26<X<27)=F(27)-F(26)
pnorm(27, mean=mu, sd=sigma) - pnorm(26, mean=mu, sd=sigma)

# * Příklad 9. ####
# Délka skoků sportovce Jakuba měřená v cm má normální rozdělení N(µ1; σ1), kde µ1 = 690
# a σ1 = 10. Délka skoků sportovce Aleše měřená v cm má také normální rozdělení N(µ2;
# σ2), kde µ2 = 705 a σ2 = 15. Na závody se kvalifikuje ten, kdo ze dvou skoků alespoň
# jednou skočí více než 700 cm.

# SJ ... délka skoku Jakuba
# SJ ~ N(mu = 690,sigma = 10)
mu_J = 690
sigma_J = 10

# SA … délka skoku Aleše
# SA ~ N(mu = 705,sigma = 15)
mu_A = 705
sigma_A = 15

# J...Jakubův skok je úspěšný (delší než 700 cm)
# A...Alešův skok je úspěšný (delší než 700 cm)

# P(J)=P(SJ>700)=1-F(700)
P.J = 1-pnorm(700,mean=mu_J,sd=sigma_J)
P.J

# P(A)=P(SA>700)=1-F(700)
P.A = 1-pnorm(700,mean=mu_A, sd=sigma_A)
P.A

# KJ … Jakub se kvalifikuje na závody,
# P(KJ) = 1-(1-P(J))(1-P(J))
P.KJ=1-(1-P.J)*(1-P.J)
P.KJ

# KA … Aleš se kvalifikuje na závody,
# P(KA) = 1-(1-P(A))(1-P(A))
P.KA=1-(1-P.A)*(1-P.A)
P.KA

# ** a) ####
# S jakou pravděpodobností se oba dva kvalifikují na závody?

# ada)
P.KJ*P.KA

# ** b) ####
# S jakou pravděpodobností se kvalifikuje Aleš, ale Jakub ne?

# adb)
(1-P.KJ)*P.KA


queens <- function(n) {
  a <- seq(n)
  u <- rep(T, 2 * n - 1)
  v <- rep(T, 2 * n - 1)
  m <- NULL
  aux <- function(i) {
    if (i > n) {
      m <<- cbind(m, a)
    } else {
      for (j in seq(i, n)) {
        k <- a[[j]]
        p <- i - k + n
        q <- i + k - 1
        if (u[[p]] && v[[q]]) {
          u[[p]] <<- v[[q]] <<- F
          a[[j]] <<- a[[i]]
          a[[i]] <<- k
          aux(i + 1)
          u[[p]] <<- v[[q]] <<- T
          a[[i]] <<- a[[j]]
          a[[j]] <<- k
        }
      }
    }
  }
  aux(1)
  m
}


#######################################################################
#######################################################################
#######################################################################
######                                                           ######
######      Routines for simulation of high-dimensionsal         ######
######                   multivariate normals                    ######
######                                                           ######
#######################################################################
#######################################################################
rbigmvn.setup <- function(mu,covfunc,covpars,Sigmalist,coords,
                          groups,neighbours,nNN,MaxDist,coord.type,
                          method="Gibbs",vars.to.monitor) {
#######################################################################
#
#   To set up the quantities required to simulate from a
#   high-dimensional multivariate normal distribution using
#   routine rbigmvnorm. Arguments:
#
#   mu        mean vector of the distribution
#   covfunc   Name of a function to compute covariances between
#             pairs of points. This function itself should have
#             two arguments: the first a vector of parameters,
#             and the second a matrix of "co-ordinates" or
#             covariates. Denoting the parameter vector by theta,
#             and the co-ordinates for variable i by x[i], the
#             covariance between variables i and j can be
#             computed as f(x[i],x[j],theta). It should return a
#             matrix of covariances. Note that the argument
#             "Sigmalist" (see below) offers an alternative
#             way to define the covariance structure.
#   covpars   Vector of parameters for the covariance function
#   coords    Matrix giving the "coordinates" or covariate values
#             for each variable, for use when evaluating the
#             covariance function. Row i corresponds to variable
#             i; the number of rows should match the length of mu.
#   groups    A numeric vector, the same length as mu, containing group
#             numbers. Variables in the same group will be simulated
#             as a block within each Gibbs sampler iteration. If
#             there are M groups then they must be numbered from
#             1 to M.
#   neighbours  A list of M vectors, where M is the number of groups.
#             The jth element of this list should be a vector of
#             indices for the variables that are not in group j but
#             are in its neighbourhood. This argument should not
#             be supplied if either nNN or MaxDist is provided;
#             but it must be supplied if neither of these is provided.
#   nNN       Optional scalar, giving the number of nearest neighbours
#             to include in the neighbourhood of each group. If supplied,
#             then distfunc must also be supplied; and neither
#             neighbours nor MaxDist should be supplied. Conversely,
#             if this is not supplied then either neighbours or
#             MaxDist must be supplied
#   MaxDist   Optional scalar, or vector of length M (number of groups)
#             giving the maximum distance to consider as being within
#             the neighbourhood of each group. A variable will be
#             considered as in the neighbourhood of a group if it is
#             within MaxDist of at least one site in the group, but
#             not otherwise. If this argument is supplied, then
#             distfunc must also be supplied; and neither neighbours
#             nor nNN should be supplied. Conversely, if this is not
#             supplied then either neighbours or nNN must be supplied
#   Sigmalist An optional list of covariance matrices, with length M
#             where M is the total number of groups. This should not
#             be used if cov.func is supplied. If provided, its jth
#             element should be the covariance matrix of all pairs of
#             variables within both group j and its neighbours (as defined
#             via the "neighbours" argument, which must therefore be
#             provided in this case). The ordering of variables in
#             this matrix must correspond with that in the full joint
#             distribution (i.e. it consists of the rows and columns
#             of the full covariance matrix corresponding to the
#             current group and its neighbours).
#             Note that the routine does *not* check that the elements
#             of the list are in mutual agreement (for example, that
#             the supplied covariance between any pair of sites is the
#             same for all groups where that pair appears). It is the
#             user's responsibility to check this, therefore.
#   coord.type  Either "geographical" (if coords is a two-column
#             matrix containing latitudes and longitudes - NB in
#             this case the first column should be latitude) or
#             "euclidean". This controls how distances between
#             variables are calculated.
#   method    Either "Gibbs" or "factorize". If "Gibbs", the routine
#             will set things up for a Gibbs sampler; if "factorize"
#             then it will set things up so that simulation is done
#             in a single pass (no iteration) using factorisation of
#             the full joint distribution into products of conditionals.
#             The latter is potentially quicker, but this increase in
#             speed may be offset by the need to specify considerably
#             larger neighbourhoods in order to achieve the same
#             level of accuracy.
#   vars.to.monitor   An optional vector of indices in the range
#             1:length(mu). If provided, the routine will
#             calculate the quantities needed to produce a trace
#             plot of the logarithm of the joint density of the
#             corresponding variables during random variate
#             generation when method="Gibbs". This allows
#             convergence monitoring.
#
# Note that if neighbourhoods are defined using nNN or MaxDist, it
# becomes necessary to calculate all of the pairwise intersite distances,
# which has a computational cost quadratic in the number of sites ...
#
#######################################################################
#
#   Checks on inputs and set up storage for results
#
  p <- length(mu)
  if (!is.matrix(coords)) stop("coords must be a matrix")
  if (nrow(coords) != p) {
    stop("coords has wrong number of rows - should be length(mu)")
  }
  if (length(groups) != p) stop("groups should have same length as mu")
  M <- max(groups)
  if (!all(sort(unique(groups))==1:M)) {
    stop("groups should be numbered from 1 to M where M is total number of groups")
  }
  if (missing(covfunc)) {
    if (missing(Sigmalist)) stop("Either covfunc or Sigmalist must be supplied")
  } else {
    if (!is.function(covfunc)) stop("covfunc should be the name of a function")
  }
  if (as.numeric(missing(neighbours))+as.numeric(missing(nNN))+
        as.numeric(missing(MaxDist)) != 2) {
    stop("You must provide exactly one of neighbours, nNN and MaxDist")
  }
  if (!missing(neighbours)) {
    if (!is.list(neighbours)) stop("neighbours must be a list")
    if (length(neighbours) != M) {
      stop("neighbours must have a list element for each group")
    }
  }
  if (!missing(nNN)) {
    if (!(length(nNN) %in% c(1,M))) {
      stop("nNN must be either a scalar, or a vector with an element for each group")
    }
  }
  if (!missing(MaxDist)) {
    if (!(length(MaxDist) %in% c(1,M))) {
      stop("MaxDist must be either a scalar, or a vector with an element for each group")
    }
  }
  if (!missing(Sigmalist)) {
    if (!missing(covfunc)) stop("Only one of covfunc and Sigmalist can be specified")
    if (missing(neighbours)) stop("'neighbours' must be specified when using 'Sigmalist'")
    if (length(Sigmalist) != M) stop("Length of Sigmalist doesn't match number of groups")
  }
  if (coord.type=="geographical") {
    distfunc <- howfar
  } else if (coord.type=="euclidean") {
    distfunc <- function(coords1,coords2) {
      sqrt(outer(coords1[,1],coords2[,1],"-")^2 +
             outer(coords1[,2],coords2[,2],"-")^2)
    }
  } else {
    stop("coord.type must be either 'geographical' or 'euclidean'")
  }
  cat(paste("Tested all inputs and these are ok\n"))

  group.details <- matrix(0,nrow=M,ncol=p)
  Sig12.Sig22Inv <- CondCovChol <- vector("list",M)
#
#   Set up neighbourhood structures for each group
#
  for (i in 1:M) {
    cat(paste("Working on block",i,"of",M,"...                \n"))
    group.details[i,groups==i] <- 1 # in network stations=1
    if (!missing(neighbours)) {
      tmp <- neighbours[[i]]
      tmp <- tmp[!(tmp %in% (1:p)[groups==i])] # double check no neighbours are actual stations?
      group.details[i,tmp] <- 2 # network neighbours =2?
    }
    if (!missing(nNN)) {
      nNN.cur <- nNN
      if (length(nNN) > 1) nNN.cur <- nNN[i]
      dist.cur <- distfunc(coords[groups==i,],coords[groups!=i,])
      min.dist <- apply(dist.cur,MARGIN=2,FUN=min)
      wanted.sites <- order(min.dist)[1:nNN.cur]
      tmp <- (1:p)[groups!=i]
      group.details[i,tmp[wanted.sites]] <- 2
    }
    if (!missing(MaxDist)) {
      MD.cur <- MaxDist
      if (length(MaxDist) > 1) MD.cur <- MaxDist[i]
      dist.cur <- distfunc(coords[groups==i,],coords[groups!=i,])
      wanted.sites <- (dist.cur <= MD.cur)
      tmp <- (1:p)[groups!=i]
      group.details[i,tmp[wanted.sites]] <- 2
    }
#
#   Now set up the components of the partitioned covariance matrix, and
#   required Choleski factors. The variables to condition on are the ones
#   that are in the neighbourhood of the current group and, if method
#   method="factorize", that are also in lower-numbered groups (because
#   these will already have been allocated by the time we get to the
#   current group).
#

# Use this whereever you want to stop with access to variables
#    browser()

    if (method=="Gibbs") {
      wanted.vars <- (group.details[i,]>0)
    } else if (method=="factorize") {
      wanted.vars <- (group.details[i,]>0 & groups <= i)
    } else {
      stop("method must be either 'Gibbs' or 'factorize'")
    }
    if (missing(Sigmalist)) {
      Sigma <- covfunc(covpars,coords[wanted.vars,])
    } else {
      Sigma <- Sigmalist[[i]]

      if (nrow(Sigma) != sum(group.details[i,]>0)) {
        stop(paste("Dimensions of Sigmalist[[",i,
                   "]] don't match required number of variables",sep=""))
      }
      if (method=="factorize") {                     # Get rid of elements for
        tmp <- (groups[group.details[i,]>0] <= i)    # groups that haven't been
        Sigma <- matrix(Sigma[tmp,tmp],
	         nrow=length(which(tmp==TRUE)),
		 ncol=length(which(tmp==TRUE)))                      # done yet
      }
    }
#    cat(paste("Now in the block and working on Sigma",i,"\n",sep=""))

    tmp <- group.details[i,wanted.vars]
#    Sig11 <- matrix(Sigma[tmp==1,tmp==1],nrow=length(which(tmp==1)),ncol=length(which(tmp==1)))
#    Sig12 <- matrix(Sigma[tmp==1,tmp==2],nrow=length(which(tmp==1)),ncol=length(which(tmp==1)))
#    Sig22 <- matrix(Sigma[tmp==2,tmp==2],nrow=length(which(tmp==1)),ncol=length(which(tmp==1)))
    Sig11 <- Sigma[tmp==1,tmp==1]
    Sig12 <- Sigma[tmp==1,tmp==2]
    Sig22 <- Sigma[tmp==2,tmp==2]
    	# for first few there may be no neighbours
#    print(tmp)
    #print(length(tmp))
#    if (nrow(Sig22)>0) {
    if (length(which(tmp==2))>0) {
      Sig12.Sig22Inv[[i]] <- Sig12 %*% solve(Sig22)
      CondCovChol[[i]] <- chol(Sig11 - tcrossprod(Sig12.Sig22Inv[[i]],Sig12))
    } else {
      CondCovChol[[i]] <- chol(Sig11)
    }
  }
#
# Choleski factor of inverse of covariance matrix for monitoring
# locations
#
  if (!missing(vars.to.monitor)) {
    if (!(method == "Gibbs")) {
      warning("argument vars.to.monitor is only used when method='Gibbs'")
      SigInvChol <- NULL
      vtm <- NULL
    } else {
      Sigma <- covfunc(covpars,coords[vars.to.monitor,])
      SigInvChol <- solve(chol(Sigma))
      vtm <- vars.to.monitor
    }
  } else {
    SigInvChol <- NULL
    vtm <- NULL
  }
  invisible(list(mu=mu,groups=groups,group.details=group.details,
                 Sig12.Sig22Inv=Sig12.Sig22Inv,CondCovChol=CondCovChol,
                 SigInvChol=SigInvChol,method=method,vars.to.monitor=vtm))
}
#######################################################################
#######################################################################
#######################################################################
rbigmvnorm <- function(n,setup,nburnin=0,nthin=1,init,monitor=FALSE) {
#######################################################################
#
#   To simulate from a high-dimensional multivariate normal
#   distribution. Arguments:
#
#   n         Number of realisations required
#   setup     A list object containing all of the information
#             required to carry out the simulation. This
#             should be produced via a call to rbigmvn.setup
#   nburnin   Number of Gibbs Sampler iterations to use as "burnin".
#             Only used if setup$method="Gibbs".
#   nthin     Thinning rate for the sampler after the burnin period:
#             the n returned values will correspong to iterations
#             nburnin+nthin, nburnin+(2*nthin), ... , nburnin+(n*nthin)
#             Only used if setup$method="Gibbs".
#   init      Starting value for the Gibbs sampler. If supplied,
#             this can be used (for example) to generate further
#             draws from a chain that is already known to have
#             converged to its limiting distribution, thereby
#             eliinating the need for any further burnin.
#             Only used if setup$method="Gibbs".
#   monitor   A logical scale indicated whether to produce a
#             trace plot of the logarithm of the joint density
#             for the variables defined by setup$vars.to.monitor.
#             The purpose is to assess convergence of the Gibbs
#             sampler. To produce the plot *does* slow down the
#             iterations, however. Only used if setup$method="Gibbs".
#
#######################################################################
  p <- length(setup$mu)
  M <- nrow(setup$group.details)
  if (!missing(init)) {
    if (length(init) != p) stop("Lengths of 'init' and 'mu' don't match")
  }
  if (monitor & is.null(setup$vars.to.monitor)) {
    warning("No monitoring variables defined - trace plot will not be produced")
    monitor <- FALSE
  }
  sim <- matrix(nrow=n,ncol=p)
#
# Initialisation if we're using a Gibbs sampler
#
  if (setup$method=="Gibbs") {
    logL <- rep(0,nburnin+(n*nthin))
    ntt <- nthin
    if (missing(init))  {
      cat("Initialising Gibbs sampler ...                           \r")
      z <- rep(NA,p)
      for (i in 1:M) {
        wanted <- (setup$groups==i)
        e <- rnorm(sum(wanted))
        z[wanted] <- setup$mu[wanted] + (setup$CondCovChol[[i]] %*% e)
      }
    } else {
      z <- init
    }
#
# Burnin for Gibbs sampler
#
    for (iter in (if (nburnin < 1) NULL else 1:nburnin)) {
      cat(paste("Gibbs sampler burnin period: iteration",iter,"of",nburnin,"...\r"))
      for (i in 1:M) {
        wanted <- (setup$groups==i)
        mu1 <- setup$mu[wanted]
        y2 <- z[setup$group.details[i,]==2]
        mu2 <- setup$mu[setup$group.details[i,]==2]
        e <- rnorm(length(mu1))
        z[wanted] <- mu1 + (setup$Sig12.Sig22Inv[[i]] %*% (y2-mu2)) +
          t(setup$CondCovChol[[i]]) %*% e
      }
      if (monitor) {
        logL[iter] <- -sum((t(setup$SigInvChol) %*%
                              (z[setup$vars.to.monitor]-
                                 setup$mu[setup$vars.to.monitor]))^2)/2
      }
    }
    if (monitor) {
      pp <- 1/(nburnin+(nthin*n))
      ylim <- -0.5*qchisq(c(pp,1-pp),df=length(setup$vars.to.monitor))
      if (nburnin > 0) ylim <- c(ylim,logL[1:nburnin])
      ylim <- extendrange(ylim)
      plot(1:(nburnin+(nthin*n)),type="n",xlab="Iteration",ylab="Score",
           main="Gibbs sampler iterations: log-density score for monitoring variables",
           ylim=ylim)
      abline(v=nburnin,col="red")
      if (nburnin > 0) lines(1:nburnin,logL[1:nburnin])
    } else {
      ntt <- 1
    }
  }

  for (cur.sim in 1:n) {
    cat(paste("Generating sample",cur.sim,"of",n,"...               \r"))
    if (setup$method == "factorize") z <- rep(NA,p)
    for (iter in 1:nthin) {
      for (i in 1:M) {
        wanted <- (setup$groups==i)
        mu1 <- setup$mu[wanted]
        e <- rnorm(length(mu1))
        if (setup$method=="Gibbs") {
          cond.vars <- (setup$group.details[i,]==2)
        } else if (setup$method=="factorize") {
          cond.vars <- (setup$group.details[i,]==2) & (setup$groups < i)
        }
        if (sum(cond.vars) > 0) {
          y2 <- z[cond.vars]
          mu2 <- setup$mu[cond.vars]
          z[wanted] <- mu1 + (setup$Sig12.Sig22Inv[[i]] %*% (y2-mu2)) +
            t(setup$CondCovChol[[i]]) %*% e
        } else {
            z[wanted] <- mu1 + t(setup$CondCovChol[[i]]) %*% e
        }
      }
      if (monitor & setup$method=="Gibbs") {
        cur.idx <- nburnin + ((cur.sim-1)*ntt) + iter
        logL[cur.idx] <- -sum((t(setup$SigInvChol) %*%
                                 (z[setup$vars.to.monitor]-
                                    setup$mu[setup$vars.to.monitor]))^2)/2
        if (cur.idx > 1) lines(c(cur.idx-1,cur.idx),logL[c(cur.idx-1,cur.idx)])
      }
    }
    sim[cur.sim,] <- z
  }
  sim
}
######################################################################
######################################################################
######################################################################
howfar <- function(sites1,sites2,units="km") {
######################################################################
#
# Function to calculate the distance between sets of points on the
# earth's surface, with co-ordinates given in latitude and longitude.
# Arguments:
#
# sites1  A matrix with 2 columns, indicating the (lat, long)
#		coordinates of each site in the first set (in
#		degrees!)
# sites2	The same for the second set of sites
# units		Either "km" (the default) or "nm" for distances in
#		nautical miles (*not* nanometers!)
#
# Value:	A matrix of distances, with rows corresponding to
#		the sites in sites1 and columns corresponding to
#		those in sites2. If sites1 and sites2 have row names,
#		these are copied over as appropriate
######################################################################
  n1 <- dim(sites1)[1]; n2 <- dim(sites2)[1]
  z <- matrix(nrow=n1,ncol=n2)
  rownames(z) <- rownames(sites1)
  colnames(z) <- rownames(sites2)
  pi180 <- pi/180
  for (i in 1:n1) {
    lat1 <- sites1[i,1]
    long1 <- sites1[i,2]
    lat2 <- sites2[,1]
    long2 <- sites2[,2]
    z[i,] <- sin(sites1[i,1]*pi180)*sin(sites2[,1]*pi180) +
             cos(sites1[i,1]*pi180)*cos(sites2[,1]*pi180) *
             cos((sites2[,2]-sites1[i,2])*pi180)
#
#   Next line deals with rounding errors that take the previous
#   line slightly outside the range (-1,1)
#
    z[i,] <- (60*180/pi)*acos(pmax(pmin(z[i,],1),-1))
  }
  if (units == "km") {
    z <- 1.852*z
  } else if (units != "nm") {
    stop("units must be either 'km' or 'nm'")
  }
  z
}


# Name: Barnabas Forgo
# Email: psybf@nottingham.ac.uk
# Student ID: 4211949

require(FuzzyToolkitUoN);
require(rgl);

fis1 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, trapMF(   "low", c(0:10), c(0, 0, 1, 3, 1)));
  fis= addMF(fis, "input", 2, trapMF(  "mild", c(0:10), c(1, 4, 6, 9, 1)));
  fis= addMF(fis, "input", 2, trapMF("severe", c(0:10), c(7, 9, 10, 10, 1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(15, 0, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(15, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(15, 100, 1)));

  rulelist = rbind(
    c(1,4,3,1,1), # IF temperature is very low THEN urgency is emergency
    c(2,4,2,1,1), # IF temperature is low THEN urgency is medium
    c(3,4,1,1,1), # IF temperature is normal THEN urgency is very low
    c(4,4,2,1,1), # IF temperature is high THEN urgency is medium
    c(5,4,3,1,1) # IF temperature is very high THEN urgency is emergency
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis2 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, trapMF(   "low", c(0:10), c(0, 0, 1, 3, 1)));
  fis= addMF(fis, "input", 2, trapMF(  "mild", c(0:10), c(1, 4, 6, 9, 1)));
  fis= addMF(fis, "input", 2, trapMF("severe", c(0:10), c(7, 9, 10, 10, 1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(15, 0, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(15, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(15, 100, 1)));

  rulelist = rbind(
    c(1,4,3,1,1),

    c(2,1,1,1,1),
    c(2,2,2,1,1),
    c(2,3,3,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,2,1,1),

    c(4,1,1,1,1),
    c(4,2,2,1,1),
    c(4,3,3,1,1),

    c(5,4,3,1,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis3 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, gaussMF(   "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 2, gaussMF(        "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 2, gaussMF(     "medium", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 2, gaussMF(     "severe", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 2, gaussMF("very severe", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(15, 0, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(15, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(15, 100, 1)));

  rulelist = rbind(
    c(1,6,3,1,1),

    c(2,1,1,1,1),
    c(2,2,1,1,1),
    c(2,3,2,1,1),
    c(2,4,2,1,1),
    c(2,5,3,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,1,1,1),
    c(3,4,2,1,1),
    c(3,5,2,1,1),

    c(4,1,1,1,1),
    c(4,2,1,1,1),
    c(4,3,2,1,1),
    c(4,4,2,1,1),
    c(4,5,3,1,1),

    c(5,6,3,1,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis4 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, gaussMF(   "very low", c(0:10), c(1, 0,  1)));
  fis= addMF(fis, "input", 2, gaussMF(        "low", c(0:10), c(1, 2.5, 1)));
  fis= addMF(fis, "input", 2, gaussMF(     "medium", c(0:10), c(1, 5,  1)));
  fis= addMF(fis, "input", 2, gaussMF(     "severe", c(0:10), c(1, 7.5, 1)));
  fis= addMF(fis, "input", 2, gaussMF("very severe", c(0:10), c(1, 10,  1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF( "very low", c(0:100), c(10, 0, 1)));
  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(10, 25, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(10, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF(     "high", c(0:100), c(10, 75, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(10, 100, 1)));

  rulelist = rbind(
    c(1,6,5,1,1),

    c(2,1,1,1,1),
    c(2,2,1,1,1),
    c(2,3,2,1,1),
    c(2,4,3,1,1),
    c(2,5,4,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,1,1,1),
    c(3,4,2,1,1),
    c(3,5,4,1,1),

    c(4,1,1,1,1),
    c(4,2,1,1,1),
    c(4,3,2,1,1),
    c(4,4,3,1,1),
    c(4,5,4,1,1),

    c(5,6,5,1,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis5 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, -1, 1.5)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 8, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 11, 1.5)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, triMF(   "very low", seq(0, 10, by=0.1), c(0,0,2.5,1)));
  fis= addMF(fis, "input", 2, triMF(        "low", seq(0, 10, by=0.1), c(0,2.5,5,1)));
  fis= addMF(fis, "input", 2, triMF(       "mild", seq(0, 10, by=0.1), c(2.5,5,7.5,1)));
  fis= addMF(fis, "input", 2, triMF(     "severe", seq(0, 10, by=0.1), c(5,7.5,10,1)));
  fis= addMF(fis, "input", 2, triMF("very severe", seq(0, 10, by=0.1), c(7.5,10,10,1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF( "very low", c(0:100), c(10, -15, 3)));
  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(10, 25, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(10, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF(     "high", c(0:100), c(10, 75, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(10, 115, 3)));

  rulelist = rbind(
    c(1,6,5,1,1),

    c(2,1,1,1,1),
    c(2,2,1,1,1),
    c(2,3,2,1,1),
    c(2,4,3,1,1),
    c(2,5,4,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,1,1,1),
    c(3,4,2,1,1),
    c(3,5,4,1,1),

    c(4,1,1,1,1),
    c(4,2,1,1,1),
    c(4,3,2,1,1),
    c(4,4,3,1,1),
    c(4,5,4,1,1),

    c(5,6,5,1,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}
fis6 <- function() {
  fis= newFIS("emergency")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, -1, 1.5)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 8, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 11, 1.5)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, triMF(   "very low", seq(0, 10, by=0.1), c(0,0,2.5,1)));
  fis= addMF(fis, "input", 2, triMF(        "low", seq(0, 10, by=0.1), c(0,2.5,5,1)));
  fis= addMF(fis, "input", 2, triMF(       "mild", seq(0, 10, by=0.1), c(2.5,5,7.5,1)));
  fis= addMF(fis, "input", 2, triMF(     "severe", seq(0, 10, by=0.1), c(5,7.5,10,1)));
  fis= addMF(fis, "input", 2, triMF("very severe", seq(0, 10, by=0.1), c(7.5,10,10,1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);

  fis= addMF(fis, "output", 1, gaussMF( "very low", c(0:100), c(10, -15, 3)));
  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(10, 25, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(10, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF(     "high", c(0:100), c(10, 75, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(10, 115, 3)));

  rulelist = rbind(
    c(1,6,5,3,1),

    c(2,1,1,1,1),
    c(2,2,2,1,1),
    c(2,3,3,1,1),
    c(2,4,4,1,1),
    c(2,5,4,1,1),

    c(3,1,1,1,1),
    c(3,2,1,1,1),
    c(3,3,2,1,1),
    c(3,4,3,1,1),
    c(3,5,4,1,1),

    c(4,1,1,1,1),
    c(4,2,2,1,1),
    c(4,3,3,1,1),
    c(4,4,4,1,1),
    c(4,5,4,1,1),

    c(5,6,5,3,1)
  );
  fis= addRule(fis, rulelist);

  return(fis);
}

fisFinal <- function() {
  fis= newFIS("emergency", defuzzMethod="bisector", impMethod="prod")

  fis= addVar(fis,"input", "temperature", c(0, 10));

  fis= addMF(fis, "input", 1, gaussMF( "very low", c(0:10), c(1, -1, 1.5)));
  fis= addMF(fis, "input", 1, gaussMF(      "low", c(0:10), c(1, 2, 1)));
  fis= addMF(fis, "input", 1, gaussMF(   "normal", c(0:10), c(1, 5, 1)));
  fis= addMF(fis, "input", 1, gaussMF(     "high", c(0:10), c(1, 8, 1)));
  fis= addMF(fis, "input", 1, gaussMF("very high", c(0:10), c(1, 11, 1.5)));

  fis= addMF(fis, "input", 1,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis,"input", "headache", c(0, 10));

  fis= addMF(fis, "input", 2, triMF(   "very low", seq(0, 10, by=0.1), c(0,0,2.5,1)));
  fis= addMF(fis, "input", 2, triMF(        "low", seq(0, 10, by=0.1), c(0,2.5,5,1)));
  fis= addMF(fis, "input", 2, triMF(       "mild", seq(0, 10, by=0.1), c(2.5,5,7.5,1)));
  fis= addMF(fis, "input", 2, triMF(     "severe", seq(0, 10, by=0.1), c(5,7.5,10,1)));
  fis= addMF(fis, "input", 2, triMF("very severe", seq(0, 10, by=0.1), c(7.5,10,10,1)));

  fis= addMF(fis, "input", 2,  trapMF("undefined", c(0:10), c(0,0,10,10, 1)));

  fis= addVar(fis, "output", "urgency", 0:100);
  fis= addMF(fis, "output", 1, gaussMF( "very low", c(0:100), c(10, -15, 3)));
  fis= addMF(fis, "output", 1, gaussMF(      "low", c(0:100), c(10, 25, 1)));
  fis= addMF(fis, "output", 1, gaussMF(   "medium", c(0:100), c(10, 50, 1)));
  fis= addMF(fis, "output", 1, gaussMF(     "high", c(0:100), c(10, 75, 1)));
  fis= addMF(fis, "output", 1, gaussMF("emergency", c(0:100), c(10, 115, 3)));

  rulelist = rbind(
    c(1,6,5,3,1), # IF temperature is very low THEN urgency is emergency

    c(2,1,1,1,1), # IF temperature is low AND headache is very low THEN urgenc#y is very low
    c(2,2,2,1,1), # IF temperature is low AND headache is low THEN urgency is low
    c(2,3,3,1,1), # IF temperature is low AND headache is mild THEN urgency is medium
    c(2,4,4,1,1), # IF temperature is low AND headache is severe THEN urgency is high
    c(2,5,4,1,1), # IF temperature is low AND headache is very severe THEN urgency is high

    c(3,1,1,1,1), # IF temperature is normal AND headache is very low THEN urgency is very low
    c(3,2,1,1,1), # IF temperature is normal AND headache is low THEN urgency is very low
    c(3,3,2,1,1), # IF temperature is normal AND headache is mild THEN urgency is low
    c(3,4,3,1,1), # IF temperature is normal AND headache is severe THEN urgency is medium
    c(3,5,4,1,1), # IF temperature is normal AND headache is very severe THEN urgency is high

    c(4,1,1,1,1), # IF temperature is high AND headache is very low THEN urgency is very low
    c(4,2,2,1,1), # IF temperature is high AND headache is low THEN urgency is low
    c(4,3,3,1,1), # IF temperature is high AND headache is mild THEN urgency is medium
    c(4,4,4,1,1), # IF temperature is high AND headache is severe THEN urgency is high
    c(4,5,4,1,1), # IF temperature is high AND headache is very severe THEN urgency is high

    c(5,6,5,3,1)  # IF temperature is very high THEN urgency is emergency
  );
  fis= addRule(fis, rulelist);

  return(fis);
}

showMFS <- function(fis) {
  par(mfrow=c(3,1));
  plotMF(fis,"input",1);
  plotMF(fis,"input",2);
  plotMF(fis,"output",1);
}

intsurf <- function(fis, ix1=1, ix2=2, ox1=1, accuracy=15) {
	require(rgl);

	i1 = fis$inputList[[ix1]]
	i2 = fis$inputList[[ix2]]
	o1 = fis$outputList[[ox1]]

	i1b = i1$inputBounds
	i2b = i2$inputBounds

	i1_min = i1b[1]
	i1_max = i1b[length(i1b)]

	i2_min = i2b[1]
	i2_max = i2b[length(i2b)]

	x_values = seq(i1_min, i1_max, length = accuracy)
	y_values = seq(i2_min, i2_max, length = accuracy)

	m_values = meshgrid(x_values, y_values)

	o_values = evalFIS(cbind(c(m_values$x), c(m_values$y)), fis)

	z_values = matrix(o_values[,ox1], accuracy, accuracy, byrow=TRUE)

  plot3d(i1b, i2b, o1$outputBounds,
    xlab=i1$inputName, ylab=i2$inputName, zlab=o1$outputName,
    type='n'
  );

  zlim <- range(o1$outputBounds)
  zlen <- zlim[2] - zlim[1] + 1

  colorlut <- rainbow(zlen, start=2/6, end=0)

  col <- colorlut[ z_values-zlim[1]+1 ]

  surface3d(x_values, y_values, z_values, color=col, lit=T, smooth=F, shininess=128)
  # persp3d(x_values, y_values, z_values, color=col, lit=T, smooth=F, shininess=128)
}

projectPng <- function(projectName, dir, ...) {
  # get a list of existing plots for the project
  plots <- list.files(path=dir, pattern=glob2rx(paste0(projectName, "*.png")))
  # pull out numeric component of the plot files
  nums <- as.numeric(gsub(paste(projectName, ".png", sep="|"), "", plots))
  last <- max(nums)
  if (last == -Inf) last <- 0;
  # Create a new file name with an incremented counter.
  newFile <- paste0(projectName, sprintf("%03d", last + 1), ".png")
  # now call png
  png(file.path(dir, newFile), ...)
}

fis= fisFinal();

# projectPng("cw", "C:\\work\\fuz", width=1000, height=1000, pointsize=20)
# intsurf(fis, accuracy=20);
# dev.off()
# intsurf(fis, accuracy=100);
# rgl.snapshot("C:\\work\\fuz\\lastfis.png")
# projectPng("cw", "C:\\work\\fuz", width=800, height=1000, pointsize=20)
# showMFS(fis);
# dev.off()

values= rbind(
    c(5,0),   # 1
    c(3,0),   # 2
    c(7,0),   # 3
    c(5,3),   # 4
    c(5,5),   # 5
    c(5,7),   # 6
    c(5,10),  # 7
    c(0,5),   # 8
    c(0,0),   # 9
    c(10,5),  #10
    c(0,10),  #11
    c(10,0),  #12
    c(10,10)  #13
  )

expected= rbind(
    0,   # 1
    0,   # 2
    0,   # 3
    15,  # 4
    25,  # 5
    50,  # 6
    75,  # 7
    100, # 8
    100, # 9
    100, #10
    100, #11
    100, #12
    100  #13
  )

rmse <- function(actual, expected) {
  return(sqrt(mean((actual - expected)^2)))
}

print(rmse(evalFIS(values, fis1()), expected))
print(rmse(evalFIS(values, fis2()), expected))
print(rmse(evalFIS(values, fis3()), expected))
print(rmse(evalFIS(values, fis4()), expected))
print(rmse(evalFIS(values, fis5()), expected))
print(rmse(evalFIS(values, fis6()), expected))
print(rmse(evalFIS(values, fisFinal()), expected))


# Enter your code here. Read input from STDIN. Print output to STDOUT
write(round(pnorm(9800, 205 * 49, sqrt( 49 * (15 ^ 2) )), 4), stdout())


a <- 5.0
l <- 2.0

N <- 10000
centX <- a/2 * runif(N)
centY <- a/2 * runif(N)
alpha <- runif(N, min=0, max=pi/2)

if (l < a) {
	ifx <- centX < l*cos(alpha)/2
	ify <- centY < l*sin(alpha)/2
	p <- mean(ifx | ify)
	print(p)
	newPi <- l^2 / (a^2 * p)
	print(newPi)
}


a <- 5
l <- 3

N <- 100000
cent_x <- a * runif(N)
alpha <- runif(N, min=0, max=pi/2)

mn <- mean(cent_x < l*cos(alpha))
print(mn)
new_pi <- 2 * l / (mn * a)
print(new_pi)


## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## population genetics
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Gset <- c("GG","GT","TT")
G_table <- expand.grid(Gf=Gset,Gm=Gset,GG=NA,GT=NA,TT=NA)
G_table[1,Gset] <- c(1  ,   0,   0)
G_table[2,Gset] <- c(1/2, 1/2,   0)
G_table[3,Gset] <- c(0  ,   1,   0)
G_table[4,Gset] <- c(1/2, 1/2,   0)
G_table[5,Gset] <- c(1/4, 1/2, 1/4)
G_table[6,Gset] <- c(0  , 1/2, 1/2)
G_table[7,Gset] <- c(0  ,   1,   0)
G_table[8,Gset] <- c(0  , 1/2, 1/2)
G_table[9,Gset] <- c(0  ,   0,   1)

pGenoOffCond <- vector("list",3)
names(pGenoOffCond) <- Gset
for (i in Gset) pGenoOffCond[[i]] <- t(subset(G_table, Gf==i)[,Gset])

p.offgenotype <- function(G_, Gf, pGm) {
    ## Look up the probability of an offspring genotype, given the maternal genotype and
    ## proportions of offspring sired by each paternal genotype.

    ## Args:
    ##   G_: Offspring genotype.
    ##   Gf: Maternal genotype.
    ##   pGm: Relative fecundities of different male genotypes.

    ## Returns:
    ##   The probability of offspring genotype G_.

    ## expect Gf to have length=1
    if (length(Gf) != 1)
        stop("offspring genotype function not vectorised for maternal genotype")
    ## return the required probability
    return((pGenoOffCond[[Gf]] %*% pGm)[G_,1])
}


###############################################################################
#  Copyright (C) 1994 - 2009, Performance Dynamics Company                    #
#                                                                             #
#  This software is licensed as described in the file COPYING, which          #
#  you should have received as part of this distribution. The terms           #
#  are also available at http://www.perfdynamics.com/Tools/copyright.html.    #
#                                                                             #
#  You may opt to use, copy, modify, merge, publish, distribute and/or sell   #
#  copies of the Software, and permit persons to whom the Software is         #
#  furnished to do so, under the terms of the COPYING file.                   #
#                                                                             #
#  This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY  #
#  KIND, either express or implied.                                           #
###############################################################################

# Load the library
library("pdq")
#
# Thruput bounds for closed tandem QNM with fixed Z
# Created by NJG on Fri Feb 27, 2009
clients = 200
think   = 8   * 10^(-3) # ms as seconds
stime   = 500 * 10^(-3) # ms as seconds
work    = "w"
for(k in list(1,20,50)) {
    xc<-0 # prudent to reset these
    yc<-0
    for (i in 1:clients) {
        Init("")
        CreateClosed(work, TERM, as.double(i), think)
        # create k queueing nodes in PDQ
        for (j in 1:k) {
       	    nname = paste("n",sep="",j) # concat j to node name
            CreateNode(nname,CEN,FCFS)
            SetDemand(nname,work,stime)
        }
        Solve(APPROX)
        # set up for plotting in R
        xc[i]<-as.double(i)
        yc[i]<-GetThruput(TERM,work)
        nopt<-(k*stime+think)/stime
     }
     if (k==1) {
     	# establish plot frame and first curve
        plot(xc, yc, type="l", ylim=c(0,1/stime), lwd=2, xlab="N Clients",
             ylab="Throughput X(N)")
        title("Increasing Number (K) of Queues")
      	abline(0, 1/(nopt*stime), lty="dashed",  col="blue")
      	abline(1/stime, 0, lty="dashed",  col = "red")
      	abline(v=nopt, lty="dashed", col="gray50") # grid line
        text(150,1.95,paste("K =", k))
      	text(5+k,1.4,paste("N* =",nopt),adj=c(0,0))
     } else {
    	# add the other curves
      	points(xc, yc, type="l", lwd=2)
      	abline(0,1/(nopt*stime), lty="dashed",  col="blue")
      	abline(v=nopt, lty="dashed", col="gray50")
       	text(150,1.85-0.085*k/10, paste("K =", k))
      	text(k+5,0.5-0.1*k/10,paste("N* =",nopt),adj=c(0,0))
     }
}