# 4. faza: Napredna analiza podatkov

#NAPOVED RASTI BRUTO MINIMALNE PLAČE V SLOVENIJI

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

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

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


DaysToMonths<-function(days) {
	# Converts days to months using formula specified by contest
	#
	# Args:
	#	any numeric variable in days
	#
	# Returns:
	#	the same variable in months
	return(days/365.24*12)
}


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

source("tools.r")

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

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

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

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

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

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

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

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

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

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

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

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

  q = rep(NA, n_rank)

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

    P = scaled_eigenvectors %*% q

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

  X
}

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

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

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

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

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

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

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

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

    X[i, ] = x
  }
  X
}

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

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

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

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

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

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

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

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

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

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

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

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

      while (cluster_grows) {
        cluster_grows = FALSE
        potential_connection = free_nodes

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

      u = runif(1, 0, 1)

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

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

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

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

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

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

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

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

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

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

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

  samples <- matrix(NA, n_sample, n_particles)

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

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

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

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

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

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

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

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

  X
}


library(readr)
phone_accel_data <- read_csv("~/GitHub/HITI/data/processed/phone/accel/data.csv")
watch_accel_data <- read_csv("~/GitHub/HITI/data/processed/watch/accel/data.csv")

#Specify Variable name
var='S'
phone_accel_data <- subset(phone_gyro,activity==var)
watch_accel_data <- subset(watch_gyro,activity==var)

library(mvoutlier)
chisq.plot(phone_accel_data[,4:6],quan=1,ask=FALSE)
chisq.plot(watch_accel_data[,4:6],quan=1,ask=FALSE)

library(pcaPP)
par(cex=1.5)
plotcov(cov(phone_accel_data[,4:6]),cov(watch_accel_data[,4:6]),method1="Group 1",method2="Group 2")

library(rrcov)
t2<-T2.test(x=phone_accel_data[,4:6], y=watch_accel_data[,4:6])
t2$statistic
t2$p.value


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#criado:     02.07.2017
#modificado: 02.07.2017

library("nnet")
library("caret")
library("NeuralNetTools")

trainset <- read.csv("../data/ripley-set.csv",header=TRUE)
trainset[,"label"] = factor(trainset[,"label"],levels=c("0","1"))

#Create testing set by sampling with replacement
n <- nrow(trainset)
bootindex <- sample(1:n,size=n,replace=TRUE)
testset <- trainset[bootindex,]

#Select settings for artificial neural network
nn_decay <- 0.3  #weight decay (improved version of learning rate)
nn_maxit <- 500  #maximum number of iterations
grid1 <- expand.grid(size=1:5,decay=nn_decay)
train1 <- train(label ~.,              #model design
                trainset,              #training set
                maxit=nn_maxit,        #maximum number of iterations
                tuneGrid=grid1,        #parameter space to explore
                metric="Accuracy",     #metric to evaluate models
                method="nnet",trace=FALSE)
nn_size <- train1$bestTune[1,1] #number of nodes in hidden layer

#Perform Neural Network fit
mod <- nnet(label ~.,       #model design
            trainset,       #training set
            size=nn_size,decay=nn_decay,maxit=nn_maxit)
print(mod)
summary(mod)
plotnet(mod,cex_val=0.7,circle_cex=3)
olden(mod,bar_plot=TRUE)
res <- predict(mod,          #model
               testset,      #testing set
               type="class") #returns classification/probabilities

#Confusion Matrix
conf_mat <- table(testset[,c("label")],res)
conf_mat

#Error rate
err_rt <- 100*(sum(conf_mat) - sum(diag(conf_mat)))/sum(conf_mat)
err_rt


# Defines several coefficents for the drift and diffusion.
# Also defines functions for conversions between processes related through a lamperti transform.

#################################
## General Coefficients
#################################

make_constant_coefficient <- function(const_val)
    # Creates a function that returns a constant.
    #
    # Args:
    #     const_val (numeric): The value that the produced function should return
    # Returns:
    #     (function(anything, anything)): A function that will always return const_val
    function(t,x) const_val

make_affine_coefficient <- function(a, b)
    # Creates a affine function a*x+b.
    #
    # Args:
    #     a (numeric): The constant term of the affine function
    #     b (numeric): The first order term of the affine function
    # Returns:
    #     (function(anything, numeric)): A function that returns a*x+b
    function(t,x) a*x + b

#################################
## Drift Coefficients
#################################

make_mean_reverting_coefficient <- function(reversion_rate, long_term_mean)
    # Creates a mean reverting function of the form -reversion_rate(x-long_term_mean)
    #
    # Args:
    #     reversion_rate (numeric): The mean reverting rate
    #     long_term_mean (numeric): The value that the process reverts to.
    # Returns:
    #     (function(anything, numeric)): A function that returns -reversion_rate(x-long_term_mean)
    function(t,x) -reversion_rate*(x - long_term_mean)

mu_1d_from_paper <- function(t, y){
    # The drift coefficient. Implementing equation 5.2 from the paper.
    #
    # Args:
    #     t (numeric): The current time
    #     y (numeric): The Lamperti-transformed process
    sigma <- 0.4
    x <- convert_y_to_x_1d(y)
    denom <- 1 + x*x
    return(2*sigma*x/(denom*denom))
}

convert_y_to_x_1d <- function(y){
    # Converts Y_t to X_t in equation 5.2
    #
    # Args:
    #     y (numeric): The Lamperti-transformed process
    X0 <- 1
    sigma <- 0.4
    temp <- (27*X0*X0 + 81)*X0 + 162*sigma*y
    temp <- (.5*(sqrt(temp*temp + 2916) + temp))^(1.0/3) / 3
    return(temp - 1/temp)
}

convert_x_to_y_1d <- function(x){
    # Converts X_t to Y_t in equation 5.2
    #
    # Args:
    #     x (numeric): The original process
    X0 <- 1
    sigma <- .4
    return((x-X0 + (x*x*x - X0*X0*X0)/3) / (2*sigma))
}

make_mu_section_52_euler <- function(d)
    # Returns the drift coefficient function described in section 5.2 from the paper.
    #
    # Args:
    #     d (int): The current dimension
    function(t, x){
        # Args:
        #     t (numeric): The current time
        #     x (matrix): The current value of the process across all paths for this dimension
        x <- matrix(x)
        x[d,]*0.1*(sqrt(x[d,]) - 1)
    }

make_mu_from_paper_multi_dimension_lamperti <- function(d)
    # Returns the drift coefficient function of the lamperti transform
    # of the process described in section 5.2 from the paper.
    #
    # Args:
    #     d (int): The current dimension
    function(t, y){
        # Args:
        #     t (numeric): The current time
        #     y (matrix): The ending value of the process for each dimension and path
        X0 <- 1
        x <- convert_y_to_x_multi_d(y)
        return(0.2*(sqrt(x[d])-1) - 0.25)
    }

convert_y_to_x_multi_d <- function(y){
    # Converts Y_t (lamperti) to X_t from section 5.2
    #
    # Args:
    #     y (matrix or vector or numeric): Values of Y_t potentially across dimensions and timesteps
    # Returns:
    #     (matrix or vector or numeric): Values of X_t corresponding to each Y_t
    X0 <- 1
    return(X0*exp(0.5*y))
}

convert_x_to_y_multi_d <- function(x){
    # Converts X_t to Y_t (lamperti) from section 5.2
    #
    # Args:
    #     x (matrix or vector or numeric): Values of X_t potentially across dimensions and timesteps
    # Returns:
    #     (matrix or vector or numeric): Values of Y_t corresponding to each X_t
    X0 <- 1
    return(2*log(x/X0))
}

make_mu_heston_variance <- function(lambda, vbar)
    # Returns the drift coefficient function of the lamperti transform
    # of the Heston variance process
    #
    # Args:
    #     lambda (numeric): The mean reversion rate
    #     vbar (numeric): The long term mean
    function(t, v){
        # Args:
        #     t (numeric): The current time
        #     v (vector or numeric): The current variance
        if (any(v<=0)) print('(mu) v went <=0 !!!') # FIXME
        return(-lambda*((v>0)*v - vbar)) # full truncation
    }

make_mu_heston_variance_lamperti <- function(lambda, vbar, eta, v0){
    # Returns the drift coefficient function of the lamperti transform
    # of the Heston variance process
    #
    # Args:
    #     lambda (numeric): The mean reversion rate
    #     vbar (numeric): The long term mean
    #     eta (numeric): The volatility of volatility
    #     v0 (numeric): The initial variance
    convert_y_to_x_heston_variance <- make_convert_y_to_x_heston_variance(eta, v0)
    function(t, y){
        # Args:
        #     t (numeric): The current time
        #     v (vector or numeric): The current variance
        v <- convert_y_to_x_heston_variance(y)
        if (any(v<=0)) print('(mu L) v went <=0 !!!') # FIXME
        v <- (v>0)*v # full truncation
        return((-lambda*(v-vbar)/eta - 0.25*eta) / sqrt(v))
    }
}

make_convert_y_to_x_heston_variance <- function(eta, v0)
    function(y){
        # Converts Y_t (lamperti) to v_t from the Heston variance process
        #
        # Args:
        #     y (matrix or vector or numeric): Values of Y_t potentially across dimensions and timesteps
        # Returns:
        #     (matrix or vector or numeric): Values of X_t corresponding to each Y_t
        rootv <- 0.5*eta*y + sqrt(v0)
        return(rootv*rootv)
    }

make_convert_x_to_y_heston_variance <- function(eta, v0)
    function(v)
        # Converts X_t to Y_t (lamperti) from the Heston variance process
        #
        # Args:
        #     x (matrix or vector or numeric): Values of X_t potentially across dimensions and timesteps
        # Returns:
        #     (matrix or vector or numeric): Values of Y_t corresponding to each X_t
        return(2*(sqrt(v)-sqrt(v0))/eta)

make_mu_black_scholes_lamperti <- function(mu, sigma)
    # Returns the drift coefficient function of the lamperti transform
    # of the Black Scholes process
    #
    # Args:
    #     TODO
    function(t, y)
        # Args:
        #     t (numeric): The current time
        #     y (matrix): The location of the Lamperti transformed process
        return(mu/sigma - 0.5*sigma)

make_convert_y_to_x_black_scholes <- function(sigma, X0)
    function(y)
        # Converts Y_t (lamperti) to v_t from the Black Scholes process
        #
        # Args:
        #     y (matrix or vector or numeric): Values of Y_t potentially across dimensions and timesteps
        # Returns:
        #     (matrix or vector or numeric): Values of X_t corresponding to each Y_t
        return(X0*exp(sigma*y))

make_convert_x_to_y_black_scholes <- function(sigma, X0)
    function(x)
        # Converts X_t to Y_t (lamperti) from the Black Scholes process
        #
        # Args:
        #     x (matrix or vector or numeric): Values of X_t potentially across dimensions and timesteps
        # Returns:
        #     (matrix or vector or numeric): Values of Y_t corresponding to each X_t
        return(log(x/X0)/sigma)

make_mu_sin <- function(a, k, phi, b)
    # Returns the drift coefficient function of the sin process
    # dX_t = (b + a*sin(n*pi*x))*dt + sigma*dW_t
    #
    # Args:
    #     a (numeric): The amplitude of the oscillatory process
    #     n (numeric): The frequency of the oscillatory process
    #     b (numeric): The drift of the sine process
    function(t, x)
        # Args:
        #     t (numeric): The current time
        #     x (matrix): The location of the process
        return(a*(sin(k*t + phi) + b))

#################################
## Diffusion Coefficients
#################################

sigma_from_paper <- function(t, x){
    # The diffusion coefficient. Implementing equation 5.1 from the paper.
    #
    # Args:
    #     t (numeric): The current time
    #     x (array_like): The previous value of the process for each path
    sigma <- 0.4
    return(2*sigma/(1+x*x))
}

sigma_deriv_from_paper <- function(t, x){
    # The derivative of the diffusion coefficient. Implementing equation 5.1 from the paper.
    #
    # Args:
    #     t (numeric): The current time
    #     x (array_like): The previous value of the process for each path
    sigma <- 0.4
    denom <- 1 + x*x
    return(-4*x*sigma / (denom*denom))
}

make_sigma_section_52_euler <- function(d)
    # Returns the diffusion coefficient function described in section 5.2 from the paper.
    #
    # Args:
    #     d (int): The current dimension
    function(t, x){
        # Args:
        #     t (numeric): The current time
        #     x (matrix): The current value of the process across all paths for this dimension
        x <- matrix(x)
        return(0.5*x[d,])
    }

make_sigma_cir <- function(eta)
    # Returns the CIR diffusion coefficient function eta*sqrt(X_t)
    #
    # Args:
    #     eta (numeric): The diffusion scaling parameter.
    function(t, x){
        # Args:
        #     t (numeric): The current time
        #     x (matrix): The ending value of the process for each dimension and path
        if (any(x<=0)) print('(CIR) x went <=0 !!!') # FIXME
        return(eta*sqrt((x>0)*x)) # full truncation
    }


Temporal_Jaccard<-function(pre,post){
  if(class(pre)!="matrix"){beta<-vegdist(rbind(pre,post),method = "jaccard")} else
  {beta<-rep(NA,nrow(pre))
   for(i in 1:nrow(pre)){
     beta[i]<-vegdist(rbind(pre[i,],post[i,]),method = "jaccard")}}
  return(beta)
}

Temporal_Bray<-function(pre,post){
  if(class(pre)!="matrix"){beta<-vegdist(rbind(pre,post),method = "bray")} else
  {beta<-rep(NA,nrow(pre))
   for(i in 1:nrow(pre)){
     beta[i]<-vegdist(rbind(pre[i,],post[i,]),method = "bray")}}
  return(beta)
}

change_metrics<-function(x,means=T){
  SR_ts<-apply(x>0,3,rowSums)
  Com_abund_ts<-apply(x,3,rowSums)
  Shan_ts<-apply(x,3,renyi,hill=T,scales=c(1))
  Simp_ts<-apply(x,3,renyi,hill=T,scales=c(2))

  log_SR<-log(SR_ts[,-1]/SR_ts[,1])
  log_abund<-log(Com_abund_ts[,-1]/Com_abund_ts[,1])
  log_shan<-log(Shan_ts[,-1]/Shan_ts[,1])
  log_simp<-log(Simp_ts[,-1]/Simp_ts[,1])

  Jaccard<-log_simp
  for(i in 2:dim(x)[3]){
    Jaccard[,i-1]<-Temporal_Jaccard(pre = x[,,1],post = x[,,i])
  }

  Bray_Curtis<-log_simp
  for(i in 2:dim(x)[3]){
    Bray_Curtis[,i-1]<-Temporal_Bray(pre = x[,,1],post = x[,,i])
  }

  if(means==T){Change.df<-data.frame(log_SR=colMeans(log_SR),log_Abund=colMeans(log_abund),log_Shannon=colMeans(log_shan),log_Simpson=colMeans(log_simp),Jaccard=colMeans(Jaccard),Bray_Curtis=colMeans(Bray_Curtis),Stress=Stressor_sub[-1])
  } else{Change.df<-data.frame(log_SR=c(log_SR),log_Abund=c(log_abund),log_Shannon=c(log_shan),log_Simpson=c(log_simp),Jaccard=c(Jaccard),Bray_Curtis=c(Bray_Curtis),Stress=rep(Stressor_sub[-1],each=dim(x)[1]))}
  return(Change.df)
}


dataset = read.csv('Data_Preprocessing/Data.csv')

dataset$Age = ifelse(is.na(dataset$Age),
    ave(dataset$Age, FUN = function(x) mean(x, na.rm = TRUE)),
    dataset$Age
)

dataset$Salary = ifelse(is.na(dataset$Salary),
    ave(dataset$Salary, FUN = function(x) mean(x, na.rm = TRUE)),
    dataset$Salary
)

# Encoding categorical data
dataset$Country = factor(dataset$Country,
    levels = c('France', 'Germany', 'Spain'),
    labels = c(1, 2, 3))

dataset$Purchased = factor(dataset$Purchased,
    levels = c('Yes', 'No'),
    labels = c(0, 1))

# Split into testing and training sets
# install.packages('caTools')
library(caTools)
set.seed(123)
split = sample.split(dataset$Purchased, SplitRatio=0.8)

training_set = subset(dataset, split == TRUE)
testing_set = subset(dataset, split == FALSE)

# Feature scaling
training_set[, 2:3] = scale(training_set[, 2:3])
testing_set[, 2:3] = scale(testing_set[, 2:3])


##############################################################################
#
# Mark Cembrowski, Janelia Research Campus, Apr 8 2015
#
# This makes a dendrogram, and allows for masking of samples; it is initially
# based off of the cummeRbund implementation.
#
##############################################################################

dendro <- function (logMode=T,pseudocount=1,replicates=F,theMask=c(),theMethod='complete'){
	if(replicates){
		fpkmMat <- fpkmRepMat
	}
	else{
		fpkmMat <- fpkmPoolMat
	}
	if(logMode){
		fpkmMat <- log10(fpkmMat + pseudocount)
	}

	if(length(theMask)>0.1){
		toMask <- grepl(paste(theMask,collapse='|'),colnames(fpkmMat))
		fpkmMat <- fpkmMat[,!toMask]
	}

	res <- .JSdist(.makeprobs(fpkmMat))
	res <- as.dendrogram(hclust(res,method=theMethod))
	plot(res, main = paste("All", deparse(substitute(genes(cuff_data))),sep = " "))
}

.JSdist <- function(mat){
    res <- matrix(0, ncol = dim(mat)[2], nrow = dim(mat)[2])
    col_js <- apply(mat, MARGIN = 2, .shannon.entropy)
    colnames(res) <- colnames(mat)
    rownames(res) <- colnames(mat)
    for (i in 1:dim(mat)[2]) {
        for (j in i:dim(mat)[2]) {
            a <- mat[, i]
            b <- mat[, j]
            JSdiv <- .shannon.entropy((a + b)/2) - (col_js[i] +
                col_js[j]) * 0.5
            res[i, j] = sqrt(JSdiv)
            res[j, i] = sqrt(JSdiv)
        }
    }
    res <- as.dist(res)
    attr(res, "method") <- "JSdist"
    res
}

.makeprobs <- function(a){
    colSums <- apply(a, 2, sum)
    b <- t(t(a)/colSums)
    b[is.na(b)] = 0
    b
}

.shannon.entropy <- function(p){
    if (min(p) < 0 || sum(p) <= 0)
        return(Inf)
    p.norm <- p[p > 0]/sum(p)
    -sum(log2(p.norm) * p.norm)
}


Viterbi <- function(nQ, nS, A, E, Ini, Obs){
  # Viterbi's Algorithm: given HMM model & observed sequence, infer state path
  #
  # Args:
  #   mQ: number of states
  #   nS: number of different observed values
  #   A: transition matrix
  #   E: Emission matrix
  #   Ini: initial state prob
  #   Obs: observed sequence, an integer vector
  #
  # Output: A list of path(integer vector) and maximum likelihood(numerical)

  # Initialize vq
  vq <- Ini * E[, Obs[1]]
  nl <- length(Obs)
  # Update vq and save path
  i <- 2
  pathlist <- matrix(0, nQ, nl)
  pathlist[, 1] <- 1:nQ
  while (i <= nl){
    mat <- vq * A * (rep(1, nQ) %*% t(E[, Obs[i]]))
    vq <- apply(mat, 2, max)
    nextState <- apply(mat, 2, which.max)
    pathlist[, i] <- nextState
    i <- i + 1
  }
  ml <- max(vq)
  endState <- which.max(vq)
  path <- rep(0, nl)
  path[nl] <- endState
  for (i in (nl - 1):1){
    path[i] <- pathlist[path[i + 1], i + 1]
  }
  output <- list(Path = path, Likelihood = ml)
  return(output)
}

E <- matrix(c(.7, .9, .6, .2, .05, .3, .1, .05, .1), 3, 3)
A <- matrix(c(.1, .9, .7, .5, .05, .2, .4, .05, .1), 3, 3)
Obs <- c(3, 1, 2, 3, 1)
Ini <- c(.2, .4, .4)
Viterbi(3, 3, A, E, Ini, Obs)
#"3" "1" "3" "1" "2"

#Comparison between "HMM" and this function. Viterbi is 30% faster.
library(HMM)
hmm <- initHMM(c("1", "2", "3"), c("a", "b", "c"), Ini, A, E)
Obsletter <- c("c", "a", "b", "c", "a")

library(microbenchmark)
microbenchmark(viterbi(hmm, Obsletter), Viterbi(3, 3, A, E, Ini, Obs))


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

# Initialization
rm(list=ls())
library(stochvol)
set.seed(0) # for replication
options(digits=17)
vt   = read.table('vyt2014.txt',sep = '\t')
T    = dim(vt)[1]
N    = dim(vt)[2]
for (i in 1: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
m    = matrix(0,T+3,N)
g    = matrix(0,3,N)
for (i in 1:N){
	draws  = svsample(vt[,i],draws=S,burnin=burn,quiet=TRUE,thinpara=10,thinlatent=10)
	all    = cbind(draws$para,draws$latent)
	m[,i]  = colMeans(all)
	g[,i]  = geweke.diag(draws$para)$z
	name   = sprintf('svydraws%d.txt',i)
#	write(t(all),file=name,ncolumn=dim(all)[2])
}
out = rbind(m,g) #include Geweke statistics
write(t(out),file='svymeans2014.txt',ncolumn=dim(out)[2])


library(lme4)
library(lmerTest)
library(readr)
library(emmeans)

# read in data from 4-way ANOVA with between-subject and within-subject factors
df_full <- read_csv("/Users/neichert/scratch/MSMstuff/targets_L.csv")

# with crossed-random effects
my_model_fit <- lmer(value ~ species * tract + (1|p_h/p_s), df_full, contrasts = list(species = "contr.sum", tract = "contr.sum"))

# display results of linear regression
summary(my_model_fit)
# main and interaction effects
anova(my_model_fit)
# random effects
rand(my_model_fit)

# post-hoc t-test for tracts
emmeans(my_model_fit, list(pairwise ~ tract * species), adjust = "tukey")
# post-hoc t-test for all combinations
emmeans(my_model_fit, list(pairwise ~ tract), adjust = "tukey")

# access underlying model for fixed effects
my_glm_fe = model.matrix(my_model_fit)
# access underlying model for random effects
my_glm_re = as.matrix(getME(my_model_fit, "Zt"))

# inspect matrices
image(t(my_glm_fe))
image(t(my_glm_re))

write.table(my_glm_fe, file = "/rootdir/palm_GLM/my_glm_fe.csv", row.names=FALSE, quote=FALSE)
write.table(t(my_glm_re), file = "/rootdir/palm_GLM/my_glm_re.csv", row.names=FALSE, quote=FALSE)


library(rstan)

d <- read.csv(file='…/ch.5/input/data4a.csv')
d_conv <- data.frame(X=c(0, 1))
rownames(d_conv) <- c('C', 'T')
data <- list(I=nrow(d), N=d$N, Y=d$y, X=d$x, F=d_conv[d$f,])
fit <- stan(file='…/ch.5/e/ex7.stan', data=data, seed=1234)


#' Build a cell graph using balanced knn graph on given gene features
#'
#' @param mat_id matrix object id
#' @param gset_id gset object id defining the features used for distances
#' @param graph_id  new graph id to create
#' @param K the guideline Knn parameter. The balanced will be constructed aiming at K edges per cell
#'
#' @export

mcell_add_cgraph_from_mat_bknn = function(mat_id, gset_id, graph_id, K, dsamp=F)
{
	feat = gset_get_feat_mat(gset_id, mat_id, downsamp=dsamp, add_non_dsamp=dsamp)
	k_nonz_exp = get_param("scm_k_nonz_exp")
	feat = log2(1+k_nonz_exp*as.matrix(feat))

	message("will build balanced knn graph on ", ncol(feat), " cells and ", nrow(feat), " genes, this can be a bit heavy for >20,000 cells")
	k_alpha = get_param("scm_balance_graph_k_alpha")
	k_beta = get_param("scm_balance_graph_k_beta")
	k_expand = get_param("scm_balance_graph_k_expand")
	gr = tgs_cor_graph(x=feat, knn=K, k_expand=k_expand, k_alpha=k_alpha, k_beta=k_beta)
	cnames = colnames(feat)
	colnames(gr) = c("mc1","mc2","w")

	scdb_add_cgraph(graph_id, tgCellGraph(gr, cnames))
}
#' Build a cell graph using raw knn graph on given gene features
#'
#' @param mat_id matrix object id
#' @param gset_id gset object id defining the features used for distances
#' @param graph_id  new graph id to create
#' @param K the guideline Knn parameter. The balanced will be constructed aiming at K edges per cell
#'
#' @export

mcell_add_cgraph_from_mat_raw_knn = function(mat_id, gset_id, graph_id, K, dsamp=F)
{
	feat = gset_get_feat_mat(gset_id, mat_id, downsamp=dsamp, add_non_dsamp=dsamp)
	k_nonz_exp = get_param("scm_k_nonz_exp")
	feat = log2(1+k_nonz_exp*as.matrix(feat))

	message("will build raw knn graph on ", ncol(feat), " cells and ", nrow(feat), " genes, this can be a bit heavy for >20,000 cells")

	mcor = tgs_cor(x=feat)
	x_knn = tgs_knn(mcor, K)
	gr = x_knn[,c("col1", "col2")]
	gr$w = 1-(x_knn$rank-1)/K
	cnames = colnames(feat)
	colnames(gr) = c("mc1","mc2","w")

	scdb_add_cgraph(graph_id, tgCellGraph(gr, cnames))
}
#' Compute a cell cell correlation matrix using features defined by a gene set
#'
#' @param mat_id matrix object id
#' @param gset_id gset object id defining the features used for distances
#'
#' @export

mcell_gen_cell_cor_gset = function(mat_id, gset_id, dsamp=F)
{
	feat = gset_get_feat_mat(gset_id, mat_id, downsamp=dsamp, add_non_dsamp=dsamp)
	k_nonz_exp = get_param("scm_k_nonz_exp")
	feat = log2(1+k_nonz_exp*as.matrix(feat))

	return(tgs_cor(feat))
}


library(tidyverse)        # 1.3.1
library(xgboost)          # 1.4.1.1
library(keras)            # 2.4.0
library(mboost)           # 2.9.5
library(MetricsWeighted)  # 0.5.3
library(flashlight)       # 0.8.0

source(file.path("r", "functions.R"))
load("prep.RData", verbose = TRUE)
x_regional <- c(x_coord, x_vars[grep("dist", x_vars)])

#===============================================
# Data split
#===============================================

set.seed(1234321L)
.in <- sample(nrow(prep), round(0.80 * nrow(prep)), replace = FALSE)
train <- prep[.in, ]
test <- prep[-.in, ]
y_train <- train[[y_var]]
y_test <- test[[y_var]]

#===============================================
# OLS (without Lat/Lon)
#===============================================

form <- reformulate(x_vars, y_var) %>%
  update(. ~ . - LONGITUDE - LATITUDE - month_sold + factor(month_sold))
ols <- lm(form, data = train)
summary(ols)

#===============================================
# Component-wise boosting
#===============================================

mboost_form <-
  log_price ~ bols(log_living) + bols(log_land) + bols(log_special) +
    bols(age) + bols(structure_quality) +
    bbs(month_sold) + btree(s_dist_highway, s_dist_rail, dist_ocean,
    log_dist_water, s_dist_center, s_dist_sub, LATITUDE, LONGITUDE,
    tree_controls = partykit::ctree_control(maxdepth = 5))

fit_mboost <- gamboost(
  mboost_form,
  control = boost_control(trace = TRUE, nu = 0.1, mstop=1022),
  data = train
)

# Centering the encoder
regio_mboost_mean <- mean(get_regio_mboost(train))

# Optimizing number of boosting rounds
# cv5f <- cv(model.weights(fit_mboost), type = "kfold", B = 5)
# cvm <- cvrisk(fit_mboost, folds = cv5f)
# mstop(cvm)

#===============================================
# XGBoost (unconstrained)
#===============================================

# Data interface
dtrain <- xgb.DMatrix(
  data.matrix(train[, x_vars]),
  label = y_train
)

# Settings
tune <- FALSE
file_grid <- "grid_unconstrained.RData"

if (tune) {
  # Step 1: find learning rate
  xgb_cv(list(learning_rate = 0.1), verbose = 2)

  # Step 2: Grid search CV
  paramGrid <- make_grid()
  for (i in seq_len(nrow(paramGrid))) { # i = 1
    print(i)
    cvm <- xgb_cv(as.list(paramGrid[i, -(1:2)]))
    paramGrid[i, 1] <- bi <- cvm$best_iteration
    paramGrid[i, 2] <- as.numeric(cvm$evaluation_log[bi, "test_rmse_mean"])
    save(paramGrid, file = file_grid)
  }
}
load(file_grid, verbose = TRUE)

# Step 3: Fit on best params
head(paramGrid <- paramGrid[order(paramGrid$score), ])
params <- paramGrid[1, ]
cat("Best rmse (CV):", params$score) # 0.142
xgb_unconstrained <- xgb_train(
  as.list(params[, -(1:2)]),
  nrounds = params$iteration
)

#===============================================
# XGBoost (constrained)
#===============================================

# Build interaction constraint vector
ic <- c(
  list(which(x_vars %in% x_regional) - 1),
  as.list(which(!(x_vars %in% x_regional)) - 1)
)
# ic <- c(list(x_regional), as.list(setdiff(x_vars, x_regional)))

# Settings
tune <- FALSE
file_grid <- "grid_constrained.RData"

if (tune) {
  # Step 1: find learning rate
  xgb_cv(
    list(learning_rate = 0.1,
         interaction_constraints = ic),
    verbose = 2
  )

  # Step 2: Grid search CV
  paramGrid <- make_grid()
  for (i in seq_len(nrow(paramGrid))) { # i = 1
    print(i)
    params <- as.list(paramGrid[i, -(1:2)])
    params$interaction_constraints <- ic
    cvm <- xgb_cv(params)
    paramGrid[i, 1] <- bi <- cvm$best_iteration
    paramGrid[i, 2] <- as.numeric(cvm$evaluation_log[bi, "test_rmse_mean"])
    save(paramGrid, file = file_grid)
  }
}
load(file_grid, verbose = TRUE)

# Step 3: Fit on best params
head(paramGrid <- paramGrid[order(paramGrid$score), ])
params <- as.list(paramGrid[1, -(1:2)])
params$interaction_constraints <- ic
cat("Best rmse (CV):", paramGrid[1, "score"]) # 0.145
xgb_constrained <- xgb_train(
  params,
  nrounds = paramGrid[1, "iteration"]
)

# Centering the encoder
regio_xgb_mean <- mean(get_regio_xgb(train))

#===============================================
# OLS with XGB loc
#===============================================

train <- train %>%
  mutate(regio_xgb = get_regio_xgb(., regio_xgb_mean))
test <- test %>%
  mutate(regio_xgb = get_regio_xgb(., regio_xgb_mean))

ols_xgb <- lm(log_price ~ log_living + log_land + log_special +
                   age + structure_quality + factor(month_sold) +
                   regio_xgb,
                 data = train)
summary(ols_xgb)

#===============================================
# Neural net with regional encoding
#===============================================

x_dense <- setdiff(x_vars, "month_sold")
x_regional
x_object <- setdiff(x_dense, x_regional)

# Standardize X using X_train
sc <- list(
  center = attr(scale(data.matrix(train[, x_dense])), "scaled:center"),
  scale = attr(scale(data.matrix(train[, x_dense])), "scaled:scale")
)

# Callbacks
cb <- list(
  callback_early_stopping(patience = 20),
  callback_reduce_lr_on_plateau(patience = 5)
)

nn <- new_neural_net(0.003)
summary(nn)

# Fit model
history <- nn %>% fit(
  x = prep_nn(train),
  y = y_train,
  epochs = 105, # 200,
  batch_size = 128,
  #validation_split = 0.2,
  #callbacks = cb
)

# Last layer weights
nn$weights[[length(nn$weights) - 1]]

# Centering the encoder
regio_nn_mean <- mean(get_regio_nn(train))

#===============================================
# Interpretation
#===============================================

if (FALSE) {
  library(SHAPforxgboost)

  # Step 1: select some observations
  X <- data.matrix(prep[sample(nrow(prep), 1000), x_vars])

  # Step 2: Crunch SHAP values
  shap <- shap.prep(xgb_constrained, X_train = X)

  # Step 3: SHAP importance
  shap.plot.summary(shap)

  # Step 4: Loop over dependence plots in decreasing importance
  for (v in shap.importance(shap, names_only = TRUE)) {
    p <- shap.plot.dependence(shap, v, color_feature = "auto",
                              alpha = 0.5, jitter_width = 0.1) +
      ggtitle(v)
    print(p)
  }
}

# Set up explainers
pred_xgb <- function(m, X) predict(m, data.matrix(X[, x_vars]))

fl_ols <- flashlight(
  model = ols,
  label = "OLS",
)

fl_ols_xgb <- flashlight(
  model = ols_xgb,
  label = "OLS with XGB loc",
  predict_function = function(m, X) X %>%
    mutate(regio_xgb = get_regio_xgb(., regio_xgb_mean)) %>%
    predict(m, .)
)

fl_xgb <- flashlight(
  model = xgb_unconstrained,
  label = "XGB (unconstrained)",
  predict_function = pred_xgb
)

fl_xgb_c <- flashlight(
  model = xgb_constrained,
  label = "XGB STAR",
  predict_function = pred_xgb
)

fl_nn <- flashlight(
  model = nn,
  label = "NN STAR",
  predict_function = function(m, X)
    as.numeric(predict(m, prep_nn(X), batch_size = 1000))
)

fl_mboost <- flashlight(
  model = fit_mboost,
  label = "mboost STAR"
)

fls <- multiflashlight(
  list(fl_ols, fl_xgb, fl_xgb_c, fl_ols_xgb, fl_nn, fl_mboost),
  data = test,
  y = "log_price"
)

# Performance
perf <- light_performance(
  fls,
  metrics = list(RMSE = rmse, `R squared` = r_squared),
  reference_mean = mean(y_train) # to get clean test r-squared
)
perf_wide <- perf$data %>%
  pivot_wider(id_cols = "label", names_from = "metric",
              values_from = "value") %>%
  rename(Model = "label")
perf_wide

# Permutation importance
imp <- light_importance(fls, v = x_vars)
plot(imp, fill = "#03336B", facet_scales = "free_x")

# Interaction strength (takes long)
# inter <- light_interaction(fls, v = most_important(imp, 4),
#                            pairwise = TRUE)
# plot(inter, fill = "#03336B")

# ICE curves
light_ice(fls, v = "log_living", n_max = 200, seed = 245) %>%
  plot(alpha = 0.2, color = "#E69F00") +
  ylab("log appraisal")

light_ice(fls, v = "dist_ocean", n_max = 200, seed = 245) %>%
  plot(alpha = 0.2, color = "#E69F00")

# Map of regio effect (full data)
X_nn <- prep %>%
  mutate(regio = get_regio_nn(., regio_nn_mean),
         type = "Neural net")
X_xgb <- prep %>%
  mutate(regio = get_regio_xgb(., regio_xgb_mean),
         type = "XGBoost")
X_mboost <- prep %>%
  mutate(regio = get_regio_mboost(., regio_mboost_mean),
         type = "mboost")
rbind(X_nn, X_xgb, X_mboost) %>%
  mutate(type = factor(type, levels = c("XGBoost", "Neural net", "mboost"))) %>%
ggplot(aes(LONGITUDE, LATITUDE, z = regio)) +
  coord_quickmap() +
  stat_summary_2d(bins = 50) +
  facet_wrap(~ type) +
  labs(fill = "Relative effect",
       x = element_blank(),
       y = element_blank()) +
  scale_fill_viridis_c(option = "inferno", begin = 0.2) +
  theme_void(base_size = 12) +
  theme(axis.ticks = element_blank(),
        axis.text = element_blank(),
        strip.text.x = element_text(size = 14),
        legend.position = c(0.28, 0.2),
        legend.key.height = unit(5, units = "mm"),
        legend.background = element_rect(fill = "transparent",
                                         linetype = "blank"),
        plot.margin=grid::unit(c(0, 0, 0, 0), "mm"))


# source: https://www.ceremade.dauphine.fr/~xian/basudo.R
# Reference value (hard sudoku)
s=matrix(0,ncol=9,nrow=9)
s[1,8:9]=c(3,9)
s[2,c(6,9)]=c(1,5)
s[3,c(3,5,7)]=c(3,5,8)
s[4,c(3,5,9)]=c(8,9,6)
s[5,c(2,6)]=c(7,2)
s[6,c(1,4)]=c(1,4)
s[7,c(3,5,8)]=c(9,8,5)
s[8,c(2,7)]=c(2,6)
s[9,c(1,4)]=c(4,7)


# # Simulate Case 1 scores from paper
# r <- c(2^seq(1, 13), 3^seq(1, 8), 10, 105, 300, 1500, 15000)
# r <- r[order(r)]/150000
#
# myseed <- 569
# set.seed(myseed)
# m <- 150000
# pi.0.true <- 1/501
# X <- rbinom(n=m, size=1, prob=pi.0.true)
# s.vec.ls <- list(c(1, 1), c(1, 1))
# params <- list(c(sqrt(2) * .8, 0), c(sqrt(2) * .6, 0))
# dist <- "binorm"
# rho <- .9
# metric = "k"
# correction = "none"; method = "AH"
# z <- 1
# simreps = 10

power.test = function(params, pi.0.true, myseed=567, dist = "binorm",
                      simreps = 100, r.vec = c(.01, .1, .5), metric = "k",
                      m = 100, plus = T, method = "EmProc",
                      rho, s.vec.ls = list(c(1, 1), c(1, 1))) {

  eff_seeds <- sample(1:2^15, simreps)
  results <- foreach(z = 1:simreps, .export=c("normalCopula", "mvdc", "rMvdc", "PerfCurveTest", "mvrnorm", "EstLambda")) %dopar% {
    set.seed(eff_seeds[z])
    X = rbinom(n=m, size=1, prob=pi.0.true)
    if (sum(X)==0) X = rbinom(n=m, size=1, prob=pi.0.true)
    if(dist == "binorm") {
      # Target parameters for univariate normal distributions
      # Parameters for bivariate normal distribution
      s1 <- s.vec.ls[[1]][1] ; s2 <- s.vec.ls[[2]][1];
      sigma1 <- matrix(c(s1^2, s1*s2*rho, s1*s2*rho, s2^2), 2)
      s1 <- s.vec.ls[[1]][2]; s2 <- s.vec.ls[[2]][2];
      sigma2 <- matrix(c(s1^2, s1*s2*rho, s1*s2*rho, s2^2), 2)# Covariance matrix
      bvn1 <- mvrnorm(m, mu = c(params[[1]][1], params[[2]][1]), Sigma = sigma1)*X + mvrnorm(m, mu = c(params[[1]][2], params[[2]][2]), Sigma = sigma2)*(1-X)
      S1 <- bvn1[, 1]
      S2 <- bvn1[, 2]
    } else if(dist == "bibeta") {
      myCopPlus <- normalCopula(param=c(rho), dim = 2, dispstr = "un")
      myMvdPlus <- mvdc(copula=myCopPlus, margins=c("beta", "beta"),
                        paramMargins=list(list(shape1=params[[1]][[1]][1], shape2=params[[1]][[1]][2]),
                                          list(shape1=params[[2]][[1]][1], shape2=params[[2]][[1]][2])))
      myCopNeg <- normalCopula(param=c(rho), dim = 2, dispstr = "un")
      myMvdNeg <- mvdc(copula=myCopNeg, margins=c("beta", "beta"),
                       paramMargins=list(list(shape1=params[[1]][[2]][1], shape2=params[[1]][[2]][2]),
                                         list(shape1=params[[2]][[2]][1], shape2=params[[2]][[2]][2])))

      bvn1 <- rMvdc(m, myMvdPlus)*X + rMvdc(m, myMvdNeg)*(1-X)
      S1 <- bvn1[, 1]
      S2 <- bvn1[, 2]
    } else if(dist == "unif") {
      myCopPlus <- normalCopula(param=c(rho), dim = 2, dispstr = "un")
      myMvdPlus <- mvdc(copula=myCopPlus, margins=c("unif", "unif"),
                        paramMargins=list(list(min=params[[1]][[1]][1], max=params[[1]][[1]][2]),
                                          list(min=params[[2]][[1]][1], max=params[[2]][[1]][2])))
      myCopNeg <- normalCopula(param=c(rho), dim = 2, dispstr = "un")
      myMvdNeg <- mvdc(copula=myCopNeg, margins=c("unif", "unif"),
                       paramMargins=list(list(min=params[[1]][[2]][1], max=params[[1]][[2]][2]),
                                         list(min=params[[2]][[2]][1], max=params[[2]][[2]][2])))

      bvn1 <- rMvdc(m, myMvdPlus)*X + rMvdc(m, myMvdNeg)*(1-X)
      S1 <- bvn1[, 1]
      S2 <- bvn1[, 2]
    }

    PerfCurveTest(S1, S2, X, r = r.vec, metric = "rec", type = ifelse(method == "EmProc", "pointwise", "band"), method = method, plus = plus, alpha = .05, seed = eff_seeds[z])
  }

  sr <- length(results)
  covout <- matrix(NA, nrow=length(r.vec), ncol=sr)
  widthout <- matrix(NA, nrow=length(r.vec), ncol=sr)
  interval.ls <- list()

  for (i in 1:sr) {
    covout[, i] <- results[[i]]$p_value < .05
    widthout[, i] <- results[[i]]$ci_interval[, 2] - results[[i]]$ci_interval[, 1]
    interval.ls[[i]] <- results[[i]]$ci_interval
  }

  return(list(r = r.vec, covout = covout, widthout = widthout, interval.ls = interval.ls, params = params, eff_seeds))

}


##
## GEEs predicting farm work for all household dyads within villages
## - for households with Mosuo heads of house only
##
## produces Supplementary Table 2
##
rm(list=ls())

source("init.r")

library(data.table)
library(geepack)
library(MuMIn)
library(arm)  # for standardize()
library(ggplot2)
library(broom)

# load custom function to standardise GEE models
source("https://gist.githubusercontent.com/matthewgthomas/6e4ae7f55a339bd8c036/raw/cff5ba979c673ef6da3533afbb7bb09c1f42ed71/standardize-gee.r")

##########################################################
## Load data
##
# relative rank:
# +ve if alter is lower wealth rank than ego (e.g. alter=5 but ego=1 => relative rank = 4)
# -ve if alter is higher rank than ego (e.g. ego=2 but alter=1 => relative rank = -1)
hh.all = hh.dyads %>%
  # merge ego covariates
  left_join(hh %>% dplyr::select(Ego.HH = HH, Ego.WealthRank = WealthRank, Ego.Size = Size, Ego.zhu = zhubo1), by="Ego.HH") %>%

  # merge alter covariates
  left_join(hh %>% dplyr::select(Alter.HH = HH, Alter.WealthRank = WealthRank, Alter.Size = Size, Alter.zhu = zhubo1), by="Alter.HH") %>%

  # calculate some dyadic covariates
  mutate(GiftGiven.ind = ifelse(TotalGifts.ind > 0, 1, 0),
         ChildrenInAlter = ifelse(TotalChildrenInAlter > 0, 1, 0),
         RelativeWealthRank = Alter.WealthRank - Ego.WealthRank) %>%

  # keep only columns needed for GEEs
  dplyr::select(Ego.HH, Alter.HH, HelpObserved, GiftGiven.ind, Distance, r,
                AnySpousesInAlter, ChildrenInAlter, RelativeWealthRank,
                Ego.Size, Alter.Size, Ego.zhu, Alter.zhu) %>%

  na.omit() %>%
  arrange(Ego.HH, Alter.HH)  # make sure data are in correct order for GEE

hh.zhu = hh.all %>% filter(Ego.zhu==1)
hh.non = hh.all %>% filter(Ego.zhu==0)

# summaries
nrow(hh.zhu)  # no. dyads
length(unique(hh.zhu$Ego.HH))  # no. households

nrow(hh.non)  # no. dyads
length(unique(hh.non$Ego.HH))  # no. households

##########################################################
## GEE models predicting whether one household helped another on their farms
## - egos are zhu
##
# intercept-only model
gee.null.z = geeglm(HelpObserved ~ 1, id=Ego.HH, family="binomial", data=hh.zhu, corstr="exchangeable", scale.fix=T)

# control model (distance + size + wealth)
gee.control.z = geeglm(HelpObserved ~ Distance + RelativeWealthRank + Ego.Size + Alter.Size,
                       id=Ego.HH, family="binomial", data=hh.zhu, corstr="exchangeable", scale.fix=T)

# full model
gee.full.z = geeglm(HelpObserved ~ GiftGiven.ind + r + AnySpousesInAlter + ChildrenInAlter +
                      Alter.zhu + r:Alter.zhu +
                      Distance + RelativeWealthRank + Ego.Size + Alter.Size,
                    id=Ego.HH, family="binomial", data=hh.zhu, corstr="exchangeable", scale.fix=T)

##########################################################
## GEE models predicting whether one household helped another on their farms
## - egos are non-zhu
##
# intercept-only model
gee.null.n = geeglm(HelpObserved ~ 1, id=Ego.HH, family="binomial", data=hh.non, corstr="exchangeable", scale.fix=T)

# control model (distance + size + wealth)
gee.control.n = geeglm(HelpObserved ~ Distance + RelativeWealthRank + Ego.Size + Alter.Size,
                       id=Ego.HH, family="binomial", data=hh.non, corstr="exchangeable", scale.fix=T)

# full model
gee.full.n = geeglm(HelpObserved ~ GiftGiven.ind + r + AnySpousesInAlter + ChildrenInAlter +
                      Alter.zhu + r:Alter.zhu +
                      Distance + RelativeWealthRank + Ego.Size + Alter.Size,
                    id=Ego.HH, family="binomial", data=hh.non, corstr="exchangeable", scale.fix=T)

##########################################################
## Model selection - egos are zhu
##
(best.models.zhu = model.sel(gee.null.z, gee.control.z, gee.full.z, rank=QIC))

# gee.full is best-fitting
gee.best = get(row.names(best.models.zhu)[1])
# standardise coefficients
gee.best.z = standardize.gee(gee.best, standardize.y=F, binary.inputs="full")

# save model coefficients
tidy(gee.best.z) %>%
  bind_cols(confint_tidy(gee.best.z)) %>%  # calculate CIs
  mutate(OR = exp(estimate), OR.low = exp(conf.low), OR.high = exp(conf.high)) %>%
  write_csv(file.path(results.dir, "GEE - ego zhu.csv"))

# save model selection table
best.models.zhu %>%
  rownames_to_column(var = "Model") %>%
  dplyr::select(Model, delta, weight) %>%
  write_csv(file.path(results.dir, "GEE - ego zhu - model selection.csv"))

##########################################################
## Model selection - egos are non-zhu
##
(best.models.non = model.sel(gee.null.n, gee.control.n, gee.full.n, rank=QIC))

# gee.full is best-fitting
gee.best = get(row.names(best.models.non)[1])
# standardise coefficients
gee.best.z = standardize.gee(gee.best, standardize.y=F, binary.inputs="full")

# save model coefficients
tidy(gee.best.z) %>%
  bind_cols(confint_tidy(gee.best.z)) %>%  # calculate CIs
  mutate(OR = exp(estimate), OR.low = exp(conf.low), OR.high = exp(conf.high)) %>%
  write_csv(file.path(results.dir, "GEE - ego non-zhu.csv"))

# save model selection table
best.models.non %>%
  rownames_to_column(var = "Model") %>%
  dplyr::select(Model, delta, weight) %>%
  write_csv(file.path(results.dir, "GEE - ego non-zhu - model selection.csv"))

# Save models
save(hh.zhu, hh.non,
     gee.null.z, gee.control.z, gee.full.z, best.models.zhu,
     gee.null.n, gee.control.n, gee.full.n, best.models.non,
     file=file.path(models.dir, "gee.RData"))


library(rms)
set.seed(4)
n <- c(20000,2000,200)[1]
x2 <- rnorm(n)
x1 <- sqrt(.5) * x2 + rnorm(n, sd=sqrt(1-.5))
y  <- 1 * x1 + 1 * x2 + rnorm(n)

type <- c('mcar','mar.x2')[2]

x1m <- if(type=='mcar') ifelse(runif(n) < .5, x1, NA) else
 ifelse(rnorm(n,sd=.8) < x2, x1, NA)  # MAR on x2, R2 50%, 50% missing
coef(ols(y ~ x1+x2))
coef(ols(y ~ x1m + x2))

Ecdf(x1)
Ecdf(x1m, lty=2, add=TRUE)
Ecdf(x1[is.na(x1m)], lty=2, lwd=3, add=TRUE)

plot(x2, x1m)
plsmo(x2, is.na(x1m), datadensity=TRUE)
dd <- datadist(x2,x1m)
options(datadist='dd')
f <- lrm(is.na(x1m) ~ rcs(x2,4))
plot(Predict(f, x2, fun=plogis))

d <- data.frame(x1,x1m,x2,y)

# Find best-validating (in terms of bootstrap R^2) value of nk
g <- aregImpute(~ y + x1m + x2, nk=c(0,3:5), data=d)
g
# nk=0 is best with respect to mean and median absolute deviations
# Another good model is one that forces the target variable (x1m) to
# be transformed linearly using tlinear=TRUE

g <- aregImpute(~y + x1m + x2, nk=0, n.impute=5, data=d, pr=F,
    type=c('pmm','regression')[1], plotTrans=FALSE)
s <- is.na(x1m)
c(mean(g$imputed$x1), mean(x1[s]))
ix1 <- g$imputed$x1[,5]
x1i <- x1m
x1i[s] <- ix1
rcorr(cbind(x1,x2,y)[s,])
rcorr(cbind(x1i,x2,y)[s,])
# allowing x1 to be nonlinearly transformed seems to increase the
# correlation between imputed x1 and x2 and imputed x1 and y,
# in addition to variance of imputed values increasing

f <- fit.mult.impute(y ~ x1m + x2, ols, xtrans=g, data=d, pr=F)
coef(f)

g2 <- g
g1 <- g
plot(g1)
# Ecdf(g2, add=TRUE, col='blue') ??

# For MARx2, pmm works reasonably well when nk=3, regression doesn't
# both work well when nk=0
# For MCAR, pmm works well when nk=3, regression works moderately
# well but imputed values have higher variance than real x1 values
# when x1m is missing, and coefficient of x2 on y is 0.92 when n=20000
# Did not get worse by setting nk=6
# Regression imputation works fine with nk=6 with ~y+I(x1m)+x2
# Problem with I(y)+x1m+I(x2)

plot(g)
Ecdf(x1, add=TRUE, col='blue')
Ecdf(x1m, lty=2, add=TRUE)
Ecdf(x1[is.na(x1m)], lty=2, lwd=3, add=TRUE)

# Look at distribution of residuals from areg for various nk
s <- !is.na(x1m)
f <- lm.fit.qr.bare(cbind(y,x2)[s,],x1m[s])
Ecdf(resid(f), lwd=2, col='gray')
py <- f$fitted.values
ry <- resid(f)

g <- areg(cbind(y,x2), x1m, nk=6, xtype=rep('l',2))
p <- g$linear.predictors
r <- resid(g)
Ecdf(r, add=TRUE, col='blue')

plot(py, p)
coef(lm.fit.qr.bare(py,p))
plot(ry,r)
coef(lm.fit.qr.bare(ry,r))
cor(ry,r)
sd(ry)
sd(r)
pr  <- predict(g, cbind(x1, x2))
pr2 <- g$linear.predictors
describe(pr-pr2)
Pr <- fitted(f)
plot(Pr,pr)   # ??
coef(lm.fit.qr.bare(Pr,pr))

obs.trans <- pr + r
plot(obs.trans, y)
w <- lm.fit.qr.bare(obs.trans,y)
coef(w)
w$rsquared

# Strip out aregImpute code for regression imputation, force linearity,
# no bootstrap, x1 is only variable with NAs

ai <- function(x1, x2, y) {
  n <- length(x1)
  na <- (1:n)[is.na(x1)]
  nna <- length(na)
  j <- (1:n)[-na]

  f <- lm.fit.qr.bare(cbind(y,x2)[j,], x1[j])
  prn(coef(f))

  # Predicted mean x1 for only those that missing:
  predx1 <- matxv(cbind(y,x2)[na,], coef(f))
  Ecdf(predx1, add=TRUE, col='blue')
  res <- f$residuals
  rp <- length(na) > length(res)
  px1  <- predx1 + sample(res, length(na), replace=rp)
  px1e <- approxExtrap(f$fitted.values, f$fitted.values, xout=px1)$y
  print(describe(abs(px1-px1e)))
  Ecdf(px1e, add=TRUE, col='green')
  x1[na] <- px1e
  x1
}

x1i <- ai(x1m, x2, y)
ols(y ~ x1i + x2)


R version 3.3.2 (2016-10-31) -- "Sincere Pumpkin Patch"
Copyright (C) 2016 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

 library(dataRetrieval)
 library(dplyr)

 siteNumber<-c("01538000")

 parameterCd <- "00060"

 Q_daily <- readNWISdv(siteNumber, parameterCd)

 tail(Q_daily)

 str(Q_daily)

 Q_daily <- renameNWISColumns(Q_daily)

 tail(Q_daily)

 stationInfo <- readNWISsite(siteNumber)

 if(as.numeric(diff(range(Q_daily$Date))) != (nrow(Q_daily)+1)){
     fullDates <- seq(from=min(Q_daily$Date),
                      to = max(Q_daily$Date), by="1 day")
     fullDates <- data.frame(Date = fullDates,
                             agency_cd = Q_daily$agency_cd[1],
                             site_no = Q_daily$site_no[1],
                             stringsAsFactors = FALSE)
     Q_daily <- full_join(Q_daily, fullDates,
                         by=c("Date","agency_cd","site_no")) %>%
         arrange(Date)
 }

 moving_avg <- function(x,n=30){stats::filter(x,rep(1/n,n), sides=1)}

 Q_daily <- Q_daily %>% mutate(rollMean = as.numeric(moving_avg(Flow)), day.of.year = as.numeric(strftime(Date, format = "%j")))

 tail(Q_daily)

 Q_summary <- Q_daily %>%
     group_by(day.of.year) %>%
     summarize(p75 = quantile(rollMean, probs = .75, na.rm = TRUE),
               p25 = quantile(rollMean, probs = .25, na.rm = TRUE),
               p10 = quantile(rollMean, probs = 0.1, na.rm = TRUE),
               p05 = quantile(rollMean, probs = 0.05, na.rm = TRUE),
               p00 = quantile(rollMean, probs = 0, na.rm = TRUE))

 current_year <- as.numeric(strftime(Sys.Date(), format = "%Y"))

 summary.0 <- Q_summary %>% mutate(Date = as.Date(day.of.year - 1, origin = paste0(current_year-2,"-01-01")), day.of.year = day.of.year - 365)

 summary.1 <- Q_summary %>% mutate(Date = as.Date(day.of.year - 1, origin = paste0(current_year-1,"-01-01")))

 summary.2 <- Q_summary %>% mutate(Date = as.Date(day.of.year - 1, origin = paste0(current_year,"-01-01")), day.of.year = day.of.year  365)

 Q_summary <- bind_rows(summary.0, summary.1, summary.2)

 Q_summary

 smooth.span <- 0.3

 Q_summary$sm.75 <- predict(loess(p75~day.of.year, data = Q_summary, span = smooth.span))

 head(Q_summary$sm.75)

 Q_summary$sm.25 <- predict(loess(p25~day.of.year, data = Q_summary, span = smooth.span))

 head(summaryQ$sm.25)

 Q_summary$sm.10 <- predict(loess(p10~day.of.year, data = Q_summary, span = smooth.span))

 head(summaryQ$sm.10)

 Q_summary$sm.05 <- predict(loess(p05~day.of.year, data = Q_summary, span = smooth.span))

 head(summaryQ$sm.05)

 Q_summary$sm.00 <- predict(loess(p00~day.of.year, data = Q_summary, span = smooth.span))

 head(summaryQ$sm.00)

 Q_summary <- select(Q_summary, Date, day.of.year, sm.75, sm.25, sm.10, sm.05, sm.00) %>% filter(Date = as.Date(paste0(current_year-1,"-01-01")))

 Q_summary

 latest.years <- Q_daily %>% filter(Date = as.Date(paste0(current_year-1,"-01-01"))) %>% mutate(day.of.year = 1:nrow(.))

 title.text <- paste0(stationInfo$station_nm,"\n", "Provisional Data - Subject to change\n", "Record Start = ", min(Q_daily$Date), "  Number of years = ", as.integer(as.numeric(difftime(time1 = max(Q_daily$Date), time2 = min(Q_daily$Date), units = "weeks"))/52.25), "\nDate of plot = ",Sys.Date(), "  Drainage Area = ",stationInfo$drain_area_va, "mi^2")

 mid.month.days <- c(15, 45, 74, 105, 135, 166, 196, 227, 258, 288, 319, 349)

 month.letters <- c("J","F","M","A","M","J","J","A","S","O","N","D")

 start.month.days <- c(1, 32, 61, 92, 121, 152, 182, 214, 245, 274, 305, 335)

 label.text <- c("Normal","Drought Watch","Drought Warning","Drought Emergency")

 year1_summary <- data.frame(Q_summary[2:366,])

 head(year1_summary)

 year2_summary <- data.frame(Q_summary[367:733,])

 head(year2_summary)

 simple.plot <- ggplot(data = Q_summary, aes(x = day.of.year))
     geom_ribbon(aes(ymin = sm.25, ymax = sm.75, fill = "Normal"))
     geom_ribbon(aes(ymin = sm.10, ymax = sm.25, fill = "Drought Watch"))
     geom_ribbon(aes(ymin = sm.05, ymax = sm.10, fill = "Drought Warning"))
     geom_ribbon(aes(ymin = sm.00, ymax = sm.05, fill = "Drought Emergency"))
     scale_y_log10(limits = c(1,1000))
     geom_line(data = latest.years, aes(x=day.of.year, y=rollMean, color = "30-Day Mean"),size=2)
     geom_vline(xintercept = 365)

 simple.plot

Chapter 05/3Loess - United States Geological Survey.r


context("Check accuracy of TSLS with single instrument using Card data")

test_that("TSLS estimate without exogeneous covariates and intercept", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]

  foo = ivmodel(Y=Y,D=D,Z=Z,intercept=FALSE)
  tsls_output = as.numeric(coef(foo)["TSLS",-1])
  expect_equal(tsls_output[1],0.4665769)
  expect_equal(tsls_output[2],0.001940093)
  expect_equal(tsls_output[3],240.492081152)
  expect_equal(tsls_output[4],0)
})

test_that("TSLS estimate with intercept, but without exogeneous covariates", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]

  foo = ivmodel(Y=Y,D=D,Z=Z)
  tsls_output = as.numeric(coef(foo)["TSLS",-1])
  tsls_other = as.numeric(coefOther(foo)$TSLS)

  expect_equal(tsls_output[1],0.188062632758)
  expect_equal(tsls_output[2],0.026291343964)
  expect_equal(tsls_output[3],7.15302469953)
  expect_equal(tsls_output[4],1.061464*10^(-12))

  expect_equal(tsls_other[1],3.767471660374)
  expect_equal(tsls_other[2],0.348861744657)
  expect_equal(tsls_other[3],10.79932585924)
  expect_equal(tsls_other[4],1.063760*10^(-26))
})

test_that("TSLS estimate with exogeneous covariates, but no intercept", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X,intercept=FALSE)
  tsls_output = as.numeric(coef(foo)["TSLS",-1])
  tsls_other = coefOther(foo)$TSLS

  expect_equal(tsls_output[1],0.311872823011726)
  expect_equal(tsls_output[2],0.01637624982246)
  expect_equal(tsls_output[3],19.04421503047432)
  expect_equal(tsls_output[4],2.021866*10^(-76))

  other_est = c(0.264680781815391,-0.006066303123084,0.010770651971337,-0.111136194883946,0.101606674342650,
                0.158161632945826 , 0.273710902514624,0.323305448915530, 0.231086891116473,0.369085137097003,
                0.417753000654896 , 0.331919063677470, -0.000200505471685, 0.042212714810450)
  other_se = c(0.02648192,0.001447105,0.034450887,0.042937923,0.046465209,
               0.106121595,0.096012842,0.09695341,0.117274666,0.101179265,
               0.109812044,0.098736306,0.122609095,0.03775272)
  other_t = c(9.994773149,-4.192026522,0.312637873,-2.588299244,
              2.186725879,1.490381222,2.850773886,3.33464753,1.970475804,
              3.647833736,3.804254861,3.361671871,-0.001635323,1.118137034)
  other_pval = c(3.68888545695*10^(-23),2.84479425579*10^(-5),7.54577566779*10^(-1),
                 9.69174313767*10^(-3),2.88396560010*10^(-2),1.36229329392*10^(-1),
                 4.39113473619*10^(-3),8.64474417991*10^(-4),4.88758353229*10^(-2),
                 2.68968590078*10^(-4),1.45073675929*10^(-4),7.84441650405*10^(-4),
                 9.98695310526*10^(-1),2.63598148986*10^(-1))
  expect_equal(as.numeric(tsls_other[,1]),other_est)
  expect_equal(as.numeric(tsls_other[,2]),other_se)
  expect_equal(as.numeric(tsls_other[,3]),other_t)
  expect_equal(as.numeric(tsls_other[,4]),other_pval)
})

test_that("TSLS estimate with exogeneous covariates and intercept", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X)
  tsls_output = as.numeric(coef(foo)["TSLS",-1])
  tsls_other = coefOther(foo)$TSLS

  expect_equal(tsls_output[1],0.131503836)
  expect_equal(tsls_output[2],0.0549636726)
  expect_equal(tsls_output[3],2.3925591)
  expect_equal(tsls_output[4],1.679262*10^(-2))

  other_est = c(0.108271106,-0.002334938,-0.146775747,-0.144671501,
                0.111808309,-0.107814233,-0.007046452,0.040444546,
                -0.057917154,0.03845768,0.055088709,0.026757977,
                -0.190891226,0.018531104,3.773965141)
  other_se = c(0.023658571,0.000333497,0.053899859,0.027284623,
               0.031661988,0.041813679,0.03290727,0.031780563,
               0.037605896,0.046938701,0.052659734,0.048828702,
               0.050711333,0.021608589,0.934947017)
  other_t = c(4.5764009,-7.0013725,-2.7231193,-5.302309,
              3.5313104,-2.5784441,-0.2141305,1.2726189,
              -1.5401083,0.8193171,1.0461258,0.5479969,
              -3.7642715,0.8575805,4.0365551)
  other_pval = c(4.92290320848*10^(-6),3.11612469442*10^(-12),6.50437654555*10^(-3),
                 1.22662588576*10^(-7),4.19745945432*10^(-4),9.97198409145*10^(-3),
                 8.30459836493*10^(-1),2.03252114106*10^(-1),1.23639625283*10^(-1),
                 4.12670726440*10^(-1),2.95587380542*10^(-1),5.83734887817*10^(-1),
                 1.70242896565*10^(-4),3.91192788096*10^(-1),5.56008327986*10^(-5))
  expect_equal(as.numeric(tsls_other[,1]),other_est)
  expect_equal(as.numeric(tsls_other[,2]),other_se)
  expect_equal(as.numeric(tsls_other[,3]),other_t)
  expect_equal(as.numeric(tsls_other[,4]),other_pval)
})


phredToProb <- function(phred) {
	if (phred == "#") return(1)
	phredNum <- as.integer(charToRaw(phred))-33
	10^(-phredNum/10)
}

#calculster posteriors for variant calls, taking into account the size of the cluster
# in which the calls were found
bayesBase <- function(calls, quals, templ, mutRate=0.0025, clusterSize=1) {
	#convert phred quals to error probabilities
	probs <- sapply(quals, function(phred) {
		#multiple qualities for the same base can occur for inserations or deletions
		#they are treated as multiplicative (i.e. the probability of all being errors)
		prod(sapply(toChars(phred), phredToProb))
	})
	#all possible hypothetical bases (=q) to test
	qs <- unique(c(templ,calls))
	#calculate priors for each base given the template and mutation rate
	#note: this could be sped up by keeping a hash/lookup table of all possible values around
	r <- mutRate
	m <- clusterSize
	logPriorOdds <- sapply(qs,
		function(q) if (q==templ) {#WT case
			log((1-r)^m)-log(1-(1-r)^m)
		} else {#Mutant case
			log(1-(1-r)^m)-log(3)-log(1-(1-(1-r)^m)/3)
		}
	)
	#log posterior odds = sum of log likelihood ratios plus prior
	k <- colSums(do.call(rbind,lapply(1:length(calls), function(i) {
		#error probablity
		p <- probs[[i]]
		#for each possible base: calculate the log likelihood ratio (LLR).
		#Given that illumina discretizes the qualities, a lookup table could speed this up too
		setNames(sapply(qs, function(q) {
			#if the basecall supports the hypothetical base
			if (calls[[i]] == q) {
				log(1-p)-log(p)+log(3)
			#otherwise, if the basecall contradicts the hypothetical base
			} else {
				log(p) - log(3) - log(1/3-p/9)
			}
		}),qs)
	}))) + logPriorOdds
	#convert to posterior probabilities
	return(exp(k)/(1+exp(k)))
}

#input "callClusters" is list of lists of dataframes. Each top layer element correponds to a
# read pair, containing a list clusters. The clusters themselves are datafraames that list proximal
# proposed variant calls with columns refbase, refpos, readbase1, qual1, readbase2, qual2
# in case of insertions, refbase is "-" and readbase and qual can contain more than one value,
# in case of deletions, readbase1/readbase2 is "-" and qual1/qual2 would contain the qualities of the neighbouring two base calls.
processClusters <- function(callClusters, mutrate=0.0025) {
	#calculate posterior probabilites for each call in each cluster
	out <- lapply(callClusters, function(clusters) {
		#iterate over each cluster for the current read pair
		lapply(clusters, function(cluster) {
			if (!is.data.frame(cluster)){
				return(cluster)
			}
			#cluster size
			csize <- nrow(cluster)
			#iterate over the proposed nucleotide change in the current cluster
			#  and calculate posteriors
			posteriors <- lapply(1:csize,function(i) with(cluster[i,],{
				#check if any calls are missing or "N"
				na1 <- is.na(readbase1) || readbase1=="N"
				na2 <- is.na(readbase2) || readbase2=="N"
				if (na1 && na2) {
					#if there's no usable data, it's WT
					# return(cbind(cluster,varcall=refbase,post=1))
					setNames(1,refbase)
				} else if (na1) {
					bayesBase(readbase2,qual2,refbase,mutrate,csize)
				} else if (na2) {
					bayesBase(readbase1,qual1,refbase,mutrate,csize)
				} else {
					bayesBase(
						c(readbase1,readbase2),
						c(qual1,qual2),
						refbase,mutrate,csize
					)
				}
			}))
			varcall <- sapply(posteriors,function(x)names(which.max(x)))
			callPosteriors <- mapply(function(posteriors,varcall)posteriors[[varcall]],posteriors,varcall)
			return(cbind(cluster,varcall=varcall,post=callPosteriors))
		})
	})
	return(out)
}


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     16.10.2019
#modificado: 06.11.2019

setwd("2019/2019.08.13_formacao_RCD2019/bin/")
library("tidyverse")
library("nycflights13")

#3.1. Missing values

#3.1.1.
flights %>%
  summary()
#flights %>%
#  select_if(function(x){sum(is.na(x))>0}) %>%
#  summarise_all(function(x){sum(is.na(x))})

flights %>%
  summarise(n_NA=sum(is.na(dep_time) | is.na(dep_delay) |
                     is.na(arr_time) | is.na(arr_delay) |
					 is.na(air_time)))
flights %>%
  summarise(n_NA=sum(is.na(air_time)))
#flights %>%
#  transmute(anyNA = dep_time + dep_delay + arr_time + arr_delay + air_time) %>%
#  summarise(n_NA=sum(is.na(anyNA)))
#flights %>%
#  mutate_all(function(x){is.na(x)}) %>%
#  transmute(anyNA = rowSums(.) > 0) %>%
#  summarise(n_NA = sum(anyNA))
#anyNA <- apply(flights,1,function(x){any(is.na(x))})
#anyNA <- !complete.cases(flights)
#n_NA = sum(anyNA)

#flights %>%
#  drop_na()      #works for any subset of columns
#na.omit(flights) #only works for all columns

#3.1.2.
not_cancelled <- flights %>%
  filter(!is.na(air_time))

#3.1.3.
not_cancelled %>%
  group_by(year,month,day) %>%
  summarize(mean = mean(dep_delay))

#3.2. Outliers

#3.2.1.
not_cancelled %>%
  group_by(tailnum) %>%
  summarize(delay = mean(arr_delay))

#3.2.2.
not_cancelled %>%
  group_by(tailnum) %>%
  summarize(delay = mean(arr_delay)) %>%
  ggplot() +
   geom_freqpoly(mapping=aes(x=delay),binwidth=10)

#3.2.3.
delays <- not_cancelled %>%
  group_by(tailnum) %>%
  summarize(delay = mean(arr_delay),
            n_flights = n())

#3.2.4.
delays %>%
  ggplot() +
    geom_point(mapping=aes(x=n_flights,y=delay),alpha=1/10)

#3.2.5.
delays %>%
  filter(n_flights > 25) %>%
  ggplot() +
   geom_point(mapping=aes(x=n_flights,y=delay),alpha=1/10)

#3.3. Distribuição 1D

#3.3.1.
diamonds2 <- diamonds %>%
  filter((x > 0) & (y > 0 & y < 20) & (z > 0 & z < 10))

diamonds2_scale <- diamonds2 %>%
  mutate(price = (price - mean((price)))/sd(price))

diamonds2_scale %>%
  ggplot() +
    geom_histogram(mapping=aes(x=price,y=..density..),binwidth=0.2) +
    stat_function(fun=dnorm,color="red",args=list(mean=0,sd=1))

#3.3.2
param <- diamonds2_scale %>%
  summarize(n = n(),
            mean = mean(price),
			sd = sd(price),
            skewness = skewness(price),
			kurtosis = kurtosis(price))
print(round(cbind(t(param),c(1/0,0,1,0,3)),digits=3))

#3.3.3.
diamonds2_scale <- diamonds2 %>%
  mutate(carat = (carat - mean(carat))/sd(carat))

diamonds2_scale %>%
  ggplot() +
    geom_histogram(mapping=aes(x=carat,y=..density..),binwidth=0.2) +
    stat_function(fun=dnorm,color="red",args=list(mean=0,sd=1))

param <- diamonds2_scale %>%
  summarize(n = n(),
            mean = mean(carat),
			sd = sd(carat),
            skewness = skewness(carat),
			kurtosis = kurtosis(carat))
print(round(cbind(t(param),c(1/0,0,1,0,3)),digits=3))

#3.3.4.
ldiamonds2_scale <- diamonds2 %>%
  mutate(carat = (log(carat) - mean(log(carat)))/sd(log(carat)))

ldiamonds2_scale %>%
  ggplot() +
    geom_histogram(mapping=aes(x=carat,y=..density..),binwidth=0.2) +
    stat_function(fun=dnorm,color="red",args=list(mean=0,sd=1))

param <- ldiamonds2_scale %>%
  summarize(n = n(),
            mean = mean(carat),
			sd = sd(carat),
            skewness = skewness(carat),
			kurtosis = kurtosis(carat))
print(round(cbind(t(param),c(1/0,0,1,0,3)),digits=3))

#3.4. Distribuição 2D

#3.4.1.
diamonds2 <- diamonds %>%
  filter((x > 0) & (y > 0 & y < 20) & (z > 0 & z < 10))

diamonds2 %>%
  filter(cut=="Fair") %>%
  ggplot() +
    geom_boxplot(mapping=aes(x=clarity,y=price))

diamonds2 %>%
  filter(cut=="Fair") %>%
  group_by(clarity) %>%
  summarize(mean_price = mean(price))

diamonds2 %>%
  filter(cut=="Fair") %>%
  group_by(clarity) %>%
  mutate(mean_price = mean(price)) %>%
  ggplot() +
    geom_point(mapping=aes(x=mean_price,y=price),size=2,alpha=0.01) +
    geom_point(mapping=aes(x=mean_price,y=mean_price),size=2,color="red")

#3.4.2.
diamonds2 %>%
  filter(cut=="Fair") %>%
  group_by(clarity) %>%
  mutate(mean_price = mean(price)) %>%
  ungroup() %>%
  summarize(cor(mean_price,price))

#3.4.3.

#Calculate Cramer's V from contingency table
calc_Cramers_V <- function(x){
    chi_stat <- chisq.test(x)$statistic #chi-sqrt
    n <- sum(x)                         #sample size
    min_dim <- min(dim(x)) - 1          #minimum number of dimensions - 1
    res <- sqrt(chi_stat/n/min_dim)     #Cramer's V
    names(res) = "Cramers.V"
    return(res)
}

diamonds2 %>%
  group_by(clarity,color) %>%
  summarize(n = n()) %>%
  ggplot() +
    geom_tile(mapping=aes(x=clarity,y=color,fill=n))
cont_table <- table(diamonds2$clarity,diamonds2$color) #contingency table
print(cont_table)
round(calc_Cramers_V(cont_table),digits=3)

diamonds2 %>%
  group_by(cut,color) %>%
  summarize(n = n()) %>%
  ggplot() +
    geom_tile(mapping=aes(x=cut,y=color,fill=n))
cont_table <- table(diamonds2$cut,diamonds2$color) #contingency table
print(cont_table)
round(calc_Cramers_V(cont_table),digits=3)


# customized plot
panel.cor <- function(x, y, digits=2, cex.cor)
{
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(0, 1, 0, 1))
  r <- abs(cor(x, y))
  txt <- format(c(r, 0.123456789), digits=digits)[1]
  test <- cor.test(x,y)
  Signif <- ifelse(round(test$p.value,3)<0.001,"p<0.001",paste("p=",round(test$p.value,3)))
  text(0.5, 0.25, paste("r=",txt))
  text(.5, .75, Signif)
}
panel.smooth<-function (x, y, col = "blue", bg = NA, pch = 18,
                        cex = 0.8, col.smooth = "red", span = 2/3, iter = 3, ...)
{
  points(x, y, pch = pch, col = col, bg = bg, cex = cex)
  ok <- is.finite(x) & is.finite(y)
  if (any(ok))
    lines(stats::lowess(x[ok], y[ok], f = span, iter = iter),
          col = col.smooth, ...)
}
panel.hist <- function(x, ...)
{
  usr <- par("usr"); on.exit(par(usr))
  par(usr = c(usr[1:2], 0, 1.5) )
  h <- hist(x, plot = FALSE)
  breaks <- h$breaks; nB <- length(breaks)
  y <- h$counts; y <- y/max(y)
  rect(breaks[-nB], 0, breaks[-1], y, col="cyan", ...)
}
<<<<<<< HEAD

global_data <- all_global_data[, -9]

=======
>>>>>>> deb4eee798046ff3050e2fdc49aff179daa28237
pairs(global_data,
      lower.panel=panel.smooth, upper.panel=panel.cor,diag.panel=panel.hist)


#' Edge Distance
#'
#' Calculates the distance from each node in the network to each edge in the network.
#'
#' @param g An igraph graph
#' @param edge.network A pre-calculated edge network from ```get.edge.network```
#' @export
#' @examples
#' edge.distance(g)

edge.distance <- function(g, edge.network = NULL, lookup.mat = F, add.names=T) {
  if(is.null(edge.network)) {
    edge.network <- get.edge.network(g)
  }
  ns <- V(g)$name
  max.node.id <- vcount(g)
  enm <- (max.node.id + 1) : (max.node.id + ecount(g))
  g.dist <- shortest.paths(graph.edgelist(edge.network))
  g.dist <- (g.dist[enm, 1:max.node.id] - 1) / 2
  if(lookup.mat) {
    # 3d lookup matrix (edge node 1, edge node 2, focal node)
    m <- array(NA, rep(vcount(g), 3))
    g.el <- get.edgelist(g, names = F)
    # this creates an index for the 3d matrix and merges it with the melted
    b <- do.call(rbind, replicate(ncol(g.dist), g.el, simplify=F)) %>%
      cbind(melt(g.dist)) %>%
      select(-Var1)
    m[b %>% select(`1`, `2`, `Var2`) %>% as.matrix] <- b$value
    return(m)
  }
  if(add.names) {
    if("matrix" %in% class(g.dist)) {
      if(is.null(ns)) {
        ns <- 1:ncol(g.dist)
      }
      colnames(g.dist) <- ns
    } else {
      names(g.dist) <- ns
    }
    g.el <- get.edgelist(g)
    rownames(g.dist) <- paste(g.el[,1],g.el[,2],sep="-")
  }
  return(g.dist)
}


##########################################################
## SCRIPT FOR Analysing MidTerm Grades                  ##
## By Farhang.Fp                                        ##
## Oct 1st 2020                                         ##
## Computational Thinking                               ##
##########################################################

### Define the working directory
setwd('C:\\Users\\Farha\\Dropbox\\Farhang (1)\\Computational Thinking Material- ENGR1330\\5th Week')

### Read the full data
data <- read.csv('MidTermFull.csv')
data
IC <- data[,3]
TH <- data[,4]
T73 <- data[,5]
Tp <- data[,6]

#Summary
summary(IC)
summary(TH )
summary(T73 )

par(mfrow=c(2,2))
boxplot(IC,horizontal=TRUE,col="goldenrod1",main="In-Class Grades (out of 23)")
text(x=fivenum(IC), labels =fivenum(IC), y=1.25)

boxplot(TH,horizontal=TRUE,col="darkorange2",main="Take-home Grades (out of 50)")
text(x=fivenum(TH), labels =fivenum(TH), y=1.25)

boxplot(T73,horizontal=TRUE,col="darkred",main="Total Grades (out of 73)")
text(x=fivenum(T73), labels =fivenum(T73), y=1.25)

boxplot(Tp,horizontal=TRUE,col="deeppink3",main="Total Grades (percentage)")
text(x=fivenum(Tp), labels =fivenum(Tp), y=1.25)


subroutine stoke(x1,y1,x2,y2,rw,area,s1,eps,nerror)

# Apply Stokes' theorem to find the area of a polygon;
# we are looking at the boundary segment from (x1,y1)
# to (x2,y2), travelling anti-clockwise.  We find the
# area between this segment and the horizontal base-line
# y = ymin, and attach a sign s1.  (Positive if the
# segment is right-to-left, negative if left to right.)
# The area of the polygon is found by summing the result
# over all boundary segments.

# Just in case you thought this wasn't complicated enough,
# what we really want is the area of the intersection of
# the polygon with the rectangular window that we're using.

# Called by dirout.

implicit double precision(a-h,o-z)
dimension rw(4)
logical value

zero   = 0.d0
nerror = -1

# If the segment is vertical, the area is zero.
call testeq(x1,x2,eps,value)
if(value) {
        area = 0.
        s1   = 0.
        return
}

# Find which is the right-hand end, and which is the left.
if(x1<x2) {
        xl = x1
        yl = y1
        xr = x2
        yr = y2
        s1 = -1.
}
else {
        xl = x2
        yl = y2
        xr = x1
        yr = y1
        s1 = 1.
}

# Dig out the corners of the rectangular window.
xmin = rw(1)
xmax = rw(2)
ymin = rw(3)
ymax = rw(4)

# Now start intersecting with the rectangular window.
# Truncate the segment in the horizontal direction at
# the edges of the rectangle.
slope = (yl-yr)/(xl-xr)
x  = max(xl,xmin)
y  = yl+slope*(x-xl)
xl = x
yl = y

x  = min(xr,xmax)
y  = yr+slope*(x-xr)
xr = x
yr = y

if(xr<=xmin|xl>=xmax) {
        area = 0.
        return
}

# We're now looking at a trapezoidal region which may or may
# not protrude above or below the horizontal strip bounded by
# y = ymax and y = ymin.
ybot = min(yl,yr)
ytop = max(yl,yr)

# Case 1; ymax <= ybot:
# The `roof' of the trapezoid is entirely above the
# horizontal strip.
if(ymax<=ybot) {
        area = (xr-xl)*(ymax-ymin)
        return
}

# Case 2; ymin <= ybot <= ymax <= ytop:
# The `roof' of the trapezoid intersects the top of the
# horizontal strip (y = ymax) but not the bottom (y = ymin).
if(ymin<=ybot&ymax<=ytop) {
        call testeq(slope,zero,eps,value)
        if(value) {
                w1 = 0.
                w2 = xr-xl
        }
        else {
                xit = xl+(ymax-yl)/slope
                w1 = xit-xl
                w2 = xr-xit
                if(slope<0.) {
                        tmp = w1
                        w1  = w2
                        w2  = tmp
                }
        }
        area = 0.5*w1*((ybot-ymin)+(ymax-ymin))+w2*(ymax-ymin)
        return
}

# Case 3; ybot <= ymin <= ymax <= ytop:
# The `roof' intersects both the top (y = ymax) and
# the bottom (y = ymin) of the horizontal strip.
if(ybot<=ymin&ymax<=ytop) {
        xit = xl+(ymax-yl)/slope
        xib = xl+(ymin-yl)/slope
        if(slope>0.) {
                w1 = xit-xib
                w2 = xr-xit
        }
        else {
                w1 = xib-xit
                w2 = xit-xl
        }
        area = 0.5*w1*(ymax-ymin)+w2*(ymax-ymin)
        return
}

# Case 4; ymin <= ybot <= ytop <= ymax:
# The `roof' is ***between*** the bottom (y = ymin) and
# the top (y = ymax) of the horizontal strip.
if(ymin<=ybot&ytop<=ymax) {
        area = 0.5*(xr-xl)*((ytop-ymin)+(ybot-ymin))
        return
}

# Case 5; ybot <= ymin <= ytop <= ymax:
# The `roof' intersects the bottom (y = ymin) but not
# the top (y = ymax) of the horizontal strip.
if(ybot<=ymin&ymin<=ytop) {
        call testeq(slope,zero,eps,value)
        if(value) {
                area = 0.
                return
        }
        xib = xl+(ymin-yl)/slope
        if(slope>0.) w = xr-xib
        else w = xib-xl
        area = 0.5*w*(ytop-ymin)
        return
}

# Case 6; ytop <= ymin:
# The `roof' is entirely below the bottom (y = ymin), so
# there is no area contribution at all.
if(ytop<=ymin) {
        area = 0.
        return
}

# Default; all stuffed up:
nerror = 8
return

end


load("sampleData")
#My sample data is 1000 rows, with the first column a unique id, followed by 100 columns of data variables
groupVars <- c("path")
dataVars <-  colnames(dt)[!colnames(dt) %in% groupVars]
#outfile
frameToJSON <- function(dt,groupVars,dataVars,outfile){
  #packages we will need:
  require(data.table)
  require(RJSONIO)

  #Here you may want to sort by colSums() to keep only the most relevant variables.

  #calculate the correlation matrix
  t <- cor(dt[,c(!colnames(dt) %in% groupVars),with=F])

  #calculate the hierarchical cluster structure from the correlation scores
  hc <- hclust(dist(t), "ward")

  #take a look at what your strucutre:
  plot(hc)

  #now we split the data based on membership structure. We will take four levels:
  #(basically this means we will calculate which group each variable belongs in for different levels of the tree strucutre)
  memb2 <- as.character(cutree(hc, k = 2))
  memb6 <- as.character(cutree(hc, k = 6))
  memb15 <- as.character(cutree(hc, k = 15))
  memb40 <- as.character(cutree(hc, k = 40))

  #Now put this information into a table, together with the labels and the order in which they should appear:
  b=data.table(memb2,memb6,memb15,memb40,label=hc$labels,order=hc$order)

  #We might want to know the size of each node. Let's add that
  b$size <- colSums(dt[,c(dataVars),with=F])

  #sort the data so it alligns with the structure calculated using hclust()
  setkey(b,order)
  #drop the order variable:
  b[,order:=NULL]

  #we define a function which will create a nested list in JSON format:
  #From here: http://stackoverflow.com/questions/12818864/how-to-write-to-json-with-children-from-r
  makeList<-function(x){
    if(ncol(x)>2){
      listSplit<-split(x[-1],x[1],drop=T)
      lapply(names(listSplit),function(y){list(name=y,imports=makeList(listSplit[[y]]))})
    }else{
      lapply(seq(nrow(x[1])),function(y){list(name=x[,1][y],size=x[,2][y])})
    }
  }

  #This will not work on a data.table

  b <- data.frame(b)
  out <- makeList(b)
  #Have a look at the structure this creates:
  print (head(out))

  #Basically we have made a list of lists containing the information from the tree diagram.
  #Finally we put everythin into a list, convert this to json format and save it as data.json
  jsonOut<-toJSON(list(name="Centre",children=makeList(b)))

  #We use the cat function here, because in some cases you may want to add separators, or a prefix and suffix to make the formatting just right
  cat(jsonOut,file=outfile)
}

frameToJSON(dt,groupVars,dataVars,outfile="data.json")


# From Pedro Emmanuel Alvarenga Americano do Brasil emmanuel.brasil@gmail.com

require(rms)
set.seed(1)
n  <- 400
n1 <- 300; n2 <- 100
data <- data.frame(outcome=c(rnorm(n1, mean = .052, sd = .005),
                     rnorm(n2, mean = .06, sd = .01)),
                   v2=sample(seq(20,80,5),n,T),
                   v3=sample(seq(60,150,1),n,T),
                   v4=c(rnorm(n1, mean = 80, sd = 10),
                     rnorm(n2, mean = 60, sd = 15)),
                   v5=sample(c('M','M','F'),n,T),
                   v6=c(rnorm(n1, mean = 80, sd = 10),
                     rnorm(n2, mean = 120, sd = 30)))

# checking data
head(data)

# setting datadist
dd <- datadist(data);  options(datadist="dd")

# generating missings
m <- function() sample(1:n, 20, FALSE)

data$v2[m()] <- NA
data$v3[m()] <- NA
data$v4[m()] <- NA
data$v5[m()] <- NA
data$v6[m()] <- NA
plot(naclus(data))

# Imputing
imp <- aregImpute(~ outcome + v2 + v3 + v4 + v5 + v6, data, n.impute=10)

# fitting
f <- fit.mult.impute(outcome ~ v6 + v2 + rcs(v3) + v5 * rcs(v4),
                     ols, imp, data, fit.reps=TRUE)
coef(f)
w <- NULL
for(i in 1 : 10) w <- rbind(w, coef(f$fits[[i]]))
w

s <- summary(f)
s
unclass(s)   # Effects are non-zero but small
plot(s)


suppressMessages(library(float))
suppressMessages(library(dimrgame))

if (comm.size() > 1)
  comm.stop("run with 1 rank")

x = matrix(1:30, 10)
s = fl(x)

ds = shaq(s)

truth = crossprod(s)
test = crossprod_game(ds)
all.equal(test, truth, tolerance=1e-4)

finalize()


setwd("C:\\Users\\anush\\OneDrive\\Desktop\\final")
getwd()
library(factoextra)
library(ClusterR)
library(cluster)
library(fpc)
library(stats)
data <- read.csv("C:\\Users\\anush\\OneDrive\\Desktop\\final\\ORIGINAL.csv")
data <- as.data.frame(data)
data[is.na(data$L1.norm.)]
data[is.na(data$BTC.)]
rownames(data) <- data$Date
data.frame <- as.data.frame(data)
# plot(data.frame[,4:5])
# ------------------------------------------------------------------>
# L1normdata <- data[,3]
# maxL1 <- max(L1normdata)
# minL1 <- min(L1normdata)
# L1normdata<- (L1normdata - minL1)/(maxL1 - minL1)
# write.csv(L1normdata, 'L1norm_data.csv')
# ------------------------------------------------------------------->
# data.scaled <- scale(data.frame[,2:3])
# dist.eucl <- dist(data.scaled, method = "euclidean")
# print(dist.eucl)
# km.res <- eclust(na.omit(data.frame[,4:5]), "kmeans", k = 4,nstart = 25)
# set.seed(50)
# km.res <- kmeans(na.omit(data.frame[,4:5]), 4, nstart = 25, na.rm = TRUE)
# km_stats <- cluster.stats(dist(data.frame[,4:5]),  km.res$cluster)
# print(km_stats)
# res <- km.res$cluster
# res <- as.data.frame(res)
#--------------------------------------------------------------->
# kmeans.re <- kmeans(na.omit(data.frame[,4:5]), centers = 4, nstart = 25)
# km_stats <- cluster.stats(dist(data.frame[,4:5]),  kmeans.re$cluster)
# print(km_stats)

# kmeans.re
# y_kmeans <- kmeans.re$cluster
# clusplot(data.frame[,4:5],
#          y_kmeans,
#          lines = 0,
#          shade = TRUE,
#          color = TRUE,
#          labels = 2,
#          plotchar = FALSE,
#          span = TRUE,
#          main = paste("Clusters"),
#          xlab = 'log(BTC)',
#          ylab = 'L1 norm')
# print(res)
# # Visualize k-means clusters
# fviz_cluster(km.res, data = na.omit(data.frame[,4:5]))

data_final <- data_final <- data.frame[626:679,2:3]
km.res <- kmeans(na.omit(data_final), 4, iter.max = 10, nstart = 1,algorithm = "MacQueen", trace=FALSE)
km_stats <- cluster.stats(dist(data_final),  km.res$cluster)
print(km_stats)
fviz_cluster(km.res, data = na.omit(data_final))


######### Calibration Plot function

CalibrationPlot = function(prob, result,bins=100, detail = FALSE,range = c(0,1)) {

	# creates breaks and sets up the vectors
	breaks = quantile(prob,seq(0,1,1/bins),na.rm=T)#seq(0,1-1/bins,1/bins)
	prediction = rep(NA,length(breaks))
	observedprop = rep(NA,length(breaks))
	meanprob = rep(NA,length(breaks))

	prob = ifelse(prob == 1, 0.99999999999,prob)

	# fills in the vectors position by position
	for (i in seq_along(breaks)) {
		prediction[i] = length(which(prob >= breaks[i] & prob < breaks[i+1]))
		observedprop[i] = length(which(prob >= breaks[i] & prob < breaks[i+1] & result ==1))/prediction[i]
		meanprob[i] = mean(prob[which(prob >= breaks[i] & prob < breaks[i+1])])
	}

	# plot observed against predicted probabilities
	plot(meanprob, observedprop, xlim = range,ylim = range,pch="")
	text(meanprob, observedprop,labels = prediction,cex=0.5)
	abline(0,1)
	print(summary(lm(observedprop ~ meanprob - 1)))

	# detailed information: plot.lm and anova table
	if (detail)  {
		plot.lm(lm(observedprop ~ meanprob - 1))
		cat("-------------------------------------------------------------\n")
		print(anova(lm(observedprop ~ meanprob - 1)))
	}
}


# Data Visualization with ggplot
# Scatterplots
# Video 2.1

# Load the dataset as described in Video 1.3

library(tidyverse)
college <- read_csv('http://672258.youcanlearnit.net/college.csv')
college <- college %>%
  mutate(state=as.factor(state), region=as.factor(region),
         highest_degree=as.factor(highest_degree),
         control=as.factor(control), gender=as.factor(gender),
         loan_default_rate=as.numeric(loan_default_rate))

#
ggplot(data=college) +
  geom_point(mapping=aes(x=tuition, y=sat_avg))


library("MASS")
library("lattice")
load("./simul-2017.Rdata")

#Valeur pour mettre plus en valeur les screens pour le rapport
lwd_default <- 1

##########################################
# Q1.1
##########################################
#Affichage de l'ensemble d'apprentissage
couleur_app<-rep('red',n_app)
couleur_app[classe_app==1]='red'
couleur_app[classe_app==2]='blue'
couleur_app[classe_app==3]='green'

plot(x_app, col = couleur_app, lwd = lwd_default)

#Affichage de l'ensemble de test
couleur_test<-rep('red',n_test)
couleur_test[classe_test==1]='red'
couleur_test[classe_test==2]='blue'
couleur_test[classe_test==3]='green'
plot(x_test, col = couleur_test, lwd = lwd_default)

##########################################
# Q1.2
##########################################
#Affichage de l'ensemble d'apprentissage
plot(x_app, col = couleur_app, lwd = lwd_default)

# Déclaration des vecteurs moyennes
M1 = seq(1,2)
M2 = seq(1,2)
M3 = seq(1,2)

# Vecteur moyenne de la classe 1
M1[1] = mean(x_app[classe_app==1,1])
M1[2] = mean(x_app[classe_app==1,2])

# Vecteur moyenne de la classe 2
M2[1] = mean(x_app[classe_app==2,1])
M2[2] = mean(x_app[classe_app==2,2])

# Vecteur moyenne de la classe 3
M3[1] = mean(x_app[classe_app==3,1])
M3[2] = mean(x_app[classe_app==3,2])

points(M1[1], y = M1[2], pch = 20, col = "red", lwd=15)
points(M2[1], y = M2[2], pch = 20, col = "blue", lwd=15)
points(M3[1], y = M3[2], pch = 20, col = "green", lwd=15)

#Affichage de l'ensemble d'apprentissage
plot(x_app, col = couleur_app, lwd = lwd_default)

# Matrices de co variance
Sigma1 <- matrix(1,2,2)
Sigma2 <- matrix(1,2,2)
Sigma3 <- matrix(1,2,2)

for (i in 1:2) {
  for (j in 1:2) {
    Sigma1[i,j]=cov(as.vector(x_app[classe_app==1,i]), as.vector(x_app[classe_app==1,j]))
    Sigma2[i,j]=cov(as.vector(x_app[classe_app==2,i]), as.vector(x_app[classe_app==2,j]))
    Sigma3[i,j]=cov(as.vector(x_app[classe_app==3,i]), as.vector(x_app[classe_app==3,j]))
  }
}

s1 = s1^2
s2 = s2^2
s3 = s3^2

##########################################
# Q1.3
##########################################

# Grille d'estimation de la densit´e de probabilit´e en 50 intervalles selon 1er attribut
xp1 <- seq(min(x_app[,1]),max(x_app[,1]),length=50)
# Grille d'estimation de la densit´e de probabilit´e en 50 intervalles selon 2eme attribut
xp2 <- seq(min(x_app[,2]),max(x_app[,2]),length=50)

grille <- expand.grid(x1=xp1,x2=xp2)
x_app_lda<-lda(x_app,classe_app)

# Estimation des densit´es de probabilit´es a posteriori dans Zp
grille = cbind(grille[,1],grille[,2])
Zp <- predict(x_app_lda,grille)

#Affichage des lignes de décision
zp_3<-Zp[["posterior"]][,3]-pmax(Zp[["posterior"]][,1],Zp[["posterior"]][,2])
zp_2<-Zp[["posterior"]][,2]-pmax(Zp[["posterior"]][,1],Zp[["posterior"]][,3])

contour(xp1,xp2,matrix(zp_3,50),add=TRUE,levels=0,drawlabels=FALSE, col="green", lwd = lwd_default)
contour(xp1,xp2,matrix(zp_2,50),add=TRUE,levels=0,drawlabels=FALSE, col="blue", lwd = lwd_default)

##########################################
# Q1.4
##########################################

assigne_test <- predict(x_app_lda, newdata=x_test)
# Estimation des taux de bonnes classifications
table_classification_test_lda <-table(classe_test, assigne_test[["class"]])
# table of correct class vs. classification
diag(prop.table(table_classification_test_lda, 1))
# total percent correct
taux_bonne_classif_test_lda <-sum(diag(prop.table(table_classification_test_lda)))

# Création du vecteur contenant le code de la forme des données test assignées aux
shape<-rep(1,n_test) ;
# Forme des données assignées
shape[assigne_test[["class"]]==1]=1 ;
shape[assigne_test[["class"]]==2]=2 ;
shape[assigne_test[["class"]]==3]=3 ;
plot(x_test,col=couleur_test,pch=shape,xlab = "X1", ylab = "X2", lwd = lwd_default)

#Affichage des lignes de décision
contour(xp1,xp2,matrix(zp_3,50),add=TRUE,levels=0,drawlabels=FALSE, col="green", lwd = lwd_default)
contour(xp1,xp2,matrix(zp_2,50),add=TRUE,levels=0,drawlabels=FALSE, col="blue", lwd = lwd_default)

##########################################
# Q1.5
##########################################
#Affichage de l'ensemble d'apprentissage
plot(x_app, col = couleur_app, lwd = lwd_default)

x_app_qda<-qda(x_app,classe_app)

# Estimation des densit´es de probabilit´es a posteriori dans Zp
Zp <- predict(x_app_qda,grille)

#Affichage des lignes de décision
zp_3<-Zp[["posterior"]][,3]-pmax(Zp[["posterior"]][,1],Zp[["posterior"]][,2])
zp_2<-Zp[["posterior"]][,2]-pmax(Zp[["posterior"]][,1],Zp[["posterior"]][,3])
contour(xp1,xp2,matrix(zp_3,50),add=TRUE,levels=0,drawlabels=FALSE, col="green", lwd = lwd_default)
contour(xp1,xp2,matrix(zp_2,50),add=TRUE,levels=0,drawlabels=FALSE, col="blue", lwd = lwd_default)

assigne_test <- predict(x_app_qda, newdata=x_test)
# Estimation des taux de bonnes classifications
table_classification_test_qda <-table(classe_test, assigne_test[["class"]])
# table of correct class vs. classification
diag(prop.table(table_classification_test_qda, 1))
# total percent correct
taux_bonne_classif_test_qda <-sum(diag(prop.table(table_classification_test_qda)))

# Création du vecteur contenant le code de la forme des données test assignées aux
shape<-rep(1,n_test) ;
# Forme des données assignées
shape[assigne_test[["class"]]==1]=1 ;
shape[assigne_test[["class"]]==2]=2 ;
shape[assigne_test[["class"]]==3]=3 ;
# Affichage avec code couleur et forme adapt´ees
plot(x_test,col=couleur_test,pch=shape,xlab = "X1", ylab = "X2", lwd = lwd_default)

#Affichage des lignes de décision
contour(xp1,xp2,matrix(zp_3,50),add=TRUE,levels=0,drawlabels=FALSE, col="green", lwd = lwd_default)
contour(xp1,xp2,matrix(zp_2,50),add=TRUE,levels=0,drawlabels=FALSE, col="blue", lwd = lwd_default)


# Loading the libraries
library(dplyr)
data(murders)

# Create new data frame called my_states (with specifications in the instructions)
my_states <- murders %>%
mutate(rate = total / population * 100000, rank = rank(-rate)) %>%
filter(region %in% c("Northeast", "West") & rate <1) %>%
select(state, rate, rank)

Data Wrangling/Filter Mutate and Select.r