#' Parameter Recovery for Model Testing without Experimental Data
#'
#' This function extracts DDM parameters from a Stanfit object run on simulated data. Then,
#' it and compares those parameters fitted on simulated data with the parameters used to simulate
#' the data in the first place. This function is intended to check if the model is capable to
#' "recover" parameters which are known. Plots for visual inspection are made automatically.
#' Automatic fit diagnostics yet to be implementd with this function. The comparison is done
#' for each parameter over all iterations to detect convergence problems or to spot difficult parameter
#' spaces.
#'
#' @export
#' @param fit Stanfit object fitted on synthetic data.
#' @param n_subjects Number of "Simulated Subjects".
#' @param auth_params "Ground-truth" parameters used to simulate the data. In the form of the
#' output from the function \code{\link{makeFakeParams}}.
#' @param model_name Optional name for the model to distinguish the plots and created
#' folder easier. Default is 'NAME_UNDEFINED'.
#' @return Creates a folder and saves plots which compare recovered parameters and "ground-truth" parameters
#' for each iteration of the MCMC sampler.
param_recovery <- function(fit, n_subjects, auth_params, model_name='NAME_UNDEFINED'){
    # plot divergencies by parameter:
    mat <- rstan::extract(fit, permuted=FALSE)

    n_iter <- dim(mat)[1]
    n_chains <- dim(mat)[2]

    param <- rstan::extract(fit, permuted=TRUE, inc_warmup=FALSE) %>% map(unname)

    param <- param[as.vector(map(param, length)==(n_iter*n_subjects*n_chains))]
    #filter elements in list with the amount of data only subject-level params have

    param %<>% map(function(x){as.data.frame(x)}) %>%
        map(function(x){ apply(x, 2, function(y) cumsum(y)/seq_along(y))}) %>%
        map(unname) %>%
        map(function(x){data.table::melt(x)}) %>%
        map(function(x){x[,c('Var2', 'value')]}) %>%
        map(function(x){x$Var2 <- as.factor(x$Var2); return(x)}) %>%
        melt()

    param %<>% select('Var2', 'value', 'L1')

    param$L1 <- as.factor(param$L1)

    names(param) <- c('suj', 'value', 'param')

    ##auth param
    tmpa <- c('a', 'v', 't', 'z', 'st', 'sz', 'sv')
    tmpb <- c('alpha_mu', 'delta_mu', 'tau_mu', 'beta_mu', 'tau_sigma', 'beta_sigma', 'delta_sigma')
    for(.. in 1:length(tmpa)){
        if(tmpa[..] %in% names(auth_params)){
            names(auth_params)[names(auth_params) == tmpa[..]] <- tmpb[..]
        }
    }

    auth_params$suj <- as.factor(seq.int(nrow(auth_params)))

    auth_params %<>% data.table::melt(id.vars='suj')
    names(auth_params) <- c('suj', 'param', 'value')
    param %<>% left_join(., auth_params , by=c('suj', 'param') )

    dd <- param %>% filter(param!='log_lik' & param!="lp__") %>% group_by(param) %>%  nest() %>%
        mutate(plot=map2(data, as.list(.$param), ~ggplot(data = .x ) +
                             geom_line(aes(y=value.x, x=1:length(.x$value.x))) +
                             geom_line(aes(y=value.y, x=1:length(.x$value.x)), linetype = "dashed", color='red') +
                             theme(legend.position="bottom") +
                             scale_colour_hue(name="Data Types:")  +
                             theme(legend.position="bottom") + facet_wrap(~suj, scales='free') +
                             labs(title = paste('Parameter:', .y, sep=' '),
                                  subtitle = "Parameter recovery per simulated subject",
                                  x = "Iterations",
                                  y = 'Parameter Values',
                                  caption = 'Note: Warmup iterations not included. The dashed line represents the
                                  parmeter value which generated the data.')))

    walk2(.x = dd$plot, .y = dd$param,
          ~ ggsave(device = 'pdf',
                   scale = 1, width = 12, height = 8, units = c("in"),
                   filename = paste0(model_name, '/', model_name, '_param_recovery_', .y, ".pdf"),
                   plot = .x))

}


puzzlers.dict <- readLines("http://www.puzzlers.org/pub/wordlists/unixdict.txt")

longest.deranged.anagram <- function(dict=puzzlers.dict) {
  anagram.groups <- function(word.group) {
    sorted <- sapply(lapply(strsplit(word.group,""),sort),paste, collapse="")
    grouped <- tapply(word.group, sorted, force, simplify=FALSE)
    grouped <- grouped[sapply(grouped, length) > 1]
    grouped[order(-nchar(names(grouped)))]
  }

  derangements <- function(anagram.group) {
    pairs <- expand.grid(a = anagram.group, b = anagram.group,
                         stringsAsFactors=FALSE)
    pairs <- subset(pairs, a < b)
    deranged <- with(pairs, mapply(function(a,b) all(a!=b),
                                   strsplit(a,""), strsplit(b,"")))
    pairs[which(deranged),]
  }

  for (anagram.group in anagram.groups(dict)) {
    if (nrow(d <- derangements(anagram.group)) > 0) {
      return(d[1,])
    }
  }
}


#' Convert a vector of frequencies into a vector of times.
#'
#' @param freq Vector of frequencies.
#'
#' @return Vector of times.
#'
#' @examples
#' as.time(c(-3, -2, -1, +1, +2, +3))
#'
#' @export
as.time <- function(freq) {
    freq <- Re(freq)

    N <- length(freq)

    freq.max <- max(freq)

    time.step <- 1 / (2*freq.max)
    time.max <- N * time.step

    seq(time.step, time.max, time.step)
}


#!/usr/bin/env Rscript

############################################################
### Ax = b
### 表示以A为坐标系中x的向量 --->(对应于) 标准基下的b向量
############################################################


### About:
## The function is to estimate the mean and covariance function
## from a cluster of functions/longitudinal observations. The output
## will also predict each curve.

## Function arguments:
### "data" is a data frame with three arguments:
# (1) "argvals": observation times;
# (2) "subj": subject indices;
# (3) "y": values of observations;
# Note that: we only handle complete data, so missing values are not allowed at this moment

## "newdata" is of the same strucutre as "data".
## To predict at new values of "argvals", make the corresponding "y" NA

### "center" means if we want to compute population mean

### "argvals.new" if we want the estimated covariance function at "argvals.new"; if NULL,
### then 100 equidistant points in the range of "argvals" in "data"

### "knots" is the number of interior knots for B-spline basis functions to be used;

face.sparse.inner <- function(data, newdata = NULL, W = NULL,
                              center = TRUE, argvals.new = NULL,
                              knots = 7, knots.option = "equally-spaced",
                              p = 3, m = 2, lambda = NULL, lambda_mean = NULL,
                              search.length = 14,
                              lower = -3, upper = 10,
                              calculate.scores = FALSE, pve = 0.99) {

  #########################
  #### step 0: read in data
  #########################
  check.data(data)
  if (!is.null(newdata)) {
    check.data(newdata, type = "predict")
  }

  y <- data$y
  t <- data$argvals
  subj <- data$subj
  tnew <- argvals.new
  if (is.null(tnew)) tnew <- seq(min(t), max(t), length = 100)

  fit_mean <- NULL

  knots.initial <- knots
  #########################
  #### step 1: demean
  #########################
  r <- y
  mu.new <- rep(0, length(tnew))
  if (center) {
    fit_mean <- pspline(data, argvals.new = tnew, knots = knots.initial, lambda = lambda_mean)
    mu.new <- fit_mean$mu.new
    r <- y - fit_mean$fitted.values
  }
  #########################
  #### step 2:raw estimates
  #########################
  indW <- F # whether identity W
  if (is.null(W)) indW <- T

  raw <- raw.construct(data.frame("argvals" = t, "subj" = subj, "y" = as.vector(r)))
  C <- raw$C
  st <- raw$st
  N <- raw$st
  N2 <- raw$N2
  if (indW) W <- raw$W
  n0 <- raw$n0
  # indicator where ti = tj
  delta <- Matrix((st[, 1] == st[, 2]) * 1) # sparse

  #########################
  #### step 3: smooth
  #########################

  # set up
  knots <- construct.knots(t, knots, knots.option, p)
  ## construct design & penalty on column dimension
  List <- pspline.setting(st[, 1], knots = knots, p, m, type = "simple", knots.option = knots.option)
  B1 <- List$B
  B1 <- Matrix(B1)
  DtD <- List$P
  ## construct design on row dimension
  B2 <- spline.des(knots = knots, x = st[, 2], ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design
  c <- dim(B1)[2]
  c2 <- c * (c + 1) / 2
  ## combine tensor product design
  B <- Matrix(t(KhatriRao(Matrix(t(B2)), Matrix(t(B1)))))
  G <- Matrix(duplication.matrix(c))

  BtWB <- matrix(0, nrow = c^2, ncol = c^2)
  Wdelta <- c()
  WC <- c()
  for (i in 1:n0) {
    seq <- (sum(N2[1:i]) - N2[i] + 1):(sum(N2[1:i])) # select combos for object i
    B3 <- Matrix(matrix(B[seq, ], nrow = length(seq)))
    W3 <- W[[i]] # don't form a large W
    BtWB <- BtWB + crossprod(B3, W3 %*% B3)
    Wdelta <- c(Wdelta, as.matrix(W3 %*% delta[seq]))
    WC <- c(WC, as.matrix(W3 %*% C[seq]))
  }

  GtBtWBG <- crossprod(G, BtWB %*% G)

  BG <- B %*% G # sparse
  detWde <- crossprod(delta, Wdelta) # detWde = sum(delta)
  GtBtWdelta <- crossprod(BG, Wdelta)
  XtWX <- rbind(cbind(GtBtWBG, GtBtWdelta), cbind(t(GtBtWdelta), detWde))
  X <- cbind(BG, delta)
  # precalculate (2 eigens)
  eSig <- eigen(XtWX, symmetric = TRUE)
  V <- eSig$vectors
  E <- eSig$values
  E <- E + 0.000001 * max(E)
  Sigi_sqrt <- matrix.multiply(V, 1 / sqrt(E)) %*% t(V)
  ## penalty
  P <- crossprod(G, Matrix(suppressMessages(kronecker(diag(c), DtD)))) %*% G

  Q <- bdiag(P, 0)
  tUQU <- crossprod(Sigi_sqrt, (Q %*% Sigi_sqrt))
  Esig <- eigen(tUQU, symmetric = TRUE)
  # s, f, ftilde, F(A here)
  U <- Esig$vectors
  s <- Esig$values
  A0 <- Sigi_sqrt %*% U
  A <- as.matrix(X %*% A0) # F=XA dense

  AtA <- crossprod(A) # diff
  f <- crossprod(A, C) # diff
  ftilde <- crossprod(A, WC) # diff

  c2 <- c2 + 1
  g <- rep(0, c2)
  G1 <- matrix(0, c2, c2)
  mat_list <- list()
  # G, g, Li(AitAi here), Litilde(Li here)
  for (i in 1:n0) {
    seq <- (sum(N2[1:i]) - N2[i] + 1):(sum(N2[1:i]))
    Ai <- matrix(A[seq, ], nrow = length(seq))
    AitAi <- crossprod(Ai) # t(Ai)%*%Ai
    Wi <- W[[i]]

    fi <- crossprod(Ai, C[seq]) # t(Fi)Ci
    Ji <- crossprod(Ai, Wi %*% C[seq])
    Li <- crossprod(Ai, Wi %*% Ai)
    g <- g + Ji * fi
    G1 <- G1 + AitAi * (Ji %*% t(ftilde))

    LList <- list()
    LList[[1]] <- AitAi
    LList[[2]] <- Li
    mat_list[[i]] <- LList
  }

  # select smoothing parameter
  Lambda <- seq(lower, upper, length = search.length)
  Gcv <- 0 * Lambda
  gcv <- function(x) {
    lambda <- exp(x)
    d <- 1 / (1 + lambda * s)
    ftilde_d <- ftilde * d
    cv0 <- -2 * sum(ftilde_d * f)
    cv1 <- sum(ftilde_d * (AtA %*% ftilde_d))
    cv2 <- 2 * sum(d * g)
    cv3 <- -4 * sum(d * (G1 %*% d))
    cv4 <- sum(unlist(sapply(mat_list, function(x) {
      a <- x[[1]] %*% ftilde_d
      b <- x[[2]] %*% ftilde_d
      2 * sum(a * b * d)
    })))
    cv <- cv0 + cv1 + cv2 + cv3 + cv4
    return(cv)
  }
  if (is.null(lambda)) {
    Lambda <- seq(lower, upper, length = search.length) # construct lambda grid
    Length <- length(Lambda)
    Gcv <- rep(0, Length)
    for (i in 1:Length) {
      Gcv[i] <- gcv(Lambda[i])
    }
    i0 <- which.min(Gcv)
    lambda <- exp(Lambda[i0])
  }
  # parameter estimated (sym)
  alpha <- matrix.multiply(A0, 1 / (1 + lambda * s)) %*% ftilde
  Theta <- G %*% alpha[1:(c2 - 1)] # wrong index?
  Theta <- matrix(Theta, c, c)
  sigma2 <- alpha[c2]
  if (sigma2 <= 0.000001) {
    warning("error variance cannot be non-positive, reset to 1e-6!")
    sigma2 <- 0.000001
  }
  # make sure Theta positive definite(2 eigens)
  Eigen <- eigen(Theta, symmetric = TRUE)
  Eigen$values[Eigen$values < 0] <- 0
  npc <- sum(Eigen$values > 0) # which.max(cumsum(Eigen$values)/sum(Eigen$values)>pve)[1]
  if (npc > 1) {
    Theta <- matrix.multiply(Eigen$vectors[, 1:npc], Eigen$values[1:npc]) %*% t(Eigen$vectors[, 1:npc])
    Theta_half <- matrix.multiply(Eigen$vectors[, 1:npc], sqrt(Eigen$values[1:npc]))
  }
  if (npc == 1) {
    Theta <- Eigen$values[1] * suppressMessages(kronecker(Eigen$vectors[, 1], t(Eigen$vectors[, 1])))
    Theta_half <- sqrt(Eigen$values[1]) * Eigen$vectors[, 1]
  }
  Eigen <- eigen(Theta, symmetric = TRUE)

  #########################
  #### step 4: calculate estimated covariance function
  ######################### (2 eigens)
  # prepare estimation dense design
  Bnew <- spline.des(knots = knots, x = tnew, ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design
  Gmat <- crossprod(Bnew) / nrow(Bnew)
  eig_G <- eigen(Gmat, symmetric = T)
  G_half <- eig_G$vectors %*% diag(sqrt(eig_G$values)) %*% t(eig_G$vectors)
  G_invhalf <- eig_G$vectors %*% diag(1 / sqrt(eig_G$values)) %*% t(eig_G$vectors)

  Chat.new <- as.matrix(tcrossprod(Bnew %*% Matrix(Theta), Bnew)) # cov matrix
  Chat.diag.new <- as.vector(diag(Chat.new))
  Cor.new <- diag(1 / sqrt(Chat.diag.new)) %*% Chat.new %*% diag(1 / sqrt(Chat.diag.new)) # scale to cor matrix

  # what is these parts? (another npc)
  Eigen.new <- eigen(as.matrix(G_half %*% Matrix(Theta) %*% G_half), symmetric = TRUE)
  # Eigen.new = eigen(Chat.new,symmetric=TRUE)
  npc <- which.max(cumsum(Eigen$values) / sum(Eigen$values) > pve)[1] # determine number of PCs
  eigenfunctions <- matrix(Bnew %*% G_invhalf %*% Eigen.new$vectors[, 1:min(npc, length(tnew))], ncol = min(npc, length(tnew)))
  eigenvalues <- Eigen.new$values[1:min(npc, length(tnew))]
  # eigenfunctions = eigenfunctions*sqrt(length(tnew))/sqrt(max(tnew)-min(tnew))
  # eigenvalues = eigenvalues/length(tnew)*(max(tnew)-min(tnew))

  #########################
  #### step 5: calculate variance
  #########################
  var.error.hat <- rep(sigma2, length(t))
  var.error.new <- rep(sigma2, length(tnew))

  Chat.raw.new <- Chat.new + diag(var.error.new) # add variance sigma2
  Chat.raw.diag.new <- as.vector(diag(Chat.raw.new))
  Cor.raw.new <- diag(1 / sqrt(Chat.raw.diag.new)) %*% Chat.raw.new %*% diag(1 / sqrt(Chat.raw.diag.new))
  #########################
  #### step 6: prediction
  #########################
  if (!is.null(newdata)) {
    # means for newdata
    mu.pred <- rep(0, length(newdata$argvals))
    var.error.pred <- rep(sigma2, length(newdata$argvals))
    if (center) {
      mu.pred <- predict.pspline.face(fit_mean, newdata$argvals)
    }

    # setup prediction data
    subj.pred <- newdata$subj
    subj_unique.pred <- unique(subj.pred)
    y.pred <- newdata$y
    Chat.diag.pred <- 0 * y.pred
    se.pred <- 0 * y.pred

    scores <- list(
      subj = subj_unique.pred,
      scores = matrix(NA, nrow = length(subj_unique.pred), ncol = npc),
      u = matrix(NA, nrow = length(subj_unique.pred), ncol = nrow(Theta))
    )

    # prediction for each subject i
    for (i in 1:length(subj_unique.pred)) {
      # select the observations for subject i
      sel.pred <- which(subj.pred == subj_unique.pred[i])
      lengthi <- length(sel.pred)

      pred.points <- newdata$argvals[sel.pred]
      mu.predi <- mu.pred[sel.pred]
      var.error.predi <- var.error.pred[sel.pred]
      # center response
      y.predi <- y.pred[sel.pred] - mu.predi
      sel.pred.obs <- which(!is.na(y.predi))
      # select tij correspond to non na response
      obs.points <- pred.points[sel.pred.obs]
      if (!is.null(obs.points)) {
        var <- mean(var.error.predi[sel.pred.obs])
        if (var == 0 & length(sel.pred.obs) < npc) {
          stop("Measurement error estimated to be zero and there are fewer observed points thans PCs; scores
                cannot be estimated.")
        }
        B3i.pred <- spline.des(knots = knots, x = pred.points, ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design
        B3i <- spline.des(knots = knots, x = obs.points, ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design
        Chati <- tcrossprod(B3i %*% Theta, B3i)
        Chat.diag.pred[sel.pred] <- diag(Chati)
        if (length(sel.pred.obs) == 1) Ri <- var.error.predi[sel.pred.obs]
        if (length(sel.pred.obs) > 1) Ri <- diag(var.error.predi[sel.pred.obs])
        Vi.inv <- as.matrix(solve(Chati + Ri))

        Vi.pred <- tcrossprod(B3i.pred %*% Theta, B3i.pred)
        Hi <- as.matrix(B3i.pred %*% tcrossprod(Theta, B3i) %*% Vi.inv)
        ui <- tcrossprod(Theta, B3i) %*% Vi.inv %*% y.predi[sel.pred.obs]
        scores$u[i, ] <- as.vector(ui)
        y.pred[sel.pred] <- as.numeric(Hi %*% y.predi[sel.pred.obs]) + mu.predi # prediction
        temp <- as.matrix(B3i.pred %*% tcrossprod(Theta, B3i))
        if (length(sel.pred.obs) > 1) {
          se.pred[sel.pred] <- sqrt(diag(Vi.pred - temp %*% Vi.inv %*% t(temp)))
        }
        if (length(sel.pred.obs) == 1) {
          se.pred[sel.pred] <- sqrt(Vi.pred[1, 1] - Vi.inv[1, 1] * temp %*% t(temp))
        }

        ## predict scores
        if (calculate.scores == TRUE) {
          temp <- matrix(t(eigenfunctions), nrow = npc) %*% (as.matrix(Bnew) %*% ui) / sum(eigenfunctions[, 1]^2)
          temp <- as.matrix(temp)
          scores$scores[i, 1:npc] <- temp[, 1]
        }
      }
    }
  } ## if(is.null(newdata))
  if (is.null(newdata)) {
    y.pred <- NULL
    mu.pred <- NULL
    var.error.pred <- NULL
    Chat.diag.pred <- NULL
    se.pred <- NULL
    scores <- NULL
  }

  res <- list(
    newdata = newdata, W = W, y.pred = y.pred, Theta = Theta, argvals.new = tnew,
    mu.new = mu.new, Chat.new = Chat.new, var.error.new = var.error.new,
    Cor.new = Cor.new, eigenfunctions = eigenfunctions, eigenvalues = eigenvalues,
    Cor.raw.new = Cor.raw.new, Chat.raw.diag.new = Chat.raw.diag.new,
    scores = scores, calculate.scores = calculate.scores,
    mu.hat = fit_mean$fitted.values, var.error.hat = var.error.hat,
    mu.pred = mu.pred, var.error.pred = var.error.pred, Chat.diag.pred = Chat.diag.pred,
    se.pred = se.pred,
    fit_mean = fit_mean, lambda_mean = fit_mean$lambda,
    lambda = lambda, Gcv = Gcv, Lambda = Lambda, knots = knots, knots.option = knots.option, s = s, npc = npc, p = p, m = m,
    center = center, pve = pve, sigma2 = sigma2, r = r, DtD = DtD,
    U = Eigen.new$vectors[, 1:npc], G_invhalf = G_invhalf
  )

  class(res) <- "face.sparse"
  return(res)
}


# Assignment Overview ----------------------------------------------------------------
# Assignment 3: Incarceration
#
# (Acknowledgement: Vera Project https://github.com/vera-institute/incarceration-trends#documentation.)
#

# This will clear environment variables
rm(list = ls())
# Setting working directory
setwd("~/a3-smoham2/source")

# Load helper functions for data visualization
source("helperfunctions.R")

# Load packages
library("tidyverse")
library("maps")
library("dplyr")

# Loading data ------------------------------------------------------------
national_data <- load_incarceration_trends()
jail_jurisdiction_data <- load_incarceration_trends_jail_jurisdiction()

# Add a location column to the data set to better understand what counties are related to each state
national_data <- national_data %>%
  mutate(location = paste(county_name, state, sep = ", "))

# 1. What is the total number of black people incarcerated in jail as of the most recent year?
# To calculate this first we must filter the data to the most recent year.
# Then we tally the total number of black people in local jails.
total_black_jail_pop <- national_data %>%
  filter(year == max(year)) %>%
  tally(black_jail_pop) %>%
  pull()

# 2. What is the percentage of total population vs the total number of black people jailed across all counties as of the most recent year?

# Calculates total number of people in jail as of the most recent year
total_jail_population <- national_data %>%
  filter(year == max(year)) %>%
  tally(total_jail_pop) %>%
  pull()

# Divide the previously calculated black jail population by the new total jail population
black_jail_percentage <- (total_black_jail_pop/total_jail_population) * 100

# 3. What is the percentage of total jail population vs the total number of white people jailed across all counties as of the most recent year?
total_white_jail_pop <- national_data %>%
  filter(year == max(year)) %>%
  tally(white_jail_pop) %>%
  pull()

# Divide the new total jail population by the previously calculated total jail population
white_jail_percentage <- (total_white_jail_pop/total_jail_population) * 100

# 4. What is the census division with the lowest percentage of black people in jail
division_lowest_black_rate <- national_data %>%
  # First we filter to the most recent year
  filter(year == max(year)) %>%
  # Then we group by census division
  group_by(division) %>%
  drop_na(total_jail_pop) %>%
  drop_na(black_jail_pop) %>%
  # Then we create two new columns to track the total amount people in jail and black people in jail
  summarise(jail_pop = sum(total_jail_pop), total_black_jail_pop = sum(black_jail_pop)) %>%
  # We add a new column to track the percentage
  mutate(black_ratio = (total_black_jail_pop/jail_pop) * 100) %>%
  # Then we filter to the lowest
  filter(black_ratio == min(black_ratio)) %>%
  pull(division)

# 5. What is the census division with the highest percentage of black people in jail
division_highest_black_rate  <- national_data %>%
  # First we filter to the most recent year
  filter(year == max(year)) %>%
  # Then we group by census division
  group_by(division) %>%
  drop_na(total_jail_pop) %>%
  drop_na(black_jail_pop) %>%
  # Then we create two new columns to track the total amount people in jail and black people in jail
  summarise(jail_pop = sum(total_jail_pop), total_black_jail_pop = sum(black_jail_pop)) %>%
  # We add a new column to track the percentage
  mutate(black_ratio = (total_black_jail_pop/jail_pop) * 100) %>%
  # Then we filter to the lowest
  filter(black_ratio == max(black_ratio)) %>%
  pull(division)

# Calculate total number of white and black people in jail every year
national_jail_pop <- national_data %>%
  drop_na(white_jail_pop) %>%
  drop_na(black_jail_pop) %>%
  group_by(year) %>%
  summarise(total_black_jail_pop = sum(black_jail_pop), total_white_jail_pop = sum(white_jail_pop))

# Adds a new column that tracks how many more black people were in jail every year
national_jail_pop <- national_jail_pop %>%
  mutate(new_black_jail_pop = total_black_jail_pop - lag(total_black_jail_pop))

# Adds a new column that tracks how many more white people were in jail every year
national_jail_pop <- national_jail_pop %>%
  mutate(new_white_jail_pop = total_white_jail_pop - lag(total_white_jail_pop))

# Shows black jail population growth over time
window_size <- 10
national_jail_pop <- moving_avg_counts(national_jail_pop, window_size)
moving_avg_black_plot <- plot_moving_avg_jail_pop_by_race(national_jail_pop, window_size, "Black", national_jail_pop$rolling_avg_black_pop)
print(moving_avg_black_plot)

# Shows white and black jail population growth over time
window_size <- 10
national_jail_pop <- moving_avg_counts(national_jail_pop, window_size)
moving_avg_white_and_black_plot <- plot_moving_avg_jail_pop(national_jail_pop, window_size)
print(moving_avg_white_and_black_plot)

# Map
# Get county fips data
data(county.fips)
# Get county data and add new column to match the polyname
counties <- map_data("county") %>%
  mutate(polyname = paste(region, subregion, sep = ","))
# left join county data with county fips data
counties <- left_join(counties, county.fips, by = "polyname")

map_data <- left_join(national_data, counties, by = "fips") %>%
  filter(year == max(year))

blank_theme <- theme_bw() +
  theme(
    axis.line = element_blank(),        # remove axis lines
    axis.text = element_blank(),        # remove axis labels
    axis.ticks = element_blank(),       # remove axis ticks
    axis.title = element_blank(),       # remove axis titles
    plot.background = element_blank(),  # remove gray background
    panel.grid.major = element_blank(), # remove major grid lines
    panel.grid.minor = element_blank(), # remove minor grid lines
    panel.border = element_blank()      # remove border around plot
  )

black_jail_map <- ggplot(map_data) +
  geom_polygon(
    mapping = aes(x = long, y = lat, group = group, fill = black_jail_pop),
    color = "white", # show state outlines
    size = .1        # thinly stroked
    ) +
  coord_map() + # use a map-based coordinate system
  scale_fill_distiller(palette = "RdPu") +
  labs(fill = "Black Jail Population") +
  blank_theme +
  labs(
    x = "",
    y = "",
    title = "Current Black Jail Populations Across Counties",
    subtitle = "",
    caption = "",
    alt = ""
  )


#devtools::test("asremlPlus")
context("model_selection3")
asr3.lib <- "D:\\Analyses\\R oldpkg"

cat("#### Test estimateV not available for version 3\n")
test_that("chickpea_estimateV_asreml3", {
  skip_if_not_installed("asreml")
  skip_on_cran()
  library(dae)
  library(asreml, lib.loc = asr3.lib)
  library(asremlPlus)

  data(chkpeadat)
  asreml.obj <- asreml(fixed = Biomass.plant ~ Lines * TRT + Smarthouse/(vLanes + vPos),
                       random = ~Smarthouse:Zone + Smarthouse:spl(vLanes),
                       residual = ~Smarthouse:ar1(Lane):ar1(Position),
                       data = chkpeadat, trace = FALSE)

  #'## estimate with fixed spline - no G terms in V matrix
  testthat::expect_error(Vnospl <- estimateV(asreml.obj,
                                             fixed.spline.terms = "Smarthouse:spl(vLanes)"))

})


# 4. faza: Analiza podatkov
library(mgcv)

# Uvozimo funkcijo za uvoz spletne strani.
# source("lib/xml.r")
#
# # Preberemo spletno stran v razpredelnico.
# cat("Uvažam spletno stran...\n")
# tabela <- preuredi(uvozi.obcine(), obcine)
#
# # Narišemo graf v datoteko PDF.
# cat("Rišem graf...\n")
# pdf("slike/naselja.pdf", width=6, height=4)
# plot(tabela[[1]], tabela[[4]],
#      main = "Število naselij glede na površino občine",
#      xlab = "Površina (km^2)",
#      ylab = "Št. naselij")
# dev.off()
cat("Rišem graf.\n")
#barva<-rainbow(28,start=0,end=7/10)
#Želim prikazati, kako so države razvrščene po indeksu enakopravnosti
X<-scale(as.matrix(denar[1]))
t <- hclust(dist(X), method = "ward.D")
GDP<-BDP$X2010
Mo<-denar$Money
model<-gam(Mo~s(GDP))
#model<-lm(Mo~I(log1p(GDP)))

sloimena1=c(sloimena[1:14],"Luksemburg",
            sloimena[16],"Malta",sloimena[17:25],
            "Združeno Kraljestvo","EU (27 držav)")
pdf("slike/analiza.pdf",paper="a4",family="Arial")

barve1 = c("red", "green", "blue", "cyan", "magenta", "yellow","grey")
#barve1<-rainbow(7)
p<-cutree(t,k=7)
#Želim prikazati, kako so države razvrščene po indeksu enakopravnosti:
plot(t, hang=-1, cex=0.6,
     main = "Razvrstitev držav po indeksu enakopravnosti",
     xlab="Države",
     ylab="Medsebojno razlikovanje")
rect.hclust(t,k=7,border="red")
#BDP glede na enakopravnost v dohodkih:
plot(BDP$X2010,denar$Money,
     main = "BDP glede na enakopravnost v dohodku",
     xlab = "BDP na prebivalca v standardih kupne moči",
     ylab = "Indeks enakopravnosti glede na denarne vire",
     col=barve1[p],
     pch=rep(20,28))
curve(predict(model,data.frame(GDP=x)),add=TRUE,col="red")

# legend(200,80,sloimena1,pch=rep(20,14),
#        col=barva,cex=0.7,y.intersp=0.7,x.intersp=0.2)
#Malo bom preverila kaj je z rodnostjo:
plot(znanje$Index,rodnost$X2010,
     main = "Stopnja rodnosti glede na enakopravnost",
     xlab = "Indeks enakopravnosti po posameznih državah",
     ylab = "Stopnja rodnosti v letu 2010",
     col=barve1[p],pch=rep(20,28))
indeks<-znanje$Index
rodn<-rodnost$X2010
mls<-rodn~indeks
curve(predict(gam(rodn~s(indeks)),data.frame(indeks=x)),add=TRUE,col="magenta")
#curve(predict(loess(rodn~indeks),data.frame(indeks=x)),add=TRUE,col="cyan")
# legend(60,1.7,sloimena1,pch=rep(20,14),
#        col=barva,cex=0.7,y.intersp=0.7,x.intersp=0.2)
#zaposlenost glede na enakopravnost v znanju
plot(znanje$Knowledge, zaposlenost$X2010,
     main="Stopnja zaposlenosti glede na enakopravnost v znanju",
     xlab="Indeks enakopravnosti glede na pridobivanje znanja",
     ylab="Stopnja zaposlenosti v letu 2010",
     col=barve1[p],pch=rep(20,28))
#abline(lm(zaposlenost$X2010~znanje$Knowledge),col="blue")
znam<-znanje$Knowledge
delam<-zaposlenost$X2010
nekaj<-gam(delam~s(znam))
curve(predict(nekaj,data.frame(znam=x)),add=TRUE,col="blue")
#curve(predict(loess(delam~znam),data.frame(znam=x)),add=TRUE,col="blue")
dev.off()


library(data.table)
transaction = fread("transaction_table.csv",header = T)
product = fread("product_table.csv",header = T)

#all the transactions
transaction_product = merge(transaction, product, by = "prod_id",all.x = T)

#Making a unique ID per transaction
transaction_product$unique_id=paste(transaction_product$cust_id+
                                      transaction_product$tran_id+
                                      transaction_product$store_id)

#Selecting only those transactions that are between 2017-01-01 and 2017-12-31
tr_2017=transaction_product[which(transaction_product$tran_dt>="2017-01-01" & transaction_product$tran_dt<="2017-12-31")]

#Calculating total sales in 2017 for each customer and selecting only those
# with sales more than $5000. I call these people whales
customer_sales=tr_2017[,.(total_sale=sum(tran_prod_paid_amt)),by="cust_id"]
whales=customer_sales[(customer_sales$total_sale>5000),]

#Subsetting the transaction_product table by selecting only 'whales'
selected=transaction_product[transaction_product$cust_id %in% whales$cust_id]

all_customers=unique(selected$cust_id)
# creating a list of tables where each table corresponds to a customer
customer_profiles = lapply(seq_along(all_customers), function(i) selected[cust_id %in% all_customers[[i]]])

promo_table<-data.table()

promo_bag<-lapply(customer_profiles, function(x) {
  # 'x' refers to each single customer's transaction data

  #Flagging products that are bought on promotion i.e non-zero discount
  x<-x[,promo_flag:=ifelse(tran_prod_offer_cts>0,1,0)]
  #Vector with total sale value of each transaction
  sales_vec<-x[,.(sale_value=sum(tran_prod_paid_amt)),by="unique_id"]$sale_value
  # Vector with % discount on each sale
  promo_vec<-x[,.(disc_promo=sum(tran_prod_discount_amt)),by="unique_id"]$disc_promo
  ########################## Promotion Sensitivity ######################
  # Promotion sensitivity of a customer is defined as the correlation of (A,B):
  # A=Percentage discount obtained in each transaction (total_discount/total_sale)
  # B=Sale value of each transaction

  promo_sensitivity=cor(sales_vec,-1*promo_vec)
  promo_table<<-rbind(promo_table,cbind(x$cust_id[[2]],promo_sensitivity))

} )

write.csv(promo_table,'promo_sensitivity.csv')


library(randomForest)

s = sample(1:150,120)
train = iris[s,]
test = iris[-s, ]

model = randomForest(Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width, data = train)
print(model)
#plot(model)

p = predict(model,test)
print(p)
print(table(p))

p1 = addmargins(predict(p,iris$Species))
print(p1)


fizz <- function(i, f, b, n) {
  if (i > n) {
    return("")
  } else if (i == n) {
    p <- ""
  } else {
    p <- " "
  }
  if (i %% f == 0 && i %% b == 0) {
    paste("FB", p, fizz(i+1, f, b, n), sep="")
  } else if (i %% f == 0) {
    paste("F", p, fizz(i+1, f, b, n), sep="")
  } else if (i %% b == 0) {
    paste("B", p, fizz(i+1, f, b, n), sep="")
  } else {
    paste(toString(i), p, fizz(i+1, f, b, n), sep="")
  }
}

fizzbuzz <- function(s) {
  fizz(1, s[1], s[2], s[3])
}

cat(sapply(lapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), as.integer), fizzbuzz), sep="\n")


#' Function for fast sampling of DP mixture of Linear regressions.
#'
#' This function takes in a training data.frame and optional testing data.frame and performs posterior sampling. It returns posterior mean regression line for training and test sets. The function is built for continuous outcomes.
#' This differs from NDPMix in the following ways: NDPMix returns draws from the posterior *predictive* distribution of the outcome, whereas fDPMix() returns the regression line. This will have the same mean as the NDPMix predictions, but lower variance. Finally, the back-end computation is different, with regression line evaluation at point X being evaluated as a weighted average of cluster-specific regression evaluations at X. This is faster than NDPMix which takes a Monte Carlo appraoch: assign X to one of the cluster specific regressions, then draw a predicted outcome from that cluster's regression.
#'
#' We recommend normalizing continuous covariates and outcomes via the \code{scale} function before running \code{fDPMix}
#'
#' Please see \url{https://stablemarkets.github.io/ChiRPsite/index.html} for examples and detailed model and parameter descriptions.
#'
#' @import stats
#'
#' @param d_train A \code{data.frame} object with outcomes and model covariates/features. All features must be \code{as.numeric} - either continuous or binary with binary variables coded using \code{1} and \code{0}. Categorical features are not supported. We recommend standardizing all continuous features. NA values are not allowed and each row should represent a single subject, longitudinal data is not supported.
#' @param d_test Optional \code{data.frame} object containing a test set of subjects containing all variables specifed in \code{formula}. The same rules that apply to \code{d_train} apply to \code{d_test}.
#' @param formula Specified in the usual way, e.g. for \code{p=2} covariates, \code{y ~ x1 + x2}. All covariates - continuous and binary - must be \code{as.numeric} , with binary variables coded as \code{1} or \code{0}. We recommend standardizing all continuous features. NA values are not allowed and each row should represent a single subject, longitudinal data is not supported.
#' @param burnin integer specifying number of burn-in MCMC draws.
#' @param iter integer greater than \code{burnin} specifying how many total MCMC draws to take.
#' @param init_k Optional. integer specifying the initial number of clusters to kick off the MCMC sampler.
#' @param phi_y Optional. Length two \code{as.numeric} vector specifying the mean and variance of the inverse gamma prior on the outcome variance. By default, \code{phi_y[1]} is set to \code{var(y)}, where \code{y} is the outcome, so the inverse gamma prior is centered around the marginal empirical variance. With prior variance given by \code{phi_y[2]}. By default, \code{phi_y[2]=.5*var(y)}. This value should be large to be "flat" and small to be "tight" around the marginal empirical variance.
#' @param beta_prior_mean Optional. If there are \code{p} covariates, a length \code{p+1} \code{as.numeric} vector specifying mean of the Gaussian prior on the outcome model's conditional mean parameter vector. Default is regression coefficients from running OLS on the outcomes.
#' @param beta_prior_var Optional. If there are \code{p} covariates, a length \code{p+1} \code{as.numeric} vector specifying variance of the Gaussian prior on the outcome model's conditional mean parameter vector. The full covarince of the prior is set to be diagonal. This vector specifies the diagonal enteries of this prior covariance. Default is estimated variances from running OLS on the outcome.
#' @param beta_var_scale Optional. A multiplicative constant that scales \code{beta_prior_var}. If you leave \code{beta_prior_mean} and \code{beta_prior_var} at their defaults, This constant toggles how wide new cluster parameters are dispersed around the observed data parameters.
#' @param mu_scale Optional. An \code{as.numeric}, scalar constant that controls how widely distributed new cluster continuous covariate means are distributed around the empirical covariate mean. Specifically, all continuous covariates are assumed to have Gaussian likelihood with Gaussian prior on their means. \code{mu_scale=2} specifies that the variance of the Gaussian prior is twice as large as the empirical variance.
#' @param tau_x Optional numeric length two vector for specifying the inverse gamma prior on each continuous covariate's prior variance. By default, the inverse gamma prior is centered around the empirical variance. \code{tau_x[1]} is the positive constant that multiplies this empirical variance. A value of 1 indicates that the inverse gamma is centered around the empirical variance. A value of one half centers the inverse gamma prior around one half the empirical covariate variance. The second argument of \code{tau_x} is the prior variance. For example, if\code{tau_x[1]=1} and \code{tau_x[2]=.001}, then the inverse gamma prior is tight around the empirical variance. If \code{tau_x[2]=100}, then the inverse gamma prior for this covariate is widely distributed around the empirical variance.
#' @return Returns \code{predictions$train} and \code{cluster_inds$train}. \code{predictions$train} returns an \code{nrow(d_train)} by \code{iter - burnin} matrix of posterior predictions. \code{cluster_inds$train} returns an \code{nrow(d_train)} by \code{iter - burnin} matrix of cluster assignment indicators, which can be input into the function \code{cluster_assign_mode()} to compute posterior mode assignment. \code{predictions$test} and \code{cluster_inds$test} are returned if \code{d_test} is specified.
#' @keywords Dirichlet Process Gaussian
#' @examples
#' set.seed(1)
#'
#' N = 200
#' x<-seq(1,10*pi, length.out = N) # confounder
#' y<-rnorm(n = length(x), sin(.5*x), .07*x )
#' d <- data.frame(x=x, y=y)
#' d$x <- as.numeric(scale(d$x))
#' d$y <- as.numeric(scale(d$y))
#'
#' plot(d$x,d$y, pch=20, xlim=c(min(d$x), max(d$x)+1 ), col='gray')
#'
#' d_test = data.frame(x=seq(max(d$x), max(d$x+1 ), .01 ))
#'
#'
#' res = fDPMix(d_train = d, d_test = d_test, formula = y ~ x,
#'              iter=100, burnin=50, tau_x = c(.01, .001) )
#'
#' ## in-sample
#' lines(d$x, rowMeans(res$train), col='steelblue')
#' lines(d$x, apply(res$train,1,quantile,probs=.05) , col='steelblue', lty=2)
#' lines(d$x, apply(res$train,1,quantile,probs=.90) , col='steelblue', lty=2)
#'
#' ## out of sample
#' lines(d_test$x, rowMeans(res$test), col='pink')
#' lines(d_test$x, apply(res$test,1,quantile,probs=.05) , col='pink', lty=2)
#' lines(d_test$x, apply(res$test,1,quantile,probs=.90) , col='pink', lty=2)
#'
#' @export
fDPMix<-function(d_train, formula, d_test=NULL, burnin=100,iter=1000, init_k=10,
                 phi_y=NULL,
                 beta_prior_mean=NULL, beta_prior_var=NULL,beta_var_scale=1000,
                 mu_scale=1, tau_x =c(.05,2) ){

  ###------------------------------------------------------------------------###
  #### 0 - Parse User Inputs                                                ####
  ###------------------------------------------------------------------------###

  # error checking user inputs
  if( missing(d_train) ){ stop("ERROR: must specify a training data.frame.") }
  x <- all.vars(formula[[3]]) # covariate names
  y <- all.vars(formula[[2]]) # outcome name

  nparams <- length(x) + 1

  y <- d_train[,y]

  if(is.null(phi_y)){
    phi_y = c(var(y), 1/2*var(y))
  }

  func_args<-mget(names(formals()),sys.frame(sys.nframe()))
  error_check(func_args,'fDP')

  if(!is.null(d_test)){
    xt <- model.matrix(data=rbind(d_train[,x, drop=F], d_test[,x, drop=F]),
                       object= as.formula(paste0('~ ',paste0(x, collapse = '+'))))
    nt <- nrow(xt)
    test_ind = c(rep(0, nrow(d_train)), rep(1, nrow(d_test)) )
  }else{
    xt <- model.matrix(data=d_train,
                       object= as.formula(paste0('~ ',paste0(x, collapse = '+'))))
    nt <- nrow(xt)
    test_ind = c( rep(0, nrow(d_train)) )
  }

  x_type <- vector(length = length(x))
  for(v in 1:length(x)){
    if( length(unique(d_train[, x[v] ]))==2 ){
      x_type[v] <- 'binary'
    }else if(length(unique(d_train[,x[v]]))>2){
      x_type[v] <- 'numeric'
    }
  }

  store_l <- iter - burnin
  x_names <- x
  x <- model.matrix(data=d_train, object = formula )

  n<-nrow(x)

  xall_names <- x_names
  nparams_all <- length(xall_names)
  xall <- d_train[,xall_names]

  all_type_map <- c(x_type)
  names(all_type_map) <- c(x_names)
  xall_type <- all_type_map[as.character(xall_names)]

  xall_names_bin <- xall_names[xall_type == 'binary']
  xall_names_num <- xall_names[xall_type == 'numeric']

  # parse numeric versus binary variables for outcome model
  n_bin_p <- sum(x_type=='binary')
  n_num_p <- sum(x_type=='numeric')

  ## calibrate priors
  if(is.null(beta_prior_mean)){
    reg <- lm(data=d_train, formula = formula)
    beta_prior_mean <- reg$coefficients
  }

  if(is.null(beta_prior_var)){
    reg <- lm(data=d_train, formula = formula)
    beta_prior_var <- beta_var_scale*diag(vcov(reg))
  }

  ## test let phi_y[1] equal prior mean of inv gamma prior for phi
  ## let phi_y[2] equal the prior variance.
  ## then set phy_i[1] = sample outcome variance
  ## and let phi_y[3] control flattness around sample variance.

  g1 = (1/phi_y[2])*(phi_y[1]^2) + 2
  b1 = (g1 - 1)*phi_y[1]

  prior_means <- apply(x[,xall_names_num, drop=F], 2, mean)
  names(prior_means) <- xall_names_num

  prior_var <- mu_scale*apply(x[,xall_names_num, drop=F], 2, var)
  names(prior_var) <- xall_names_num

  g2 = (1/tau_x[2])*( tau_x[1]*apply(x[,xall_names_num, drop=F], 2, var) + 2)
  b2 = (g2 - 1)*tau_x[1]*apply(x[,xall_names_num, drop=F], 2, var)
  names(g2) <- xall_names_num
  names(b2) <- xall_names_num

  K <- init_k
  a <- 1

  ###------------------------------------------------------------------------###
  #### 1 - Create Shells for storing Gibbs Results                          ####
  ###------------------------------------------------------------------------###

  alpha <- numeric(length = store_l)

  curr_class_list <- 1:K
  class_names <- paste0('c',curr_class_list)

  c_shell<-matrix(NA, nrow=n, ncol=1) # shell for indicators

  class_shell <- matrix(NA, nrow=n, ncol=store_l)

  psi_shell <- matrix(NA, nrow= 1, ncol = K) # shell for Y's cond. var
  colnames(psi_shell) <- class_names

  beta_shell <- matrix(NA, nrow = nparams, ncol = K)
  colnames(beta_shell) <- class_names
  rownames(beta_shell) <- colnames(x)

  c_b_shell <- vector(mode = 'list', length = n_bin_p) # -1 for trt
  names(c_b_shell) <- xall_names_bin

  c_n_shell <- vector(mode = 'list', length = n_num_p)
  names(c_n_shell) <- xall_names_num

  for( p in xall_names_bin ){
    c_b_shell[[p]] <- matrix(NA, nrow = 1, ncol = K)

    c_b_shell[[p]][1,] <- rep(.5, K)

    colnames(c_b_shell[[p]]) <- class_names
  }

  for( p in xall_names_num ){
    c_n_shell[[p]] <- list(matrix(NA, nrow=1, ncol=K),
                           matrix(NA, nrow=1, ncol=K))

    c_n_shell[[p]][[2]][1, ] <- rep(0, K)
    c_n_shell[[p]][[2]][1, ] <- rep(20^2, K)

    colnames(c_n_shell[[p]][[1]]) <- class_names
    colnames(c_n_shell[[p]][[2]]) <- class_names
  }

  c_b_new <- numeric(length = n_bin_p)
  names(c_b_new) <- xall_names_bin

  c_n_new <- matrix(NA, nrow = 2, ncol = n_num_p)
  colnames(c_n_new) <- xall_names_num

  if(is.null(d_test)){
    predictions <- vector(mode = 'list', length = 1)
    predictions[[1]] <- matrix(nrow = n, ncol = store_l)
    names(predictions) <- c('train')
  }else{
    predictions <- vector(mode = 'list', length = 2)
    predictions[[1]] <- matrix(nrow = n, ncol = store_l)
    predictions[[2]] <- matrix(nrow = nrow(d_test), ncol = store_l)
    names(predictions) <- c('train','test')
  }

  ###------------------------------------------------------------------------###
  #### 2 - Set Initial Values                                               ####
  ###------------------------------------------------------------------------###

  # initially assign everyone to one of K clusters randomly with uniform prob
  c_shell[,1] <- sample(x = class_names, size = n,
                        prob = rep(1/K,K), replace = T)

  beta_start <- matrix(0, nrow=nparams, ncol=K)
  colnames(beta_start) <- class_names

  for(k in class_names){
    beta_shell[,k] <- beta_prior_mean
  }

  for(p in xall_names_bin ){
    c_b_shell[[p]][1,] <- rep(1, K)
  }

  for(p in xall_names_num ){
    c_n_shell[[p]][[2]][ 1 , ] <- rep(0, K)
    c_n_shell[[p]][[2]][ 1 , ] <- rep(20^2, K)
  }

  psi_shell[1,1:K] <- rep(500000, K)

  ###------------------------------------------------------------------------###
  #### 3 - Gibbs Sampler                                                    ####
  ###------------------------------------------------------------------------###
  message_seq <- seq(2, iter, round(iter/20) )
  cat(paste0('Iteration ',2,' of ', iter,' (burn-in) \n'))
  message_step <- (iter)/10
  for(i in 2:iter){

    ## print message to user
    if( i %% message_step == 1 ) cat(paste0('Iteration ',i,' of ',
                                            iter,
                                            ifelse(i>burnin,' (sampling) ',
                                                   ' (burn-in)') ,
                                            '\n'))

    # compute size of each existing cluster
    class_ind<-c_shell[,1]
    nvec<-table(factor(class_ind,levels = class_names) )

    ###----------------------------------------------------------------------###
    #### 3.1 - update Concentration Parameter                               ####
    ###----------------------------------------------------------------------###

    a_star <- rnorm(n = 1, mean =  a, sd = 1)
    if(a_star>0){
      r_num <- cond_post_alpha(a_star, n, K, nvec)
      r_denom <- cond_post_alpha(a, n, K, nvec)
      r <- exp(r_num - r_denom)
      accept <- rbinom(1,1, min(r,1) )==1
      if(accept){ a <- a_star }
    }

    ###----------------------------------------------------------------------###
    #### 3.2 - update parameters conditional on classification              ####
    ###----------------------------------------------------------------------###
    K <- length(unique(class_names))
    for(k in class_names){ # cycle through existing clusters - update parameters

      ck_ind <- class_ind == k

      y_ck <- y[ck_ind]

      x_ck <- x[ck_ind,, drop=FALSE]

      psi_shell[1, k]<-rcond_post_psi(beta = beta_shell[,k, drop=F],
                                      y = y_ck, xm = x_ck,
                                      g1 = g1, b1 = b1)

      beta_shell[,k] <- rcond_post_beta(y=y_ck,
                                        xm=x_ck,
                                        psi = psi_shell[1,k],
                                        beta_prior_mean = beta_prior_mean,
                                        beta_prior_var = beta_prior_var)

      for( p in xall_names_bin ){
        c_b_shell[[p]][1, k] <- rcond_post_mu_trt(x_ck = x_ck[, p])
      }

      for( p in xall_names_num ){
        c_n_shell[[p]][[1]][1,k] <- rcond_post_mu_x(x_ck = x_ck[, p],
                                                    phi_x = c_n_shell[[p]][[2]][1,k],
                                                    lambda = prior_means[p],
                                                    tau = prior_var[p])

        c_n_shell[[p]][[2]][1,k] <- rcond_post_phi(mu_x = c_n_shell[[p]][[1]][1, k],
                                                   x = x_ck[ , p],
                                                   g2 = g2[p], b2 = b2[p])
      }

    }

    ###----------------------------------------------------------------------###
    #### 3.3 - update classification conditional on parameters              ####
    ###----------------------------------------------------------------------###

    ## draw parameters for potentially new cluster from priors
    ### draw beta, phi, covariate parameters

    beta_new <- mvtnorm::rmvnorm(n = 1, mean = beta_prior_mean,
                                 sigma = diag(beta_prior_var) )
    psi_new <- invgamma::rinvgamma(n = 1, shape = g1, rate = b1)

    for(p in xall_names_bin){
      c_b_new[p] <- rbeta(n = 1, shape1 = 1, shape2 = 1)
    }

    for(p in xall_names_num){
      c_n_new[1, p] <- rnorm(n = 1, prior_means[p], sqrt(prior_var[p]) )
      c_n_new[2, p] <- invgamma::rinvgamma(n = 1, shape = g2[p], rate = b2[p])
    }

    name_new <- paste0('c', max(as.numeric(substr(class_names, 2,10))) + 1)

    ## compute post prob of membership to existing and new cluster,
    ## then classify

    uniq_clabs = colnames(beta_shell)

    weights <- class_update_train_fdp(n = n, K = length(class_names), alpha = a,
                                      name_new =  name_new,
                                      uniq_clabs = uniq_clabs,
                                      clabs = class_ind,

                                      y = y, x = x,
                                      x_cat_shell = c_b_shell , x_num_shell = c_n_shell,

                                      ## col number of each covar...index with base 0
                                      cat_idx=xall_names_bin, num_idx=xall_names_num,

                                      beta_shell = beta_shell,
                                      psi_shell = psi_shell,

                                      beta_new=beta_new, psi_new=psi_new,
                                      cat_new = c_b_new, num_new=c_n_new)

    c_shell[,1] <- apply(weights, 1, FUN = sample,
                         x=c(colnames(beta_shell), name_new), size=1, replace=T)

    if( i > burnin ){

      ###--------------------------------------------------------------------###
      #### 4.0 - Predictions on a Training and Test set  & Store Results    ####
      ###--------------------------------------------------------------------###

      test_pred <- post_mean_test_fdp(n=nt,K=K,alpha=a, name_new=name_new,
                                      uniq_clabs = uniq_clabs, x=xt,
                                      x_cat_shell=c_b_shell, x_num_shell=c_n_shell,
                                      cat_idx=xall_names_bin, num_idx=xall_names_num,
                                      cat_new=c_b_new, num_new=c_n_new,
                                      clabs=class_ind, beta_shell, beta_new)
      if( is.null(d_test) ){
        predictions[['train']][, i-burnin  ] <- test_pred[test_ind==0]
      }else{
        predictions[['train']][, i-burnin  ] <- test_pred[test_ind==0]
        predictions[['test']][, i-burnin  ] <- test_pred[test_ind==1]
      }
    }

    ###----------------------------------------------------------------------###
    #### 5.0 - update shell dimensions as clusters die/ are born            ####
    ###----------------------------------------------------------------------###

    new_class_names <- unique(c_shell[,1])
    K_new <- length(new_class_names)

    # Grow shells by adding labels/parameters of new clusters
    new_class_name <- setdiff(new_class_names, class_names)
    if(length(new_class_name)>0){ # new cluster was born

      beta_shell <- cbind(beta_shell, t(beta_new) )
      colnames(beta_shell)[K+1] <- new_class_name

      psi_shell <- cbind(psi_shell, psi_new)
      colnames(psi_shell)[K+1] <- new_class_name

      for(p in xall_names_bin ){
        c_b_shell[[p]] <- cbind( c_b_shell[[p]], c_b_new[p] )
        colnames(c_b_shell[[p]])[K+1] <- new_class_name
      }

      for(p in xall_names_num ){
        c_n_shell[[p]][[1]] <- cbind(c_n_shell[[p]][[1]], c_n_new[1, p])
        colnames(c_n_shell[[p]][[1]])[K+1] <- new_class_name

        c_n_shell[[p]][[2]] <- cbind(c_n_shell[[p]][[2]], c_n_new[2, p])
        colnames(c_n_shell[[p]][[2]])[K+1] <- new_class_name
      }
    }

    # shrink shells by deleting labels of clusters that have died.
    dead_classes <- setdiff(class_names, new_class_names)
    if(length(dead_classes) > 0){ # clusters have died
      beta_shell <- beta_shell[,! colnames(beta_shell) %in% dead_classes, drop=F]

      psi_shell <- psi_shell[, ! colnames(psi_shell) %in% dead_classes, drop=F]

      for(p in xall_names_bin){
        c_b_shell[[p]] <- c_b_shell[[p]][, ! colnames(c_b_shell[[p]]) %in% dead_classes, drop=F]
      }

      for(p in xall_names_num){
        c_n_shell[[p]][[1]] <- c_n_shell[[p]][[1]][, ! colnames(c_n_shell[[p]][[1]]) %in% dead_classes, drop=F]
        c_n_shell[[p]][[2]] <- c_n_shell[[p]][[2]][, ! colnames(c_n_shell[[p]][[2]]) %in% dead_classes, drop=F]
      }
    }

    K <- K_new
    class_names <- new_class_names

  }

  results <- predictions
  cat('Sampling Complete.')
  return(results)
}


#' mb2inchHG
#'
#' Conversion from Millibar [hPa] to inches HG.
#'
#' @param numeric   mb Air pressure in Millibar [hPa]
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  mbtoinchHG
#'
#' @export
#'
#'
#'
#'

mb2inchHG<-function(mb)
{
  return (mb/ 33.8638864);
}


# -------------------------------------------------------------------------
# Estimate a first-order autoregressive stochastic volatility model on the
# forecast errors from the macroeconomic data (no conditional mean)
# -------------------------------------------------------------------------

#rm(list=ls())

# Initialization
require(stochvol)
options(digits=17)
set.seed(0) # for replication

# KE file
vt = read.csv(header = TRUE, sep = ",", "C:/Dateien/My Dropbox/Lennart/Thesis/Code/ez-shocks/MATLAB/factors_vyt.csv")

# Remove dates vector
vt = vt[, -1]

obs.T    = dim(vt)[1]
obs.N    = dim(vt)[2]

for (i in 1:obs.N){

	if(min(log(vt[, i]^2)) == -Inf){

		vt[, i] = vt[, i] + 0.00001 #offset to avoid taking log of zero
	}
}

# Run MCMC algorithm and store draws
S    = 50000
burn = 50000 # MCMC with [50000, 50000] takes roughly 50 seconds per iteration.

h    = matrix(0, obs.T, obs.N) # Latent variable ht
t    = matrix(0, 3, obs.N) # Parameter vector theta
g    = matrix(0, 3, obs.N) # Geweke convergence statistic for each parameter

for (i in 1:obs.N){

  draws   = svsample(vt[, i], draws = S, burnin = burn, quiet = TRUE, thinpara = 10, thinlatent = 10)

  h[, i]  = colMeans(draws$latent)
  t[, i]  = colMeans(draws$para)
  g[, i]  = geweke.diag(draws$para)$z

  # Show progress in console
  cat('i =', i)
  print(Sys.time())
}

# Save results to .csv in format [estimators, variables]
write.csv(h, file = 'svylatent.csv', row.names = FALSE)
write.csv(t, file = 'svyparams.csv', row.names = FALSE)
write.csv(g, file = 'svygeweke.csv', row.names = FALSE)


library(contextual)
horizon <- 500
simulations <- 1000
ProbClickContx <- matrix(c(0.1, 0.3, 0.7, 0.8, 0.4, 0.1),
                     nrow = 2, ncol = 3, byrow = TRUE)

bandit <- ContextualBinaryBandit$new(weights = ProbClickContx)

policy <- EpsilonGreedyPolicy$new(epsilon = 0.1)

agent <- Agent$new(policy,bandit)

simulator <- Simulator$new(agent, horizon, simulations, do_parallel = FALSE)

history <- simulator$run()

plot(history, type = "arms", legend_position = "bottomright")


require(ggplot2)
require(gridExtra)
require(reshape2)

source('fmm_conditional.r')

config = list(
    k = 3
  , a = 1
  , l = 0
  , r = 0.01
  , b = 1
  , w = 1
  , n = 1000
  )

set.seed(990909)

d = data.frame(
  value = c(rnorm(250, -3, 0.25), rnorm(500, 0, 0.25), rnorm(250, 3, 0.25)))

set.seed(990909)

params = inverse_model(
    config$n, config$k, d$value
  , config$a, config$l, config$r
  , config$b, config$w
  )

dp = melt(as.data.frame(params$p))
dm = melt(as.data.frame(params$m))
ds = melt(as.data.frame(params$s))
dl = melt(as.data.frame(params$l))

py = ggplot(d, aes(value)) + geom_histogram(alpha = 0.5, fill = 'darkblue')

pp = ggplot(dp, aes(x = seq_along(value), y = value, colour = variable)) +
       geom_line()

pm = ggplot(dm, aes(x = seq_along(value), y = value, colour = variable)) +
       geom_line()

ps = ggplot(ds, aes(x = seq_along(value), y = log(value), colour = variable)) +
       geom_line()

pl = ggplot(dl, aes(x = seq_along(value), y = value)) +
       geom_line(colour = 'darkblue')

early = data.frame(value = d$value, variable = params$z[1,])
mid   = data.frame(value = d$value, variable = params$z[round(config$n / 2),])
late  = data.frame(value = d$value, variable = params$z[config$n - 1,])

p_early =
  ggplot(early, aes(value, colour = factor(variable), fill = factor(variable))) +
    geom_histogram(alpha = 0.5)

p_mid =
  ggplot(mid, aes(value, colour = factor(variable), fill = factor(variable))) +
    geom_histogram(alpha = 0.5)

p_late =
  ggplot(late, aes(value, colour = factor(variable), fill = factor(variable))) +
    geom_histogram(alpha = 0.5)

chain_plots    = grid.arrange(py, pp, pm, ps, nrow = 2, ncol = 2)

inferred_plots = grid.arrange(py, p_early, p_mid, p_late, nrow = 2, ncol = 2)


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.2.3
#criado:     08.02.2019
#modificado: 08.02.2019

## 1. FUNCTIONS
{
# Key:
# a - auxiliar
# d - dataframe
# f - file name
# i - iterator
# l - list
# n - vector size
# s - selected samples
# t - title
# v - vector
# w - weights

# Perform Partition around medoids clustering (wide format) [allow for specific number of partitions]
# dst1 - distance matrix of variables to be analysed
# kbest - specify number of partitions [if is.null(kbest) then calculate best number of partitions]
# col1 - colors for points
# border - add border to columns
# f1 - output filename
# main - title for plots
plot_pam_v2 = function(dst1,kbest=NULL,col1=NULL,border=1,f1,main=NULL){
    library("cluster")
    kmax <- dim(as.matrix(dst1))[1]-1
    asw <- rep(0,kmax)
    for(k in 2:kmax)
        asw[k] = pam(dst1,k)$silinfo$avg.width
    if(is.null(kbest)){
        kbest = which.max(asw)
    }
    pres1 = pam(dst1,kbest)
    d1 = cbind(1:kmax,asw)
    colnames(d1) = c("K","Average silhouette width")
    d2 = silhouette(pres1)
    f2 = paste(f1,"_1.csv",sep="")
    f3 = paste(f1,"_2.csv",sep="")
    f4 = paste(f1,"_3.csv",sep="")
    write.table(d1,f2,quote=TRUE,sep=",",eol="\n",na="NA",dec=".",
      col.names=TRUE,row.names=FALSE)
    write.table(pres1$clusinfo,f3,quote=TRUE,sep=",",eol="\n",na="NA",dec=".",
      col.names=TRUE,row.names=FALSE)
    write.table(d2,f4,quote=TRUE,sep=",",eol="\n",na="NA",dec=".",col.names=NA)
    for(i1 in c("eps","tiff")){
        if(i1 == "eps"){
            postscript(file=paste(f1,".eps",sep=""),width=7.0,height=3.5,
              colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special",
              family="Helvetica")
        }else{
            tiff(file=paste(f1,".tif",sep=""),units="in",width=7.0,height=3.5,
              res=300,compression="lzw",family="sans")
        }
        oldpar = par(mfcol=c(1,2),mar=c(2.2,2.2,1.2,1.2),mgp=c(1.0,0.2,0.0),
          tcl=-0.2,cex=0.8,cex.lab=0.8,cex.axis=0.8,cex.main=0.9)
        plot(d1,type="h",main=main)
        points(kbest,asw[kbest],col="red",type= "h")
        plot(d2,main=main,sub="",xlab="Silhouette width",do.n.k=FALSE,
          border=border,do.clus.stat=FALSE,mgp=c(1.0,0.2,0.0),
          col=col1[rownames(d2)])
        par(oldpar)
        invisible(dev.off())
    }
}

# min-max transformation
# y - vector
# miny - minimum value to scale y
# maxy - maximum value to scale y
minmax = function(y,miny=NULL,maxy=NULL){
    if(is.null(miny)){miny = min(y)}
    if(is.null(maxy)){maxy = max(y)}
    return((y - miny)/(maxy - miny))
}

# Inverse min-max transformation
# y - vector
# miny - minimum value to scale y
# maxy - maximum value to scale y
minmax_inv = function(y,miny,maxy){
    return(y*(maxy - miny) + miny)
}

# Construct network (wide format) [allow for very many nodes]
# dst1 - distance matrix of variables to be analysed
# col1 - colors for points
# vmode - network layout
# edge_thr - threshold for edges to plot
# edge_lwd - scale for edges
# label_cex - size of node labels
# f1 - output filename
# main - title for plots
plot_sna_v2 = function(dst1,col1=NULL,vmode="fruchtermanreingold",edge_thr=0.80,
  edge_lwd=10,label_cex=0.8,f1,main=NULL){
    library("sna")
    m1 = as.matrix(dst1)
    m1 = -m1                            #invert distances
    mind = min(m1)
    maxd = max(m1)
    m1 = minmax(m1,mind,maxd)           #min-max transformation
    m1[m1 < edge_thr] = NA              #remove dist < thresh
    m1 = ((m1 - edge_thr))/(1 - edge_thr) #rescale dist
    edge_col = "lightblue"
    vertex_cex=1.5
    for(i1 in c("eps","tiff")){
        if(i1 == "eps"){
            postscript(file=paste(f1,".eps",sep=""),width=7,height=10,
              colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special",
              family="Helvetica")
        }else{
            tiff(file=paste(f1,".tif",sep=""),units="in",width=7,height=10,
              res=300,compression="lzw",family="sans")
        }
        oldpar = par(mar=c(1.1,1.1,2.1,1.1),mgp=c(0,0,0),xpd=TRUE,cex.main=0.9)
        gplot(m1,gmode="graph",displaylabels=TRUE,label.cex=label_cex,
          label.pos=5,mode=vmode,jitter=FALSE,main=paste(main,
          " [minmax(-dist) > ",edge_thr,"]",sep=""),vertex.cex=vertex_cex,
          vertex.col=col1[colnames(m1)],vertex.border=1,vertex.lty=1,
          vertices.last=TRUE,edge.lwd=edge_lwd,edge.lty=1,edge.lty.neg=1,
          edge.col=edge_col)
        par(oldpar)
        invisible(dev.off())
    }
}

# Summary statistics for network
# dst1 - distance matrix of variables to be analysed
# f1 - output filename
analyse_net = function(dst1,f1){
    library("sna")
    m1 = as.matrix(dst1)
    m1 = -m1                            #invert distances
    mind = min(m1)
    maxd = max(m1)
    m1 = (m1 - mind)/(maxd - mind)      #min-max transformation
    f2 = paste(f1,"_degree.csv",sep="")
    f3 = paste(f1,"_eigen.csv",sep="")
    f4 = paste(f1,"_dens.csv",sep="")
    #Degree - number of links incident upon a node
    net_deg = degree(m1,gmode="graph")
    s1 = order(net_deg,decreasing=TRUE)
    d1 = cbind(rownames(m1)[s1],net_deg[s1])
    colnames(d1) = c("Node","Degree")
    write.table(d1,f2,row.names=FALSE,col.names=TRUE,sep=",",dec=".",eol="\n",
      na="NA")
    #Eigenvector centrality - Influence of a node in a network
    net_evc = evcent(m1,gmode="graph",use.eigen=TRUE)
    s1 = order(abs(net_evc),decreasing=TRUE)
    d1 = cbind(rownames(m1)[s1],net_evc[s1])
    colnames(d1) = c("Node","Eigenvector")
    write.table(d1,f3,row.names=FALSE,col.names=TRUE,sep=",",dec=".",eol="\n",
      na="NA")
    #Density - the proportion of direct ties in a network relative to the total number possible
    nvert = nrow(m1)
    m2 = m1; diag(m2) = NA; m2[upper.tri(m2)] = NA
    nedge = sum(m2 != 0 & !is.na(m2))
    tedge = nties(m1,mode="graph")
    dens = gden(m1,mode="graph")
    d1 = data.frame(nvert,nedge,tedge,dens)
    write.table(d1,f4,row.names=FALSE,col.names=TRUE,sep=",",dec=".",eol="\n",
      na="NA")
}

# Reduce number of predictors
# dat1 - data frame of variables to be analysed (only predictors)
# y - response variable
# thr1 - upper threshold for correlation between predictors
# thr2 - lower threshold for correlation between predictors and response variables [if thr2==NULL then reduces till maxsize]
# thr3 - lower threshold for coefficient of variation [if thr3==NULL then reduces till maxsize]
# thr4 - upper threshold for Variance Inflation Factor (VIF)
# maxsize - maximum number of predictors [if maxsize==NULL then reduces till nsubj - 1]
# f1 - output filename
reduce_predictors_v2 = function(dat1,y,thr1=0.95,method="spearman",thr2=NULL,
  thr3=NULL,thr4=10,maxsize=NULL,f1){
# Note: Sqrt(R^2) for continuous variables is the correlation between variables. Sqrt(R^2)
# for continuous and categorical variables is the correlation between observed and predicted
# values.
    if(is.null(maxsize)){
        maxsize = nrow(dat1) - 1
    }
    if(is.null(thr2)){
        doStep2 = TRUE
    }else if(thr2 > 0){
        doStep2 = TRUE
    }else{
        doStep2 = FALSE
    }
    if(is.null(thr3)){
        doStep3 = TRUE
    }else if(thr3 > 0){
        doStep3 = TRUE
    }else{
        doStep3 = FALSE
    }
    write("Step1: Highly correlated between themselves",file=f1,append=FALSE)
    if(thr1 < 1){                       #remove variables highly correlated between themselves
        vars = colnames(dat1)
        rm_vars = c()
        for(i1 in vars){
            for(i2 in vars){
                if(i1 < i2 & !i1 %in% rm_vars){
                    rres = cor(dat1[,i1],dat1[,i2],method=method,use="complete")
                    if(abs(rres) > thr1){
                        write(paste("  Remove ",i2," (r_",i1," = ",round(rres,2),
                          ")",sep=""),file=f1,append=TRUE)
                        rm_vars = c(rm_vars,i2)
                    }
                }
            }
        }
        dat1 = dat1[,!vars %in% rm_vars]
    }else{
        write("<Skip step>",file=f1,append=TRUE)
    }
    write("Step2: Low correlated with response variable",file=f1,append=TRUE)
    if(doStep2){                        #remove variables with low correlation with dependent variable
        vars = colnames(dat1)
        if(is.factor(y)){
            y = as.character(y)
        }
        cors = apply(dat1,2,function(x){sqrt(summary(lm(y~x))$r.squared)})
        if(is.null(thr2)){
            n_rm = ncol(dat1) - maxsize #n_rm, so that, nvars = nsubj - 1
            if(n_rm <= 0){
                thr2 = 0.00
            }else{
                thr2 = sort(cors)[n_rm]
            }
        }
        rm_vars = cors <= thr2
        if(sum(rm_vars) == 0){
            write("<None removed>",file=f1,append=TRUE)
        }else{
            dat1 = dat1[,!rm_vars]
            tmp = cbind(vars[rm_vars],cors[rm_vars])
            tmp = apply(tmp,1,function(x){paste("  Remove ",x[1]," (r = ",
              round(as.numeric(x[2]),2),")",sep="")})
            write(tmp,file=f1,append=TRUE)
        }
    }else{
        write("<Skip step>",file=f1,append=TRUE)
    }
    write("Step3: Variables with low variation",file=f1,append=TRUE)
    if(doStep3){                        #remove variables with low variation
        vars = colnames(dat1)
        sds = apply(dat1,2,sd,na.rm=TRUE)
        means = apply(dat1,2,mean,na.rm=TRUE)
        if(is.null(thr3)){
            n_rm = ncol(dat1) - maxsize #n_rm, so that, nvars = nsubj - 1
            if(n_rm <= 0){
                thr3 = 0.00
            }else{
                thr3 = sort(sds/means)[n_rm]
            }
        }
        rm_vars = sds/means <= thr3
        if(sum(rm_vars) == 0){
            write("<None removed>",file=f1,append=TRUE)
        }else{
            dat1 = dat1[,!rm_vars]
            tmp = cbind(vars[rm_vars],sds/means[rm_vars])
            tmp = apply(tmp,1,function(x){paste("  Remove ",x[1]," (r = ",
              round(as.numeric(x[2]),2),")",sep="")})
            write(tmp,file=f1,append=TRUE)
        }
    }else{
        write("<Skip step>",file=f1,append=TRUE)
    }
    write("Step4: Variables with low VIF",file=f1,append=TRUE)
    if(thr4 < Inf){                     #remove variables using VIF (reduce multicollinearity)
        vars = colnames(dat1)
        keep_vars = stepwise_vif(dat1,thresh=thr4,trace=FALSE)
        if(sum(!keep_vars) == 0){
            write("<None removed>",file=f1,append=TRUE)
        }else{
            dat1 = dat1[,keep_vars]
            tmp = paste("  Remove",vars[!vars %in% keep_vars])
            write(tmp,file=f1,append=TRUE)
        }
    }else{
        write("<Skip step>",file=f1,append=TRUE)
    }
    return(dat1)
}

# Stepwise Variance Inflation Factors (VIF) selection to reduce collinearity
# [From "Marcus W Beck" in https://gist.github.com/fawda123/4717702#file-vif_fun-r]
# in_frame - data frame of variables to be analyzed
# thresh - threshold for VIF
# trace - print output of each iteration
stepwise_vif = function(in_frame,thresh=10,trace=TRUE){
    if(class(in_frame) != 'data.frame'){
        in_frame = data.frame(in_frame)
    }
    #get initial vif value for all comparisons of variables
    var_names = names(in_frame)
    vif_init = vif(in_frame)
    vif_max = max(as.numeric(vif_init),na.rm=TRUE)
    if(vif_max < thresh){
        if(trace==TRUE){
            print(data.frame(vif_init))
            cat('\n')
            cat(paste('All variables have VIF < ', thresh,', max VIF ',
              round(vif_max,2), sep=''),'\n\n')
        }
        return(var_names)
    }else{
        in_dat = in_frame
        #backwards selection of explanatory variables, stops when all VIF values are below 'thresh'
        while(vif_max >= thresh){
            var_names = names(in_dat)
            vif_vals = vif(in_dat)
            imax = which(vif_vals == max(as.numeric(vif_vals),na.rm=TRUE))[1]
            vif_max = as.numeric(vif_vals[imax])
            if(vif_max < thresh){
                break
            }
            if(trace==TRUE){
                print(data.frame(vif_vals))
                cat('\n')
                cat('removed: ',names(vif_vals)[imax],vif_max,'\n\n')
                flush.console()
            }
            in_dat = in_dat[,!names(in_dat) %in% names(vif_vals)[imax]]
        }
        return(names(in_dat))
    }
}

# Calculate Variance Inflation Factors (VIF) at a model-level
# [based on HH::vif()]
# dat1 - data frame of variables to be analysed (only predictors)
vif = function(dat1){
#see https://en.wikipedia.org/wiki/Variance_inflation_factor
#see car::vif() for calculation of VIF at variable-level
#see HH::vif() for calculation of VIF at model-level
#see faraway::vif() for calculation of VIF at model-level
#see fmsb::vif() for calculation of VIF at model-level
# Note: VIF can be defined at variable-level (using the partial R^2) and at the model
# level (using R^2, i.e. coefficient of determination).
    vars = colnames(dat1)
    nvars = length(vars)
    r2 = vector("numeric",length=nvars)
    names(r2) = vars
    for(i1 in 1:nvars){
        tmp = lm(dat1[,i1] ~ data.matrix(dat1[,-i1]),na.action="na.omit")
        r2[i1] = 1/(1 - summary(tmp)$r.squared)
    }
    return(r2)
}

# Automatic model selection for multiple linear regression using General LM [simplified version]
# dat1 - data frame of independet variables (predictors)
# resp - dependent variable (response variable)
# maxs1 -  maximum number of terms in candidate models {"hard"}
# crit - information criteria to use {"aic","aicc","bic","qaic","qaicc"}
# thrs  - threshold for nmods to perform exhaustive search
# popsize - Population size
# mutrate - Per locus (i.e. per term) mutation rate, [0,1]
# sexrate - Sexual reproduction rate, [0,1]
# imm - Immigration rate, [0,1]
# deltaM - Stop Rule: change in mean IC
# deltaB - Stop Rule: change in best IC
# conseq - Stop Rule: times with no improvement
# f1 - output filename
mod_select_lm_v2 = function(dat1,resp,maxs1="hard",crit="aicc",thrs=100000,
  popsize=100,mutrate=0.001,sexrate=0.1,imm=0.3,deltaM=0.05,deltaB=0.05,
  conseq=5,nreps=2,f1){
    library("glmulti")
    d1 = data.frame(resp,dat1)
    colnames(d1) = sapply(colnames(d1),function(x){gsub("[-|.]","_",x)}) #remove symbols used in "formulas"
    nvars = ncol(d1)
    vars = colnames(d1)
    hmax = (nrow(d1) - 1) - 3           #hard max (i.e. nparam = nsubj - 3)
    maxs1 = min(maxs1,hmax)             #prevent maxs1 > hard max
    nmods = sum(sapply(1:maxs1,function(x){choose(nvars-1,x)})) + 1
    if(nmods < thrs){                   #exhaustive search
        res2 = glmulti(y=vars[1],xr=vars[2:nvars],data=d1,level=1,maxsize=maxs1,
          method="h",crit=crit,plotty=FALSE,report=FALSE,includeobjects=TRUE,
          marginality=FALSE,model=TRUE,fitfunction="lm")
    }else{                              #genetic algorithm
        res1 = vector("list",length=nreps)
        for(i1 in 1:nreps){
            f2 = paste(f1,"_rep",i1,"_1",sep="")
            res1[[i1]] = glmulti(y=vars[1],xr=vars[2:nvars],data=d1,level=1,
              maxsize=maxs1,method="g",crit=crit,confsetsize=100,plotty=FALSE,
              report=FALSE,name=f2,includeobjects=TRUE,marginality=FALSE,
              model=TRUE,popsize=popsize,mutrate=mutrate,sexrate=sexrate,
              imm=imm,deltaM=deltaM,deltaB=deltaB,conseq=conseq,
              fitfunction="lm")
        }
        if(nreps > 1){
            res2 = glmulti::consensus(xs=res1,confsetsize=100)
        }else{
            res2 = res1
        }
    }
    t1 = weightable(res2)
    t2 = t1[t1[,crit] <= min(t1[,crit]) + 2,]
    t3 = coef(res2)
    f2 = paste(f1,".log",sep="")
    f3 = paste(f1,"_1.csv",sep="")
    f4 = paste(f1,"_2.csv",sep="")
    capture.output(print(res2),file=f2,append=FALSE,type="output")
    write.table(t2,file=f3,sep=",",row.names=TRUE,col.names=NA)
    write.table(t3,file=f4,sep=",",row.names=TRUE,col.names=NA)
    for(i1 in c("eps","tiff")){
        if(i1 == "eps"){
            postscript(file=paste(f1,".eps",sep=""),width=7.0,height=10,
              colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special",
              family="Helvetica")
        }else{
            tiff(file=paste(f1,".tif",sep=""),units="in",width=7.0,height=10,
              res=300,compression="lzw",family="sans")
        }
        oldpar = par(mfcol=c(3,1),mar=c(2.2,2.2,1.2,1.2),mgp=c(1.0,0.2,0.0),
          oma=c(0,0,0,0),tcl=-0.2,cex=0.8,cex.lab=0.8,cex.axis=0.8,cex.main=0.9)
        par(mar=c(2.2,10.2,1.2,1.2))
        plot(res2,type="s",cex.names=0.6)
        par(mar=c(2.2,2.2,1.2,1.2))
        plot(res2,type="p")
        plot(res2,type="w")
        par(oldpar)
        invisible(dev.off())
    }
    a1 = formula(res2@objects[[1]]$terms) #formula
    a2 = res2@objects[[1]]$model        #data
    l1 = list(a1,a2)
    names(l1) = c("formula","data")
    return(l1)
}

# Fit multiple linear regression using General LS
# form1 - formula of the model to fit
# dat1 - data frame of variables to fit
# f1 - output filename
# main - title for plots
fit_lm = function(form1,dat1,f1,main){
#see https://en.wikipedia.org/wiki/General_linear_model
# Note: Multiple linear regression assumptions:
# 1. The error terms need to be independent.
# 2. The error variance is homoskedastic.
# 3. The errors are normally distributed with mean = 0
# 4. The independent variables should be independent from each other (i.e. little or no multicollinearity).
# 5. Linearity between independent variables and dependent variable.
# 6. Large sample sizes (i.e. 10-30 cases per parameter).
    library("car")
    fit1 = lm(form1,data=dat1)
    sfit1 = summary(fit1)
    t1 = Anova(fit1,type="II")
    f2 = paste(f1,".log",sep="")
    f3 = paste(f1,".csv",sep="")
    capture.output(print(sfit1),file=f2,append=FALSE,type="output")
    write.table(t1,file=f3,sep=",",row.names=TRUE,col.names=NA)
    vars = all.vars(form1)
    y = dat1[,vars[1]]
    f = fit1$fitted.values
    r = fit1$residuals
    for(i1 in c("eps","tiff")){
        if(i1 == "eps"){
            postscript(file=paste(f1,".eps",sep=""),width=7.0,height=7.0,
              colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special",
              family="Helvetica")
        }else{
            tiff(file=paste(f1,".tif",sep=""),units="in",width=7.0,height=7.0,
              res=300,compression="lzw",family="sans")
        }
        oldpar = par(mfcol=c(2,2),mar=c(2.2,2.2,1.2,1.2),mgp=c(1.0,0.2,0.0),
          tcl=-0.2,cex=0.8,cex.lab=0.8,cex.axis=0.8,cex.main=0.9)
        qqnorm(r,col=4); qqline(r)                        #wg-err_norm: qqplot
        plot(f,sqrt(abs(r)),xlab="Fitted",ylab="sqrt(abs(Residuals))",col=4)
        abline(h=0,lty=2)                                 #wg-err_var: scatterplot
        hist(r,freq=FALSE,main="",col=4,xlab="Residuals") #wg-err_norm: histogram
        plot(f,y,xlab="Fitted values",ylab="Values",main=main,col=4)
        abline(c(0,1),lty=2)                              #goodness-of-fit: scatterplot
        par(oldpar)
        invisible(dev.off())
    }
}

# Fits multiple regression via neural networks
# [adapted from nnet::nnet.formula()]
# formula - formula of the regression
# data - data frame of variables to fit
# weights - weights for each subject
# ... - arguments for "nnet" {e.g. size, decay, maxit, abstol, reltol, Hess, trace}
# na.action - usual model parameter
# contrast - usual model parameter
multivar = function(formula,data,weights,...,subset,na.action,contrasts=NULL){
    m = match.call(expand.dots=FALSE)
    if(is.matrix(eval.parent(m$data))){
        m$data <- as.data.frame(data)
    }
    m$... = m$contrasts = NULL
    m[[1L]] = quote(stats::model.frame)
    m = eval.parent(m)
    Terms = attr(m, "terms")
    x = model.matrix(Terms,m,contrasts)
    cons = attr(x,"contrast")
    xint = match("(Intercept)",colnames(x),nomatch = 0L)
    if(xint > 0L){
        x = x[,-xint,drop=FALSE]
    }
    if(attr(Terms,"intercept") == 0){
        Qr = qr(x)
    }else{
        Qr = qr(cbind(1,x))
        colnames(Qr$qr) = c("(Intercept)",colnames(Qr$qr)[-1])
    }
    w = model.weights(m)
    if(length(w) == 0L){
        w = rep(1,nrow(x))
    }
    y = model.response(m)
    miny = min(y)
    maxy = max(y)
    y_tr = minmax(y,miny,maxy)
    res = nnet.default(x,y_tr,w,linout=TRUE,...)
    res$terms = Terms
    res$coefnames = colnames(x)
    res$call = match.call()
    res$na.action = attr(m,"na.action")
    res$contrasts = cons
    res$call$formula = formula
    res$xlevels = .getXlevels(Terms, m)
    if(0){
        res$tr.fitted.values = matrix(minmax_inv(res$fitted.values[,1],
          miny,maxy))
        res$tr.residuals = matrix(y - res$tr.fitted.values)
    }else{
        res$tr.fitted.values = res$fitted.values
        res$tr.residuals = res$residuals
        res$fitted.values = matrix(minmax_inv(res$fitted.values[,1],miny,maxy))
        res$residuals = matrix(y - res$fitted.values)
    }
    res$deviance = sum(res$residuals^2)
    res$qr = Qr
    res$rank = res$qr$rank
    res$df.residual = length(y) - res$rank
    res$model = m
    class(res) = c("multivar","nnet.formula","nnet")
    res
}

# Create logLik() function for "multivar" objects
# [adapted from stats:::logLik.lm()]
# object - "multivar" object
logLik.multivar = function(object,...){
    res = object$residuals
    p = object$rank
    N = length(res)
    if(is.null(w <- object$weights)){
        w = rep.int(1,N)
    }else{
        excl = w == 0
        if(any(excl)){
            res = res[!excl]
            N = length(res)
            w = w[!excl]
        }
    }
    val = 0.5*(sum(log(w)) - N*(log(2*pi) + 1 - log(N) + log(sum(w*res^2))))
    attr(val, "nobs") = N
    attr(val, "df") = p + 1
    class(val) = "logLik"
    val
}

# Create nobs() function for "multivar" objects
# [adapted from stats:::nobs.lm()]
# object - "multivar" object
nobs.multivar = function(object){
    if(!is.null(w <- object$weights)){
        sum(w != 0)
    }else{
        nrow(object$residuals)
    }
}

# Create summary() function for "multivar" objects
# [adapted from stats:::summary.lm()]
# object - "multivar" object
summary_multivar = function(object){
    z = object
    p = z$rank
    rdf = z$df.residual
    if(p == 0){
        r = z$residuals
        n = length(r)
        w = z$weights
        if(is.null(w)){
            rss = sum(r^2)
        }else{
            rss = sum(w*r^2)
            r = sqrt(w)*r
        }
        resvar = rss/rdf
        ans = z[c("call", "terms", if (!is.null(z$weights)) "weights")]
        ans$residuals = r
        ans$df = n
        ans$sigma = sqrt(resvar)
        ans$r.squared = ans$adj.r.squared <- 0
        return(ans)
    }
    Qr = object$qr
    n = nrow(Qr$qr)
    r = z$residuals
    f = z$fitted.values
    w = z$weights
    if(is.null(w)){
        mss = if(attr(z$terms, "intercept")){sum((f - mean(f))^2)}else{sum(f^2)}
        rss = sum(r^2)
    }else{
        mss = if(attr(z$terms, "intercept")){m = sum(w * f/sum(w));
          sum(w*(f - m)^2)}else{sum(w*f^2)}
        rss = sum(w*r^2)
        r = sqrt(w)*r
    }
    resvar = rss/rdf
    if(is.finite(resvar) && resvar < (mean(f)^2 + var(f))*1e-30)
        warning("essentially perfect fit: summary may be unreliable")
    p1 = 1L:p
    ans = z[c("call", "terms",if(!is.null(z$weights)){"weights"})]
    ans$residuals = r
    ans$sigma = sqrt(resvar)
    ans$df = c(p,rdf,ncol(Qr$qr))
    if(p != attr(z$terms,"intercept")){
        df.int = if(attr(z$terms, "intercept")){1L}else{0L}
        ans$r.squared = mss/(mss + rss)
        ans$adj.r.squared = 1 - (1 - ans$r.squared)*((n - df.int)/rdf)
        ans$fstatistic = c(value=(mss/(p - df.int))/resvar,numdf=p - df.int,
          dendf=rdf)
    }else{
        ans$r.squared = ans$adj.r.squared = 0
    }
    if(!is.null(z$na.action)){
        ans$na.action = z$na.action
    }
    ans
}

# Fit multiple regression using ANN [add finer tune for ANN]
# form1 - formula of the model to fit
# dat1 - data frame of variables to fit
# nn_size - number of units in the hidden layer [ANN]
# nn_decay - parameter for weight decay [ANN]
# nn_maxit - maximum number of iterations [ANN]
# nn_abstol - absolute fit criterion [ANN]
# nn_reltol - relative fit criterion [ANN]
# f1 - output filename
# main - title for plots
fit_nnet_v2 = function(form1,dat1,nn_size=10,nn_decay=0.01,nn_maxit=1000,
  nn_abstol=1e-4,nn_reltol=1e-8,f1,main){
#see https://en.wikipedia.org/wiki/Artificial_neural_network
# Note: Multiple regression assumptions:
# 1. The error terms need to be independent.
# 2. The independent variables should be independent from each other (i.e. little or no multicollinearity).
# 3. Large sample sizes (i.e. 10-30 cases per parameter).
# Note: Neuronal network caveats
# 1. optimal number of hidden units is problem specific (risk of overfitting)
    library("nnet")
    library("caret")
    library("NeuralNetTools")
    vars = all.vars(form1)
    if(is.null(nn_size) || is.null(nn_decay)){
        if(!is.null(nn_size)){
            gr_size = nn_size
        }else{
            gr_size = c(1,3*(1:10))
        }
        if(!is.null(nn_decay)){
            gr_decay = nn_decay
        }else{
            gr_decay = 1*10^(-(1:9))
        }
        y = as.matrix(dat1[,vars[1]])
        miny = min(y)
        maxy = max(y)
        dat2 = dat1
        dat2[,vars[1]] = minmax(y,miny,maxy)
        grid1 = expand.grid(size=gr_size,decay=gr_decay)
        train1 = train(form1,data=dat2,method="nnet",maxit=nn_maxit,
          abstol=nn_abstol,reltol=nn_reltol,linout=TRUE,trace=FALSE,
          trControl=trainControl(method="boot",number=100),tuneGrid=grid1,
          metric="RMSE")
        nn_size = train1$bestTune[1,1]
        nn_decay = train1$bestTune[1,2]
    }
    fit1 = multivar(form1,dat1,size=nn_size,decay=nn_decay,maxit=nn_maxit,
      abstol=nn_abstol,reltol=nn_reltol,trace=FALSE)
    sfit1 = summary(fit1)
    sfit2 = summary_multivar(fit1)
    if(length(vars) > 1){
        t1 = olden(fit1,bar_plot=FALSE)
    }
    f2 = paste(f1,"_1.log",sep="")
    f3 = paste(f1,"_2.log",sep="")
    f4 = paste(f1,"_3.log",sep="")
    f5 = paste(f1,".csv",sep="")
    capture.output(print(sfit1),file=f2,append=FALSE,type="output")
    capture.output(stats:::print.summary.lm(sfit2),file=f3,append=FALSE,
      type="output")
    if(exists("train1")){
        capture.output(train1,file=f4,append=FALSE,type="output")
    }
    if(length(vars) > 1){
        write.table(t1,file=f5,sep=",",row.names=TRUE,col.names=NA)
    }
    f2 = paste(f1,"_1",sep="")
    y = dat1[,vars[1]]
    f = fit1$fitted.values
    r = fit1$residuals
    for(i1 in c("eps","tiff")){
        if(i1 == "eps"){
            postscript(file=paste(f2,".eps",sep=""),width=7.0,height=7.0,
              colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special",
              family="Helvetica")
        }else{
            tiff(file=paste(f2,".tif",sep=""),units="in",width=7.0,height=7.0,
              res=300,compression="lzw",family="sans")
        }
        oldpar = par(mfcol=c(2,2),mar=c(2.2,2.2,1.2,1.2),mgp=c(1.0,0.2,0.0),
          tcl=-0.2,cex=0.8,cex.lab=0.8,cex.axis=0.8,cex.main=0.9)

        qqnorm(r,col=4); qqline(r)                        #wg-err_norm: qqplot
        plot(f,sqrt(abs(r)),xlab="Fitted",ylab="sqrt(abs(Residuals))",col=4)
        abline(h=0,lty=2)                                 #wg-err_var: scatterplot
        hist(r,freq=FALSE,main="",col=4,xlab="Residuals") #wg-err_norm: histogram
        plot(f,y,xlab="Fitted values",ylab="Values",main=main,col=4)
        abline(c(0,1),lty=2)                              #goodness-of-fit: scatterplot
        par(oldpar)
        invisible(dev.off())
    }
    if(length(vars) > 1){
        f2 = paste(f1,"_2",sep="")
        for(i1 in c("eps","tiff")){
            if(i1 == "eps"){
                postscript(file=paste(f2,".eps",sep=""),width=7.0,height=7.0,
                  colormodel="rgb",horizontal=FALSE,onefile=FALSE,
                  paper="special",family="Helvetica")
            }else{
                tiff(file=paste(f2,".tif",sep=""),units="in",width=7.0,
                  height=7.0,res=300,compression="lzw",family="sans")
            }
            oldpar = par(mar=c(1.1,1.1,2.1,1.1),mgp=c(0,0,0),xpd=TRUE,
              cex.main=0.9)
            plotnet(fit1,cex_val=0.7,circle_cex=3)
            par(oldpar)
            invisible(dev.off())
        }
    }
}

}


# Eliminamos los warnings del script ya que ensucian el script
options(warn=-1)

# Realizamos los imports necesarios
library(caret)

load("har.RData")

# Configuramos nuestro identificador universitario
uo <- 236856
n_instancias <- 10000

set.seed(uo) #Pon aquí los número de tu UO
filtered <- har[sample(nrow(har)-1,n_instancias),]

filtered$age<-NULL
filtered$user<-NULL
filtered$gender<-NULL
filtered$how_tall_in_meters<-NULL
filtered$weight<-NULL
filtered$body_mass_index<-NULL

# Mostramos los datos con los que trabajaremos.
head(filtered)

training_percentage <- .8

set.seed(uo)
inTrain <- createDataPartition(
    # indicamos la clase
    y = filtered$class,

    # el porcentaje de instancias para entrenamiento
    p = training_percentage,

    # controla el formato de salida
    list = FALSE
)

# Definimos nuestras particiones de entrenamiento y validación.
training <- filtered[ inTrain,]
testing <- filtered[-inTrain,]

crossValidation <- trainControl(method = "cv", number = 10)

cat('Número de datos de cada clase: \n')
summary(filtered$class)
cat('\nPorcentaje de datos de cada clase: \n')
summary(filtered$class)/sum(summary(filtered$class))

# Creamos una función para ver los resultados de la validación interna
internalValidation <- function(model) {
  print(model)
  print(model$results[rownames(model$bestTune),1:4])
}

# Creamos una función para ver los resultados de la validación externa
externalValidation <- function(model, testingData = testing) {
  print(confusionMatrix(predict(model,testingData),testingData$class))
}

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

# Realizamos el entrenamiento de nuestro modelo con J48.
c4.5Fit <- train(
    class ~ .,
    data = training,
    method = "J48",
    trControl = crossValidation,
    tuneLength = 7,
    metric = "Kappa"
)

# Resultados validación interna
internalValidation(c4.5Fit)

# Resultados validación externa
externalValidation(c4.5Fit)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

# Realizamos el entrenamiento de nuestro modelo con rpart.
rpartFit <- train(
    class ~ .,
    data = training,
    method = "rpart",
    trControl = crossValidation,
    tuneLength = 10,
    metric = "Kappa"
)

# Resultados validación interna
internalValidation(rpartFit)

# Resultados validación externa
externalValidation(rpartFit)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

# Realizamos el entrenamiento de nuestro modelo con rpart2.
rpart2Fit <- train(
    class ~ .,
    data = training,
    method = "rpart2",
    trControl = crossValidation,
    tuneLength = 21,
    metric = "Kappa"
)

# Resultados validación interna
internalValidation(rpart2Fit)

# Resultados validación externa
externalValidation(rpart2Fit)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

# Realizamos el entrenamiento de nuestro modelo con knn.
knnFit <- train(
  class ~ .,
  data = training,
  method = "knn",
  trControl = crossValidation,
  tuneLength = 10, # k. Número de vecinos a comprobar.
  metric = "Kappa"
)

# Resultados validación interna
internalValidation(knnFit)

# Resultados validación externa
externalValidation(knnFit)

plotNNErrorEvolution <- function(nnModel){
  ggplot() + geom_line(aes(x=1:length(nnModel$finalModel$IterativeFitError),
                           y=nnModel$finalModel$IterativeFitError)) +
  xlab("Iteraciones") + ylab("Error")
}

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

# Realizamos el entrenamiento de nuestro modelo
nn1LFit <- train(
    class ~ .,
    data = training,
    method = "mlp",
    trControl = crossValidation,
    metric = "Kappa",
    preProcess=c("center","scale"),
    tuneGrid = data.frame(size=seq(9,30,3))
)

nneurons1L <- nn1LFit$results[rownames(nn1LFit$bestTune),1]

# Resultados validación interna
internalValidation(nn1LFit)

externalValidation(nn1LFit)

# Dibujamos la evolución del error a lo largo de las iteraciones de la red
plotNNErrorEvolution(nn1LFit)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

# Realizamos el entrenamiento de nuestro modelo
nn1LFit2_maxit300 <- train(
    class ~ .,
    data = training,
    method = "mlp",
    trControl = crossValidation,
    metric = "Kappa",
    preProcess=c("center","scale"),
    tuneGrid = data.frame(size=seq(9,30,3)),
    maxit=300
)

# Resultados validación interna
internalValidation(nn1LFit2_maxit300)

externalValidation(nn1LFit2_maxit300)

# Dibujamos la evolución del error a lo largo de las iteraciones de la red
plotNNErrorEvolution(nn1LFit2_maxit300)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

# Realizamos el entrenamiento de nuestro modelo
nn1LFit2_maxit300_lr02 <- train(
    class ~ .,
    data = training,
    method = "mlp",
    trControl = crossValidation,
    metric = "Kappa",
    preProcess=c("center","scale"),
    tuneGrid = data.frame(size=seq(9,30,3)),
    maxit=300,
    leanFuncParam = c(0.01,0)
)

externalValidation(nn1LFit2_maxit300_lr02)

# Dibujamos la evolución del error a lo largo de las iteraciones de la red
plotNNErrorEvolution(nn1LFit2_maxit300_lr02)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

# Realizamos el entrenamiento de nuestro modelo
nn2LFit <- train(
    class ~ .,
    data = training,
    method = "mlpML",
    trControl = crossValidation,
    tuneGrid = expand.grid(layer1=seq(10,14,2),
                           layer2=seq(10,14,2),
                           layer3=0)
)

internalValidation(nn2LFit)

externalValidation(nn2LFit)

# Dibujamos la evolución del error a lo largo de las iteraciones de la red
plotNNErrorEvolution(nn2LFit)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

# Realizamos el entrenamiento de nuestro modelo
nn2LFit_500 <- train(
    class ~ .,
    data = training,
    method = "mlpML",
    trControl = crossValidation,
    learnFuncParams = c(0.02,0),
    maxit = 500,
    metric = "Kappa",
    tuneGrid = expand.grid(layer1=seq(10,14,2),
                           layer2=seq(10,14,2),
                           layer3=0)
)

internalValidation(nn2LFit)

externalValidation(nn2LFit_500)

# Dibujamos la evolución del error a lo largo de las iteraciones de la red
plotNNErrorEvolution(nn2LFit_500)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

svmLinealFit <- train(
    class ~ .,
    data = training,
    method = "svmLinear",
    trControl = crossValidation,
    tuneGrid = data.frame(C=c(0.5, 1, 5, 10, 20, 40, 80)),
    metric = "kappa"
)

# Resultados validación interna
internalValidation(svmLinealFit)

# Resultados validación externa
externalValidation(svmLinealFit)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

svmPolyFit <- train(
    class ~ .,
    data = training,
    method = "svmPoly",
    trControl = crossValidation,
    tuneGrid = expand.grid(degree=c(1,3,5,10),C=c(1,3,5),scale = c(0.1, 0.5, 1)),
    metric = "kappa"
)

# Resultados validación interna
internalValidation(svmPolyFit)
externalValidation(svmPolyFit)

# Plantamos la semilla para obtener un valor constante tras cada ejecución.
set.seed(uo)

svmRadialFit <- train(
    class ~ .,
    data = training,
    method = "svmRadial",
    trControl = crossValidation,
    tuneGrid = expand.grid(sigma=c(1,3),C=c(1,5,6,7)),
    metric = "kappa"
)

# Resultados validación interna
internalValidation(svmRadialFit)
externalValidation(svmRadialFit)

set.seed(uo)
rfFit <- train(
    class ~ .,
    data = training,
    method = "rf",
    trControl = crossValidation,
    tuneGrid = data.frame(mtry=seq(2,30,4)),
    metric = "Kappa"
)

rfFit$finalModel
# Resultados validación interna
internalValidation(rfFit)
externalValidation(rfFit)

kappaRF <- 0.9832
kappaKNN <- 0.9658
kappaSVM <- 0.959
kappaNN <- 0.9362
kappaDT <- 0.924

binomialTest <- function(percentageSuccess1, percentageSuccess2, testingData = testing){
  binom.test(
    round(c(percentageSuccess1, 1-percentageSuccess1)* # porcentaje de acierto y error
            nrow(testingData)), # multiplicado por el número de instancias
                                # para obtener el número total de aciertos y fallos
    p = percentageSuccess2 # el porcentaje de acierto del modelo con el que comparar
  )
}

binomialTest(kappaRF, kappaKNN) # Comparación NN y SVM

binomialTest(kappaRF, kappaSVM) # Comparación NN y RF

binomialTest(kappaRF, kappaNN) # Comparación NN y kNN

options(repr.plot.width=15, repr.plot.height=10)
dfm.resamp <- data.frame(Accuracy = c(nn1LFit$resample$Kappa,
                                      c4.5Fit$resample$Kappa,
                                      knnFit$resample$Kappa,
                                      svmPolyFit$resample$Kappa,
                                      rfFit$resample$Kappa),
                        Model = rep(c('NeuralNet','C4.5','kNN', 'MVS', 'rF'), each=10))
ggplot(dfm.resamp,aes(x=Model, y=Accuracy, fill=Model)) + geom_boxplot() +
ggtitle("Distribución del porcetaje de acierto en el proceso de aprendizaje para cada paradigma") +
theme(plot.title = element_text(hjust = 0.5))


# Generates artificial threads
# store them in igraph objects
# and in dataframe representations useful to compute the likelihood
# author: Alberto Lumbreras
################################
library(igraph)
library(parallel)
library(data.table)
source('R/plotting.r')
source('R/thread_generators.r')
models <- c("Gomez2011", "Gomez2013", "Lumbreras2016unicluster", "Lumbreras2016")

ntrees <- 10000
ncores <- detectCores() - 2
model <- models[3]

##########################################
# Chose one of the models below
##########################################
# Gomez 2011
if(model == "Gomez2011"){
  alpha.root <- 0.734
  alpha.c <- 0.683
  beta.root <- 1.302
  trees <- replicate(ntrees,  gen.thread.Gomez2011(n=25, alpha.root=alpha.root, alpha.c=alpha.c, beta.root=beta.root), simplify = FALSE)
}

# Gomez 2013
if(model == "Gomez2013"){
  alpha <- 1
  beta <- 0.68
  tau <- 0.75
  trees <- replicate(ntrees, gen.thread.Gomez2013(n=25, alpha=alpha, beta=beta, tau=tau), simplify = FALSE)
}

# Lumbreras 2016 one cluster, one user
if(model == "Lumbreras2016unicluster"){
  users.by.cluster <- 50
  alphas <- 1
  betas <- 0.68
  taus <- 0.75
  z <- do.call(c, lapply(1:length(alphas), function(x) rep(x, users.by.cluster)))

  # parallel
  cl <- makeCluster(ncores)
  clusterEvalQ(cl, {library(igraph); source('R/thread_generators.r')})
  clusterExport(cl, c("alphas", "betas", "taus", "z"))
  trees <- parLapply(cl, 1:ntrees, function(i) gen.thread.Lumbreras2016(n=25, z=z, alphas=alphas, betas=betas, taus=taus) )
  stopCluster(cl)
}

# Lumbreras 2016
if(model == "Lumbreras2016"){
  users.by.cluster <- 1000
  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, users.by.cluster)))

  # parallel
  cl <- makeCluster(ncores)
  clusterEvalQ(cl, {library(igraph); source('R/thread_generators.r')})
  clusterExport(cl, c("alphas", "betas", "taus", "z"))
  trees <- parLapply(cl, 1:ntrees, 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
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')