square<-function(x){
    x=x^2
    return(x)
}


  predict.maturity.males = function(cw.mm, chela.mm) {

    # maturity codes
    immature = 0
    mature = 1
    mat.unknown = 2

    # to ID maturity of males using mm
    # usage: predict.maturiyt.males(cw.mm=.., chela.mm=..)
    test.male = -25.32404 * log(cw.mm) + 19.775707 * log(chela.mm) + 56.649941
    mat = test.male * NA # initialise a vector with NA's of the right length
    mat[ which( test.male <= 0 ) ] = immature
    mat[ which( test.male > 0 )  ] = mature

    ii =which(cw.mm<60)
    mat[ii] = immature
    return(mat)
  }


    n <- 80 # number of signal series
    m <- 100 # bandwith resolution
    x <- seq(-15,15, len=m) # sequential

    y <- matrix(NA, n, m) # creation of matrix filled with NA's
    for (i in 1:n) # loop for generation of randomly & logistically distributed data

    #You can whether use normal or logistic distribution or even couple them together for customization

    y[i,] <- (dnorm(x+runif(1,-1,1),mean = runif(1, -5,5), log = F)*runif(m, 1.8,2)/ runif(1, 0.9,3) + dlogis(x+runif(1,-1,1),location = runif(1,-5,5), scale = runif(1,1,1.5), log = FALSE)*runif(m, 1.9,2) / runif(1, 0.9,7) + dlogis(x+runif(1,-1,1),location = runif(1,-5,5), scale = runif(1,1,1.5), log = FALSE)*runif(m, 1.9,2) / runif(1, 0.9,7)) *runif(x, 0.85,1)/runif(1, 1,4)

    #y[i,] <- dlogis(x,location = runif(1,-5,5), scale = runif(1,1,7), log = FALSE)*runif(m, 1.9,2.5) / runif(1, 0.9,3)

    par(bg="black") # black color for background
    yrange <- range(c(y, y+n/20)) # range between signals in y direction

    plot(x, x, type="n", axes=F, bg="black", ylim=yrange)

    for (i in n:1) {
       y1 <- c(y[i,] + i/20, 0, 0)
       x1 <- c(x, x[m], x[1])
       polygon(x1,y1,col="black")
       #density(x1,y1,col="black")
       lines(x, y[i,] + i/20, col="white")

    }


#' Function for posterior sampling of DP mixture of logistic regressions for binary data.
#'
#' This function takes in a training data.frame and optional testing data.frame and performs posterior sampling. It returns posterior predictions and posterior clustering for training and test sets.
#' The function is built for binary outcomes.
#'
#' Please see \url{https://stablemarkets.github.io/ChiRPsite/index.html} for examples and detailed model and parameter descriptions.
#'
#' @import stats
#'
#' @param d_train A \code{data.frame} object with outcomes and model covariates/features. The outcome must be \code{numeric} coded with \code{1}s and \code{0}s. All features must be \code{as.numeric} - either continuous or binary with binary variables coded using \code{1} and \code{0}. Categorical features are not supported. We recommend standardizing all continuous features. NA values are not allowed and each row should represent a single subject, longitudinal data is not supported.
#' @param d_test Optional \code{data.frame} object containing a test set of subjects containing all variables specifed in \code{formula}. The same rules that apply to \code{d_train} apply to \code{d_test}.
#' @param formula Specified in the usual way, e.g. for \code{p=2} covariates, \code{y ~ x1 + x1}. All covariates - continuous and binary - must be \code{as.numeric} , with binary variables coded as \code{1} or \code{0}. We recommend standardizing all continuous features. NA values are not allowed and each row should represent a single subject, longitudinal data is not supported.
#' @param burnin integer specifying number of burn-in MCMC draws.
#' @param iter integer greater than \code{burnin} specifying how many total MCMC draws to take.
#' @param init_k Optional. integer specifying the initial number of clusters to kick off the MCMC sampler.
#' @param prop_sigma_b Optional. If you specified \code{p} covariates in \code{formula}, \code{p+1} regression parameters are sampled for the probability of the outcome being one using a Metropolis step.  \code{prop_sigma_b} is a \code{p+1} by \code{p+1} covariance matrix for the Metropolis proposal distribution.
#' @param beta_prior_mean Optional. If there are \code{p} covariates as length \code{p+1} \code{as.numeric} vector specifying mean of the Gaussian prior on the outcome model's conditional mean parameter vector. Default is regression coefficients from running logistic regression on the outcome.
#' @param beta_prior_var Optional. If there are \code{p} covariates as length \code{p+1} \code{as.numeric} vector specifying variance of the Gaussian prior on the outcome model's conditional mean parameter vector. The full covarince of the prior is set to be diagonal. This vector specifies the diagonal enteries of this prior covariance. Default is estimated variances from running logistic regression on the outcomes..
#' @param beta_var_scale Optional. A multiplicative constant that scales \code{beta_prior_var}. If you leave \code{beta_prior_mean} and \code{beta_prior_var} at their defaults, This constant toggles how wide new cluster parameters are dispersed around the observed data parameters.
#' @param mu_scale Optional. An numeric, scalar constant that controls how widely distributed new cluster continuous covariate means are distributed around the empirical covariate mean. Specifically, all continuous covariates are assumed to have Gaussian likelihood with Gaussian prior on their means. \code{mu_scale=2} specifies that the variance of the Gaussian prior is twice as large as the empirical variance.
#' @param tau_scale Optional. An numeric, scalar constant that controls how widely distributed new cluster continuous covariate variances are distributed around the empirical variance. Specifically, all continuous covariates are assumed to have Gaussian likelihood with Inverse Gamma prior on their variance. \code{tau_scale=2} specifies that the rate of the InvGamma prior is twice as large as the empirical variance.
#' @return Returns \code{predictions$train} and \code{cluster_inds$train}. \code{predictions$train} returns an \code{nrow(d_train)} by \code{iter - burnin} matrix of posterior predictions. \code{cluster_inds$train} returns an \code{nrow(d_train)} by \code{iter - burnin} matrix of cluster assignment indicators, which can be input into the function \code{cluster_assign_mode()} to compute posterior mode assignment. \code{predictions$test} and \code{cluster_inds$test} are returned if \code{d_test} is specified.
#' @keywords Dirichlet Process binary outcomes logistic
#' @examples
#' set.seed(1)
#' n<-1000 # simulate 1000 subjects
#'
#' # Cluster 1: 5 continuous covariates with mean 5, variance 5
#' x1 <- replicate(2,  rnorm(n/2, 10, 5) )
#'
#' # Cluster 2: 5 continuous covariates with mean 5, variance 5
#' x2 <- replicate(2,  rnorm(n/2, -10, 5))
#'
#' # outcome for both clusters
#' y <- numeric(length = n)
#' y[1:500] <- rbinom(500, 1, pnorm(-5 + x1 %*% matrix(c(-2,2), ncol=1) )  )
#' y[501:1000] <- rbinom(500, 1, pnorm(5 + x2 %*% matrix(c(2,-2), ncol=1)  ) )
#'
#' # combine into data.frame
#' d <- data.frame(rbind(x1,x2), y)
#'
#' # normalize covariates...helps for numerical stability.
#' d$X1 <- scale(d$X1)
#' d$X2 <- scale(d$X2)
#'
#' set.seed(100)
#'
#' # split data into training (800 obs) and testing (200 obs)
#' test_ids <- sample(1:1000, 200, replace = FALSE )
#' d_test <- d[test_ids, ]
#' d_train <- d[-test_ids, ]
#'
#' logit_res <- PDPMix(d_train = d_train, d_test = d_test,
#'                     formula = y ~ X1 + X2,
#'                     burnin = 100, iter = 200,
#'                     beta_prior_var = rep(3, 3), # fairly flat priors
#'                     beta_prior_mean = rep(0,3), # null centered priors
#'                     prop_sigma_b = diag(rep(.001, 3)) , # proposal covariance
#'                     init_k = 5, tau_scale = 3, mu_scale = 3)
#' @export
PDPMix<-function(d_train, formula, d_test=NULL, burnin=100, iter=1000,
                 beta_prior_mean=NULL, beta_prior_var=NULL,
                 init_k=10, beta_var_scale=1000, mu_scale=1, tau_scale=1,
                 prop_sigma_b = diag(rep(.025, nparams))){

  ###------------------------------------------------------------------------###
  #### 0 - Parse User Inputs                                                ####
  ###------------------------------------------------------------------------###
  # error checking user inputs
  if( missing(d_train) ){ stop("ERROR: must specify a training data.frame.") }

  x <- all.vars(formula[[3]]) # covariate names
  y <- all.vars(formula[[2]]) # outcome name

  nparams <- length(x) + 1

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

  if(!is.null(d_test)){
    xt <- model.matrix(data=d_test,
                       object= as.formula(paste0('~ ',paste0(x, collapse = '+'))))
    nt <- nrow(xt)
  }

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

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

  n<-nrow(x)

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

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

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

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

  ## calibrate priors
  if(is.null(beta_prior_mean)){
    reg <- glm(data=d_train, formula = formula, family = binomial('probit'))
    beta_prior_mean <- reg$coefficients
  }

  if(is.null(beta_prior_var)){
    reg <- glm(data=d_train, formula = formula, family = binomial('probit'))
    beta_prior_var <- beta_var_scale*diag(vcov(reg))
  }

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

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

  g2 <- rep(2, n_num_p)
  names(g2) <- xall_names_num

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

  K <- init_k
  a <- 1

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

  alpha <- numeric(length = store_l)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  if(!is.null(d_test)){
    c_b_new_test <- numeric(length = n_bin_p)
    names(c_b_new_test) <- xall_names_bin

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

    predictions <- vector(mode = 'list', length = 2)
    predictions[[1]] <- matrix(nrow = n, ncol = store_l)
    predictions[[2]] <- matrix(nrow = nt, ncol = store_l)
    names(predictions) <- c('train','test')

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

    cluster_inds <- vector(mode = 'list', length = 1)
    cluster_inds[[1]] <- matrix(nrow = n, ncol = store_l)
    names(cluster_inds) <- c('train')
  }

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

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

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

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

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

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

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

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

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

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

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

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

      ck_ind <- class_ind == k

      y_ck <- y[ck_ind]

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

      beta_shell[ ,k] <- metrop_hastings(x_0 = beta_shell[ ,k], iter = 1,
                                         log_post_density = cond_post_beta_pdp,
                                         y= y, xm = x_ck,
                                         prop_sigma = prop_sigma_b,
                                         beta_prior_mean = beta_prior_mean,
                                         beta_prior_var = beta_prior_var)[[1]]

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

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

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

    }

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

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

    beta_new <- mvtnorm::rmvnorm(n = 1, mean = beta_prior_mean,
                                 sigma = diag(beta_prior_var) )

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

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

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

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

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

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

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

                                      beta_shell = beta_shell,

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

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

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

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

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

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

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

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

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

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

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

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

    K <- K_new
    class_names <- new_class_names

    if( i > burnin ){

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

      if(!is.null(d_test)){
        name_new_test<-paste0('c', max(as.numeric(substr(class_names,2,10)))+1)

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

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

        beta_new <- mvtnorm::rmvnorm(n = 1, mean = beta_prior_mean,
                                     sigma = diag(beta_prior_var) )

        weights_test <- class_update_test_pdp(n = nt, K = length(class_names) ,
                                              alpha =a,
                                              name_new = name_new_test,
                                              uniq_clabs = colnames(beta_shell),
                                              clabs = c_shell[,1],
                                              x = xt,
                                              x_cat_shell = c_b_shell,
                                              x_num_shell = c_n_shell,
                                              cat_idx = xall_names_bin,
                                              num_idx = xall_names_num,
                                              cat_new = c_b_new_test,
                                              num_new = c_n_new_test)

        c_shell_test <- apply(weights_test, 1, FUN = sample,
                              x=c(colnames(beta_shell), name_new_test),
                              size=1, replace=T)

        test_pred <- post_pred_draw_test_pdp(n=nt, x=xt, pc=c_shell_test,
                                             beta_shell = beta_shell,
                                             name_new = name_new_test,
                                             beta_new = beta_new)

        train_pred<-post_pred_draw_train_pdp(n=n, x=x, pc=c_shell[,1],
                                             beta_shell = beta_shell)

        # cluster indicators
        cluster_inds[['train']][, i-burnin] <- c_shell[,1]
        cluster_inds[['test']][, i-burnin] <- c_shell_test

        # predictions
        predictions[['train']][, i-burnin ] <- train_pred
        predictions[['test']][, i-burnin  ] <- test_pred
      }else{
        train_pred<-post_pred_draw_train_pdp(n=n, x=x, pc=c_shell[,1],
                                             beta_shell = beta_shell)

        # cluster indicators
        cluster_inds[['train']][, i-burnin] <- c_shell[,1]

        # predictions
        predictions[['train']][, i-burnin ] <- train_pred

      }
    }

  }

  results <- list(cluster_inds=cluster_inds,
                  predictions = predictions)
  cat('Sampling Complete.')
  return(results)
}


`%myop%` <- function(a, b) {2*a + 2*b}

# use own operator
1 %myop% 1
#[1] 4
1 %myop% 2
#[1] 6


############################################################
# For owl monkey project, last revised 04.18
# Plots and statistical tests for Figure 3, Figure S3, and
# Figure S4 in owl monkey paper.
#
# Gregg Thomas
############################################################

library(ggplot2)
library(akima)
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)
cat("----------\n")

figs2_opt = F
# CHANGE TO TRUE TO GENERATE FIG. S2

figs3_opt = T
# CHANGE TO TRUE TO GENERATE FIG. S3

####################
## Estimating model parameters using Kong (2012) data
human_dm0 = 34; human_df = 31; human_num_f = 14.2; human_haploid = 2630000000; human_diploid = human_haploid * 2;
# Parameters observed from Drost & Lee (1995) and Kong (2012)

human_mu_c = (human_num_f / human_df)
cat("mu_c estimated from Kong params: ", human_mu_c, "\n")
human_mu_c = human_mu_c / human_haploid
cat("mu_c per site estimated from Kong params: ", human_mu_c, "\n")
# Estimating mu_c

# Calculate spermatogenic proportion and expected number of spermatogenic divisions
# per year using human (Kong) observations.
human_sc = 16
human_dy1 = ((2.01 / human_haploid) / human_mu_c)
human_sp = human_dy1 / (365/16)
cat("Human expected # of spermatogenic cycles/year: ", human_dy1, "\n")
cat("Human spermatogenic cell proportion given a cycle length of 16 days: ", human_sp, "\n")
cat("----------\n")
# Estimating the expected number of spermatogenic cycles per year

# 2.01 is the slope of the Kong line -- mutations per year in males after puberty.
# We can calculate the expected number of spermatogenic cycles per year (human_dy1) based on mu_c.
# Then, we can estimate the proportion of cells undergoing spermatogenesis at any given time (human_sp)
####################

####################
## Human prediction (orange)
human_puberty = 13.4
age_range = seq(human_puberty, 50.4, by=0.1)
rep_long = age_range - human_puberty
# The human age of puberty set at 13.4 years and a range of paternal ages

human_mu_g = ((human_df * human_mu_c) + ((human_dm0 * human_mu_c) + (human_dy1 * rep_long * human_mu_c))) / 2
# Calculating the mutation rate (Equation 9 in paper)

human_pred = data.frame(human_mu_g, age_range)
names(human_pred) = c("Mutation.rate", "Parental.age")
human_pred_reg = lm(human_mu_g ~ age_range)
cat("Human slope (d_ym1): ", coef(human_pred_reg)[2], " -> ", coef(human_pred_reg)[2]*human_diploid, "\n")
cat("----------\n")
####################

####################
## Owl monkey prediction (purple)
if(figs2_opt){
  om_sc = 10.2
}else{
  om_sc = 16
}
om_dy1 = (365/om_sc) * human_sp
cat("Owl monkey expected # of spermatogenic cycles/year: ", om_dy1, "\n")
# Estimate the expected number of spermatogenic cycles per year in owl monkeys using the human proportion
# of cells actively dividing (human_sp).

om_puberty = 1
age_range = seq(om_puberty, 16, by=0.1)
rep_long = age_range - om_puberty
# The owl monkey age of puberty set at 1 year and a range of paternal ages

om_mu_g = ((human_df * human_mu_c) + ((human_dm0 * human_mu_c) + (om_dy1 * rep_long * human_mu_c))) / 2
# Calculating the mutation rate (Equation 9 in paper)

om_pred = data.frame(om_mu_g, age_range)
names(om_pred) = c("Mutation.rate", "Parental.age")
om_pred_reg = lm(om_mu_g ~ age_range)
cat("Owl monkey slope (d_ym1): ", coef(om_pred_reg)[2], " -> ", coef(om_pred_reg)[2]*human_diploid, "\n")
cat("----------\n")
####################

####################
## Chimp prediction (red)
if(figs2_opt){
  chimp_sc = 14
}else{
  chimp_sc = 16
}
chimp_dy1 = (365/chimp_sc) * human_sp
cat("Chimpanzee expected # of spermatogenic cycles/year: ", chimp_dy1, "\n")
# Estimate the expected number of spermatogenic cycles per year in chimpss using the human proportion
# of cells actively dividing (human_sp).

chimp_puberty = 7.5
age_range = seq(chimp_puberty, 35.5, by=0.1)
rep_long = age_range - chimp_puberty
# The owl monkey age of puberty set at 1 year and a range of paternal ages

chimp_mu_g = ((human_df * human_mu_c) + ((human_dm0 * human_mu_c) + (chimp_dy1 * rep_long * human_mu_c))) / 2
# Calculating the mutation rate (Equation 9 in paper)

chimp_pred = data.frame(chimp_mu_g, age_range)
names(chimp_pred) = c("Mutation.rate", "Parental.age")
chimp_pred_reg = lm(chimp_mu_g ~ age_range)
cat("Chimp slope (d_ym1): ", coef(chimp_pred_reg)[2], " -> ", coef(chimp_pred_reg)[2]*human_diploid, "\n")
cat("----------\n")
####################

####################
# Read the study data
study_data = read.csv("data/mutation-studies.csv", header=TRUE)
####################

####################
## The plot for Fig. 3
  if(!figs3_opt){
  fig3 = ggplot(study_data, aes(x=Paternal.age, y=Mutation.rate, color=Species)) +
    geom_line(data=human_pred, aes(x=Parental.age, y=Mutation.rate), color='#db6d00', size=1) +
    geom_segment(aes(x=human_puberty,y=human_mu_g[1]-human_mu_g[1]/10,xend=human_puberty,yend=human_mu_g[1]+human_mu_g[1]/10), linetype=1, color="#db6d00", size=0.5) +
    geom_line(data=om_pred, aes(x=Parental.age, y=Mutation.rate), color='#b66dff', size=1) +
    geom_segment(aes(x=om_puberty,y=om_mu_g[1]-om_mu_g[1]/10,xend=om_puberty,yend=om_mu_g[1]+om_mu_g[1]/10), linetype=1, color="#b66dff", size=0.5) +
    geom_line(data=chimp_pred, aes(x=Parental.age, y=Mutation.rate), color='#920000', size=1) +
    geom_segment(aes(x=chimp_puberty,y=chimp_mu_g[1]-chimp_mu_g[1]/10,xend=chimp_puberty,yend=chimp_mu_g[1]+chimp_mu_g[1]/10), linetype=1, color="#920000", size=0.5) +
    geom_point(size=3) +
    scale_x_continuous(limits=c(0,50), breaks = seq(1, 50, by=5)) +
    labs(x="Paternal age (y)",y="Mutation rate per site\nper generation") +
    theme_classic() +
    guides(colour = guide_legend(override.aes = list(size=3))) +
    theme(axis.text=element_text(size=14),
          axis.title=element_text(size=20),
          axis.title.y=element_text(margin=margin(t=0,r=20,b=0,l=0),color="black"),
          axis.title.x=element_text(margin=margin(t=20,r=0,b=0,l=0),color="black"),
          axis.line=element_line(colour='#595959',size=0.75),
          axis.ticks=element_line(colour="#595959",size = 1),
          axis.ticks.length=unit(0.2,"cm"),
          legend.title=element_blank(),
          legend.position=c(0.13,0.87),
          legend.text=element_text(size=18)
    ) +
    scale_color_manual(breaks=c("Owl monkey", "Chimpanzee", "Human"), values=c("Human"='#db6d00',"Owl monkey"='#b66dff',"Chimpanzee"='#920000'))
  print(fig3)
  if(figs2_opt) {
    ggsave(filename="figS2.pdf", fig3, width=10, height=6, units="in")
  }else{
    ggsave(filename="fig3.pdf", fig3, width=10, height=6, units="in")
  }
  ####################

  ####################
  ## The F test for Fig. 3
  human_data = data.frame(study_data$Paternal.age[study_data$Species=="Human"], study_data$Mutation.rate[study_data$Species=="Human"])
  names(human_data) = c("Age","Mu")
  human_data = na.omit(human_data)

  human_study_reg = lm(human_data$Mu ~ human_data$Age)
  cat("--Regression summary for human study data--\n")
  print(summary(human_study_reg))

  human_pred_reg = lm(human_pred$Mutation.rate ~ human_pred$Parental.age)

  pred_actual = coef(human_pred_reg)[1] + human_data$Age * coef(human_pred_reg)[2]
  pred_resids = human_data$Mu - pred_actual
  #plot(human_pred$Parental.age,human_pred$Mutation.rate, type='l',ylim=c(0.8e-8,1.8e-8), xlim=c(13.4,50))
  #points(human_data$Age, human_data$Mu)
  #segments(x0=human_data$Age,y0=human_data$Mu,x1=human_data$Age,y1=human_data$Mu-pred_resids)
  #abline(human_study_reg, lty=2)
  #segments(x0=human_data$Age,y0=human_data$Mu,x1=human_data$Age,y1=human_data$Mu-resid(human_study_reg),lty=2)
  cat("--F test for differences between residuals of the predicted and best fit lines for the human studies--")
  print(var.test(resid(human_study_reg), pred_resids, alternative="two.sided"))
}
####################

####################
## Fig. S3
if(figs3_opt){
  colfunc <- colorRampPalette(c("#009292", "#920000"))
  #colfunc <- colorRampPalette(c("#009292", "#db6d00", "#920000"))
  #colfunc <- colorRampPalette(c("#009292", "#006ddb", "#920000"))
  #colfunc <- colorRampPalette(c("#018571", "#80cdc1", "#a6611a"))
  #colfunc <- colorRampPalette(c("#eecc82", "#926544", "#000000"))
  # A nice(?) color palette

  rt = c();nrt = c();
  for(i in seq(5, 51, 1))
  {
    for(j in seq(5, 51, 1))
    {
      rt = c(rt, i)
      nrt = c(nrt, j)
    }
  }
  mu_y = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * rt * human_mu_c)) / (rt + nrt));
  # Calculate mu_y for a range of life history values

  am = 20; af = 6; p = 3; rt1 = am-p; nrt1 = af+p
  mu_y_m1 = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * (am-p) * human_mu_c)) / (am + af));
  am = 35; af = 6; p = 3; rt2 = am-p; nrt2 = af+p
  mu_y_m2 = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * (am-p) * human_mu_c)) / (am + af));

  am = 20; af = 27; p = 3; rt3 = am-p; nrt3 = af+p
  mu_y_m3 = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * (am-p) * human_mu_c)) / (am + af));
  am = 35; af = 27; p = 3; rt4 = am-p; nrt4 = af+p
  mu_y_m4 = (((human_df * human_mu_c) + (human_dm0 * human_mu_c) + (human_dy1 * (am-p) * human_mu_c)) / (am + af));

  rts = c(rt1, rt2, rt3, rt4)
  nrts = c(nrt1, nrt2, nrt3, nrt4)
  muys = c(signif(mu_y_m1, 3), signif(mu_y_m2,3), signif(mu_y_m3,3), signif(mu_y_m4,3))
  # Generate a couple points with varying male age at conception

  pdf(NULL)
  dev.control(displaylist="enable")
  # pdf seems to save with some weird grid marks.
  par(mar=c(5,5,4,2))
  pred_data = interp(rt,nrt,mu_y)
  filled.contour(pred_data, xlab='RL (years)', ylab=expression('F + M'[0]*' (years)'), cex.lab=2, col=colfunc(26),
                 key.title = {par(cex.main=2);title(main=expression(mu[y]))},
                 #key.axes = axis(4, seq(2.5e-10, 1.415e-9, by = 0.5e-10)),
                 plot.axes = { contour(pred_data, drawlabels=T, axes=F, frame.plot=F, add=T, col="#999999", lwd=1.5, lty=3, labcex=1);
                   axis(1);
                   axis(2);
                   #segments(rt1, nrt1, rt2, nrt2)
                   #segments(rt3, nrt3, rt4, nrt4)
                   #points(rts, nrts)
                   #points(rts, nrts)
                   #text(rts, nrts, labels=muys, pos=1)

                   points(16.3,43.1,pch=21,bg='#db6d00',col="white",cex=2)
                   # Kong human point
                   points(5.64,7.53,pch=21,bg='#b66dff',col="white",cex=2)
                   # Our owl monkey point
                   points(16.8,33.8,pch=21,bg='#920000',col="white",cex=2)
                   # Venn chimp point
                   #points(5.15,4.19,pch=3,col='#009292',cex=1)
                   # Pfeiffer vervet point

                   #rect(xleft=min(rt_h), ybottom=min(nrt_h), xright=max(rt_h), ytop=max(nrt_h), border="orange")
                   # Human range
                   #rect(xleft=min(rt_ch), ybottom=min(nrt_ch), xright=max(rt_ch), ytop=max(nrt_ch), border="red")
                   # Chimp range
                   #rect(xleft=min(rt_om), ybottom=min(nrt_om), xright=max(rt_om), ytop=max(nrt_om), border="purple")
                   # Owl monkey range
                   #rect(xleft=min(rt_vv), ybottom=min(nrt_vv), xright=max(rt_vv), ytop=max(nrt_vv), border="#009292")
                   # Vervet range

                   #points(rt_p,nrt_p,type='l',col="red")
                   # Varying P line
                   #points(rt_gm,nrt_gm,type='l',col="green")
                   # Varying Gm line
                   #points(rt_gf,nrt_gf,type='l',col="blue")
                   # Varying Gf line
                 })
  plot_obj = recordPlot()
  dev.off()
  # Generate the plot and save it as an object. This allows simultaneous saving and displaying.

  png(file="figS3.png", width=8, height=7, units="in", res=400)
  print(plot_obj)
  dev.off()
  # Save plot to png file. pdf saves with weird grid lines.

  print(plot_obj)
  # Display plot
}


library(quantmod)

par(mfrow=c(3, 2))

stock <- na.omit( get( getSymbols('2330.TW') ) )
stock <- to.weekly(stock)

# ======1======
# Open buy close sell.
PL <- Cl(stock) - Op(stock)
plot( cumsum(PL) )

# ======2======
# Open buy close sell.
PLts <- xts( numeric( length( time(stock) ) ), time(stock) ) # [P]rofit and [L]ose [t]ime-[s]eries
#head(PLts)

time <- proc.time()
for ( m in as.character( time(stock) ) ) {
    PLts[m] <- stock[m, 4] - stock[m, 1]
}
proc.time() - time

plot( cumsum(PLts) )

# ======3======
# Open buy close sell.
# 'PLts' seems to be a dictionary whose values are strings.
# Super slow. Here is how to speed it up: MATRIX!
# Why is matrix faster? What are the rows and columns of this matrix? What are the dimensions of this matrix?
#class(stock)
stock <- as.matrix(stock)
#head(stock)
PL <- setNames( numeric( nrow(stock) ), rownames(stock) )

time <- proc.time()
for ( m in 2:nrow(stock) ) {
    cur_open <- stock[m, 1]
    cur_close <- stock[m, 4]
    PL[m] <- cur_close - cur_open
}
proc.time() - time

plot( cumsum(PL), type='l', col='blue', lwd=2 )
abline( h=0, col='green' )

# ======4======
# Open buy close sell only when kai1_gao1.
PL <- setNames( numeric( nrow(stock) ), rownames(stock) )
for ( m in 2:nrow(stock) ) {
    cur_open <- stock[m, 1]
    cur_close <- stock[m, 4]
    prev_close <- stock[m - 1, 4]
    if (cur_open > prev_close) {
        PL[m] <- cur_close - cur_open
    }
}
plot( cumsum(PL), type='l', col='red', lwd=2 )
abline( h=0, col='green' )

# ======5======
# Open buy close sell only when kai1_di1.
PL <- setNames( numeric( nrow(stock) ), rownames(stock) )
for ( m in 2:nrow(stock) ) {
    cur_open <- stock[m, 1]
    cur_close <- stock[m, 4]
    prev_close <- stock[m - 1, 4]
    if (cur_open <= prev_close) {
        PL[m] <- cur_close - cur_open
    }
}
plot( cumsum(PL), type='l', col='green', lwd=2 )
abline( h=0, col='green' )


print("---All files in directory---")
print(list.files())

print("---Refugee data---")
refugees <- read.csv('../data/popstats_clean.csv')
print(str(refugees))

print("---Population data---")
population <- read.table('../data/sp_pop.tsv', sep='\t', header=TRUE)
print(str(population))

print("---Merged data---")
popdata <- merge(x = refugees, y = population, by.x='Country.of.origin', by.y='Country.Name')
print(str(popdata))
print(cor.test(popdata$Asylum.seekers, popdata$X2013.Population))

plot(popdata$Asylum.seekers, popdata$X2013.Population)
line <- lm(popdata$X2013.Population ~ popdata$Asylum.seekers)
abline(line)


library(quantmod)

rm(list=ls())
setwd(Sys.getenv('RWorkingDirectory'))
source('ifm_sa.r')
par(mfrow=c(3, 4))

stock_ids <- scan('stock_ids', character(), quote = '')
win_rates <- vector()
gain_rates <- vector()
profit_factors <- vector()
mdds <- vector()
max_ddds <- vector()
for (stock_id in stock_ids) {
    stock <- readRDS(paste(stock_id, '.stk', sep=''))
    pl <- strategy(stock)

    # Assess the strategy.
    win_rate <- length( pl[pl > 0] ) / length( pl[pl != 0] )
    gain_rate <- mean( pl[pl > 0] ) / abs( mean( pl[pl < 0] ) )
    profit_factor <- sum( pl[pl > 0] ) / abs( sum( pl[pl < 0] ) )
    cum_pl <- cumsum(pl)
    dd <- cum_pl - cummax(cum_pl) # [d]raw[d]own
    mdd <- mean(dd)
    max_ddd <- max( diff( which(dd == 0) ) ) # [max]imum [d]raw[d]own [d]uration

    # Update assessments.
    win_rates <- c(win_rates, win_rate)
    gain_rates <- c(gain_rates, gain_rate)
    profit_factors <- c(profit_factors, profit_factor)
    mdds <- c(mdds, mdd)
    max_ddds <- c(max_ddds, max_ddd)

    # Plot the strategy.
    y_range <- range(dd, cum_pl)
    plot(dd, type='h', col='#91d18b', ylim=y_range)
    par(new=T)
    plot(cum_pl, type='h', col='#e11d74', lwd=2, ylim=y_range)
    points( which(dd == 0), cummax(cum_pl)[ which(dd == 0) ], pch=4, col='#440047' )
}

View( cbind(stock_ids, win_rates, gain_rates, profit_factors, mdds, max_ddds) )


# REML estimation of variance components
#  nested effects (farm, bales in farm)
#  using lmer

wool <- read.table('wool.txt',header=T)
#  after reshaping wool.txt into row column format

library(lme4)

# there is an outlier, remove that before continuing
#  (could also use subset=() in the lmer call

wool2 <- wool[wool$clean < 62,]

# create farm, could also use match()
# bales 1 and 2 are from farm SE, 3-5 from SW, and 6 and 7 from C

wool2$farm <- rep(c('SE','SW','C'),c(2,3,2))[wool2$bale]

# convert both bale and farm to factors so can nest

wool2$farm.f <- as.factor(wool2$farm)
wool2$bale.f <- as.factor(wool2$bale)

wool.vc <- lmer(clean~(1|farm/bale),data=wool2)
# farm/bale indicates farm , then bale nested in farm (bale:farm)

# can also specify both explicitly
wool.vcb <- lmer(clean~(1|bale) + (1|farm:bale),data=wool2)

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/wool2.r


# 4. faza: Analiza podatkov

data <- bdp %>% filter(Drzave=="European Union")
data <- data[,c(1,4)]
data <- aggregate(x = data$Vrednost,
                  by = list(data$Vrednost),
                  FUN = function(a){y <- a; return(y)})
colnames(data) <-c("EU","x")
data$EU <- c(1,2,3,4,5,6,7,8,9)

glm <- glm(data = data, x ~ I(EU))
cas <- data.frame(EU = c(10,11,12))
napoved <- cas %>% mutate(x=predict(glm,.))
imena <-c("2018/Q1","2018/Q2","2018/Q3","2019/Q1","2019/Q2","2019/Q3","2020/Q1",
          "2020/Q2","2020/Q3","2021/Q1","2021/Q2","2021/Q3")

graf_napoved <- data %>% ggplot(aes(x=EU, y=x)) +
  scale_x_continuous('Leto/Kvartal', breaks = seq(1,12, 1), limits = c(1,12),labels= imena) +
  geom_smooth(method='glm', formula=y ~ poly(x,1), color='blue',fullrange=TRUE) +
  geom_point(size=2) +
  geom_point(data = napoved, aes(x = EU, y = x), color = "red", size = 3,shape=17)+
  labs(title = "Napoved BDP za Evropsko Unijo v letu 2021") +
  ylab("Vrednost BDP v mio €") +
  guides(color=FALSE)


#=========================================================================================================================================================================================
#1. POVPREcNO sTEVILO DOSEzENIH ZADETKOV DOMAcINOV IN GOSTOV

#1. graf

preimenovanje <- c("Zadetki_domaca_ekipa"="Domači", "Zadetki_gostujoca_ekipa"="Gosti")
povprecje_golov <- Sezone %>% select(Sezona, Zadetki_domaca_ekipa, Zadetki_gostujoca_ekipa) %>%
  gather(key=Gostovanje, value="Zadetki", -Sezona) %>%
  mutate(Gostovanje=preimenovanje[Gostovanje]) %>%
  group_by(Sezona, Gostovanje) %>%
  summarise(Povprecje = mean(Zadetki, na.rm = TRUE))

Primerjava_zadetkov_domace_gostujoce_ekipe_graf <- ggplot(povprecje_golov, aes(x=Sezona, y=Povprecje, color=Gostovanje)) +
  geom_line() +
  xlab("Sezona") + ylab("Povprečje zadetkov") + ggtitle("Primerjava zadetkov domače in gostujoče ekipe") +
  theme(panel.background=element_rect(fill="white"), plot.title=element_text(hjust=0.5))

#=========================================================================================================================================================================================
# Drugi graf (Osvojene tocke v zadnjih 10 sezonah)
zmage <- Sezone %>%
  transmute(Domaca_ekipa, Gostujoca_ekipa,
            Zmaga_domaci = Zadetki_domaca_ekipa > Zadetki_gostujoca_ekipa,
            Remi=Zadetki_domaca_ekipa == Zadetki_gostujoca_ekipa,
            Zmaga_gosti= Zadetki_domaca_ekipa < Zadetki_gostujoca_ekipa)
zmage.skupaj <- rbind(select(zmage, Ekipa=Domaca_ekipa, Zmaga=Zmaga_domaci, Remi, Poraz=Zmaga_gosti),
                      select(zmage, Ekipa=Gostujoca_ekipa, Zmaga=Zmaga_gosti, Remi, Poraz=Zmaga_domaci)) %>%
                      group_by(Ekipa) %>% summarise(Zmage=sum(Zmaga), Remiji=sum(Remi), Porazi=sum(Poraz)) %>%
                      mutate(Tocke = 3*Zmage + Remiji)

Najuspesnejse_ekipe <- (ggplot(zmage.skupaj, aes(x=reorder(Ekipa, Tocke), y=Tocke)) + geom_col() + coord_flip() + xlab("Ekipa") + ylab("Tocke"))

#=========================================================================================================================================================================================
# 3. graf
# diagram, ki kaze da dobijo gostje veliko vec rumenih kartonov kot domaci // to bi se lahk naredu po sezonah in eno skupno bi blo bolj zanimivo
kartoni <- Sezone %>% summarise("Domaci" = sum(Rumeni_karton_domaci, na.rm = TRUE), "Gostje" = sum(Rumeni_karton_gostje, na.rm = TRUE))
#pripravljeni podatki
stevilo_vseh_rumenih_kartonov_domaci <- sum(Sezone$Rumeni_karton_domaci, na.rm = TRUE)
stevilo_vseh_rumenih_kartonov_gostje <- sum(Sezone$Rumeni_karton_gostje, na.rm = TRUE)
vsi_kartoni <- sum(kartoni$Domaci + kartoni$Gostje)
procent <- c(stevilo_vseh_rumenih_kartonov_domaci/vsi_kartoni, stevilo_vseh_rumenih_kartonov_gostje/ vsi_kartoni)
kartoni2 <- kartoni %>% gather(key= "Ekipa", value = "stevilo_kartonov")
##### 3 graf #####
stolpicni_graf_prejetih_rumenih_kartonov <- ggplot(kartoni2,  aes(x= Ekipa, y = stevilo_kartonov, fill=Ekipa )) +
                              geom_col() + geom_text(aes(label = scales::percent(procent), y = procent, group = stevilo_kartonov),
                              position = position_dodge(width = 1.5), vjust = -0.5) +
                              ylab("število kartonov") + ggtitle("Primerjava prejetih rumenih kartonov domače in gostujoče ekipe") +
                              theme(panel.background=element_rect(fill="white"), plot.title=element_text(hjust=0.5))

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

# kolk kartonov dajo vsi sodniki povprecno skup
stevilo_tekem <- nrow(Sezone)
stevilo_vseh_rumenih_kartonov <- stevilo_vseh_rumenih_kartonov_domaci + stevilo_vseh_rumenih_kartonov_gostje
povprecno_rumenih_kartonov_domaci <- round(stevilo_vseh_rumenih_kartonov_domaci/stevilo_tekem,2)
povprecno_rumenih_kartonov_gostje <- round(stevilo_vseh_rumenih_kartonov_gostje/stevilo_tekem,2)
povprecno_rumenih_kartonov <- round(stevilo_vseh_rumenih_kartonov/stevilo_tekem,2)

povprecno_vsi_Sodniki <- tibble(povprecno_rumenih_kartonov,povprecno_rumenih_kartonov_domaci,povprecno_rumenih_kartonov_gostje)

# kolk kartonov da ker sodnik
Sodniki_rumeni_kartoni <- Sezone %>%
  group_by(Sodnik) %>%
  summarise(povprecno_domacim_rumen_karton= round(mean_(Rumeni_karton_domaci, na.rm=TRUE),2), povprecno_gostom_rumeni_karton = round(mean_(Rumeni_karton_gostje, na.rm= TRUE),2), povprecno_rumeni_karton = round(mean_((Rumeni_karton_gostje+Rumeni_karton_domaci), na.rm= TRUE),2)) %>%
  arrange(povprecno_rumeni_karton)

#### 4. graf, koliko rumenih kartonov dodeli sodnik na posamezni tekmi ####
Sodniki_rumen_karton <- ggplot(Sodniki_rumeni_kartoni,aes(x= Sodniki_rumeni_kartoni$Sodnik,y= Sodniki_rumeni_kartoni$povprecno_rumeni_karton))+ geom_col() + coord_flip()+
  geom_hline(aes(yintercept = povprecno_rumenih_kartonov), color = "red")+ xlab("Sodnik") +
  ylab("stevilo rumenih kartonov") + ggtitle("Število dodeljenih rumenih kartonov v povprečju")

#=========================================================================================================================================================================================
####5 . graf (Povprecno rdeci kartoni) ####

stevilo_vseh_rdecih_kartonov_domaci <- sum(Sezone$Rdec_karton_domaci, na.rm = TRUE)
stevilo_vseh_rdecih_kartonov_gostje <- sum(Sezone$Rdec_karton_gostje, na.rm = TRUE)
rdeci_kartoni <- Sezone %>% summarise("Domaci" = sum(Rdec_karton_domaci, na.rm = TRUE), "Gostje" = sum(Rdec_karton_gostje, na.rm = TRUE))
vsi_kartoni2 <- sum(rdeci_kartoni$Domaci + rdeci_kartoni$Gostje)
rdec_procent <- c(stevilo_vseh_rdecih_kartonov_domaci/vsi_kartoni2, stevilo_vseh_rdecih_kartonov_gostje/ vsi_kartoni2)
rdec_kartoni2 <- rdeci_kartoni %>% gather(key= "Ekipa", value = "stevilo_kartonov")

##### 5 graf ##### RDECI KARTONI
stolpicni_graf_prejetih_rdecih_kartonov <- ggplot(rdec_kartoni2,  aes(x= Ekipa, y = stevilo_kartonov, fill=Ekipa )) +
  geom_col() + geom_text(aes(label = scales::percent(rdec_procent), group = stevilo_kartonov),
                         position = position_dodge(width = 1), vjust = -1) +
  ylab("Število kartonov") + ggtitle("Primerjava prejetih rdečih kartonov domače in gostujoče ekipe") +
  theme(panel.background=element_rect(fill="white"), plot.title=element_text(hjust=0.5))

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

#prekrški
Prekrski_domacini <- Sezone %>% select(Domaca_ekipa, PrekrSki_domaci) %>%
  gather(-Domaca_ekipa, key = ekipa, value = stevilo_prekrskov) %>% group_by(Domaca_ekipa) %>%
  summarise(skupek = sum(stevilo_prekrskov))# %>% rename("Ekipa"= Domaca_ekipa)
Prekrski_gostjee <- Sezone %>% select(Gostujoca_ekipa, PrekrSki_gostje) %>%
  gather(-Gostujoca_ekipa, key = ekipa, value = stevilo_prekrskov) %>% group_by(Gostujoca_ekipa) %>%
  summarise(skupek = sum(stevilo_prekrskov))# %>% rename("Ekipa"= Gostujoca_ekipa)

Prekrski_skupaj <- rbind(select(Prekrski_domacini, Ekipa=Domaca_ekipa, prek= skupek),
                        select(Prekrski_gostjee, Ekipa=Gostujoca_ekipa, prek= skupek)) %>%
                        group_by(Ekipa) %>% summarise("Prekrški"=sum(prek))
graf_prekrskov <- ggplot(Prekrski_skupaj, aes(x=reorder(Ekipa, Prekrški), y=Prekrški)) + geom_point() + xlab("Ekipa")+ coord_flip() + ylab("Število prekrškov")

#=========================================================================================================================================================================================
# Graf kolk dni je kdo trener

Trenutni_trenerji$razlika_v_dnevih <-  as.Date(as.character(Sys.Date()), format="%Y-%m-%d")-
  as.Date(as.character((Trenutni_trenerji$Appointed)), format="%Y-%m-%d")

Trenutna_trenerska_doba <- (ggplot(Trenutni_trenerji, aes(x=as.numeric(razlika_v_dnevih), y= Name)) + geom_point())+  ylab("Trener")+ xlab("Število dni")

#=========================================================================================================================================================================================
# Graf od ustanovitve premier lige, najuspešnejši trenerji

stevilo_naslovov <- NajbolSi_trenerji %>% group_by(Trener) %>% tally()
Najuspesnejsi_trenerji <- (ggplot(stevilo_naslovov, aes(x=Trener, y=n)) + geom_point())+ coord_flip() + ylab("Število naslovov")

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

#Zemljevidi

tocke <- Sezone %>%
  transmute(Domaca_ekipa, Gostujoca_ekipa,
            Tocke_domaci=ifelse(Zadetki_domaca_ekipa > Zadetki_gostujoca_ekipa, 3,
                                ifelse(Zadetki_domaca_ekipa == Zadetki_gostujoca_ekipa, 1, 0)),
            Tocke_gostujoci=ifelse(Zadetki_domaca_ekipa < Zadetki_gostujoca_ekipa, 3,
                                   ifelse(Zadetki_domaca_ekipa == Zadetki_gostujoca_ekipa, 1, 0)))
tocke.skupaj <- rbind(select(tocke, Ekipa=Domaca_ekipa, Tocke=Tocke_domaci),
                      select(tocke, Ekipa=Gostujoca_ekipa, Tocke=Tocke_gostujoci)) %>%
  group_by(Ekipa) %>% summarise(Tocke=sum(Tocke))

tocke_domacii <- tocke %>% group_by(Domaca_ekipa) %>%
  summarise(Domace_tocke=sum(Tocke_domaci)) %>% rename(Ekipa=Domaca_ekipa)
gostujoce_tocke <- tocke %>% group_by(Gostujoca_ekipa) %>%
  summarise(Gostujoce_tocke=sum(Tocke_gostujoci)) %>% rename(Ekipa=Gostujoca_ekipa)

UK <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_GBR_shp.zip", "gadm36_GBR_2",
                      encoding="UTF-8")
klubi <- c("Man United"="Manchester",
           "Man City" = "Salford",
           "Stoke City" = "Stoke-on-Trent",
           "Bournemouth" = "Bournemouth",
           "Leicester" = "Leicester",
           "Middlesbrough" = "Middlesbrough",
           "Southampton" = "Southampton",
           "Cardiff" = "Cardiff",
           "Swansea" = "Swansea",
           "Bolton" = "Bolton",
           "Brighton" = "Brighton and Hove",
           "Birmingham" = "Birmingham",
           "Blackpool" = "Blackpool",
           "Blackburn" ="Blackburn with Darwen",
           "Reading" = "Reading",
           "Bristol" = "Bristol",
           "Huddersfield" = "Calderdale",
           "Everton" = "Sefton",
           "Aston Villa" = "Coventry",
           "Newcastle" = "Newcastle upon Tyne",
           "Wigan" = "Wigan",
           "Wolverhampton" = "Wolverhampton",
           "Sunderland" = "Sunderland",
           "West Brom" = "Dudley",
           "Liverpool" = "Saint Helens",
           "Hull" = "Kingston upon Hull",
           "Watford" = "Luton",
           "Burnley" = "Bury",
           "Norwich" = "Peterborough",
           "Arsenal" = "Greater London",
           "West Ham" = "Greater London",
           "Fulham" = "Greater London",
           "Chelsea"= "Greater London",
           "Crystal Palace" = "Greater London",
           "QPR" = "Greater London",
           "Tottenham" = "Greater London",
           "Watford" = "Greater London",
           "Wolves" = "Wolverhampton"

           )
klubi.regija <- data.frame(Ekipa=names(klubi),
                           Regija=parse_factor(klubi, levels(UK$NAME_2)),
                           stringsAsFactors=FALSE)
EngWal <- UK[UK$NAME_1 %in% c("England", "Wales"),]

tocke.regije <- tocke.skupaj %>% inner_join(klubi.regija) %>%
  group_by(Regija) %>% summarise(Tocke=mean(Tocke))

zem.tocke <- merge(EngWal, tocke.regije, by.x="NAME_2", by.y="Regija")

zemljevid_EngWal <- tm_shape(zem.tocke) + tm_polygons("Tocke") + tm_legend(show=TRUE)

# LONDON

UK2 <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_GBR_shp.zip", "gadm36_GBR_3",
                      encoding="UTF-8")

klubi2 <- c(  "Arsenal" = "Hackney",
              "West Ham" = "Barking and Dagenham",
              "Fulham" = "Hammersmith and Fulham",
              "Chelsea"= "Kensington and Chelsea",
              "Crystal Palace" = "Croydon",
              "QPR" = "Ealing",
              "Tottenham" = "Enfield",
              "Watford" = "Harrow")

Lond <- UK2[UK2$NAME_2 %in% c("Greater London"),]

klubi.regija2 <- data.frame(Ekipa=names(klubi2),
                           Regija=parse_factor(klubi2, levels(UK2$NAME_3)),
                           stringsAsFactors=FALSE)
tocke.regije2 <- tocke.skupaj %>% inner_join(klubi.regija2)

zem.tocke2 <- merge(Lond, tocke.regije2, by.x="NAME_3", by.y="Regija")

zemljevid_london <- tm_shape(zem.tocke2) + tm_polygons("Tocke") + tm_legend(show=TRUE)

#### Moja ideja
# install.packages("rworldxtra")
# newmap <- getMap(resolution = "high")
# plot(newmap, xlim = c(-5, 0), ylim = c(50, 58), asp = 1)
#
# stadioni
# iz_sezone_2018 <- Sezone %>%  filter(Sezona == 2018)
# Seznam_ekip <- iz_sezone_2018 %>% select(Domaca_ekipa) %>% group_by(Domaca_ekipa) %>% count() %>% select(Domaca_ekipa)
# mesta <- c("Liverpool", "Manchester United", "Newcastle")
#
# tocke <- Sezone %>%
#   transmute(Domaca_ekipa, Gostujoca_ekipa,
#             Tocke_domaci=ifelse(Zadetki_domaca_ekipa > Zadetki_gostujoca_ekipa, 3,
#                                 ifelse(Zadetki_domaca_ekipa == Zadetki_gostujoca_ekipa, 1, 0)),
#             Tocke_gostujoci=ifelse(Zadetki_domaca_ekipa < Zadetki_gostujoca_ekipa, 3,
#                                    ifelse(Zadetki_domaca_ekipa == Zadetki_gostujoca_ekipa, 1, 0)))
# tocke.skupaj <- rbind(select(tocke, Ekipa=Domaca_ekipa, Tocke=Tocke_domaci),
#                       select(tocke, Ekipa=Gostujoca_ekipa, Tocke=Tocke_gostujoci)) %>%
#   group_by(Ekipa) %>% summarise(Tocke=sum(Tocke))
#
# lon <- c( 53.400002, 52, 51 )
# lat <- c(-2.983333,-1, -2)
# Koordinate <- data.frame(mesta,lon, lat)
#
# points(Koordinate$lat, Koordinate$lon, col = "red")


gridSets <- function(dat,grid.size=50) {

  print('grid size is set for km only')

  dat <- dat[complete.cases(dat[,c('lon','lat')]),]

  xwin <- data.frame(lat=c(min(dat$lat),min(dat$lat),max(dat$lat),max(dat$lat)),lon=c(min(dat$lon),max(dat$lon),min(dat$lon),max(dat$lon)))

  lon.d <- vincenty(loc1=xwin[1,],loc2=xwin[2,],a=6378.13700,f=1/298.257223563)
  lat.d <- vincenty(loc1=xwin[1,],loc2=xwin[3,],a=6378.13700,f=1/298.257223563)

  dplo <- (xwin[2,2]-xwin[1,2])/lon.d # deg NS per km
  dpla <- (xwin[3,1]-xwin[2,1])/lat.d # deg EW per km

  seqlo <- dplo*grid.size
  seqla <- dpla*grid.size

 ys <- seq(xwin[1,1],xwin[3,1],by=seqla)
 xs <- seq(xwin[1,2],xwin[2,2],by=seqlo)
 require(PBSmapping)
 gr <- makeGrid(x=xs,y=ys,projection="LL",zone=20,addSID=F)

 #make pbsmap friendly
	dat$X 	<- dat$lon
	dat$Y 	<- dat$lat
	dat$EID <- 1:nrow(dat)
	attr(dat,'projection') <- "LL"
	fp 		<- findPolys(dat,gr,maxRows=1e6)
 	dat <- merge(dat,fp,by='EID')
  return(list(dat,gr))
}


"plot.fitted.vs.observed.colored" <- function(x,y,yhat,color.by='year.built'){
  col.ix <- cut(x[,color.by],br=11)
  library('RColorBrewer')
  cols <- brewer.pal(11,'RdBu')
  cols <- sprintf('%s77',cols)
  print(cols)
  plot(y,yhat,
         pch=21,col=NA,
         bg=cols[col.ix],
         xlab='Observed',
         ylab='Predicted',
         cex.main=1.1)
}

"plot.co2.vs.size.by.ship.type" <- function(color.by='year.built'){
	col.ix <- cut(x[,color.by],br=11)
	library('RColorBrewer')
	cols <- brewer.pal(11,'RdBu')

	par(mfrow=c(4,4),mar=c(4,4,1.2,.4))
	for(shiptype in levels(x$Ship.type)){
		ix <- x$Ship.type == shiptype
		plot(x[ix,'deadweight.tons'],
			log10(x[ix,'kg.CO2.nm.2020']),
			pch=21,col=NA,
			#bg='#00000022',
			bg=cols[col.ix[ix]],
			xlab='Deadweight Tons',
			ylab='log10(KG CO2/NM)',
			main=shiptype,
			cex.main=1.1)
	}
}

"is.outlier" <- function(x,iqr.width=1.5){
	stats <- summary(x)
	q1 <- stats[2]
	q3 <- stats[5]
	iqr <- q3 - q1
	return((x < q1 - iqr.width*iqr) | (x > q3 + iqr.width*iqr))
}


# Compare Dq without repetition the most interesting are
# compareTwoCurvesT and KS.test

# Modified functions from package statmod to compare curves
#

# y1 is a matrix with columns mean,sd,n
#
meanAbsT <-function (y1, y2)
{
  if (is.null(dim(y1)) || is.null(dim(y2)))
    return(NA)
  y1 <- as.matrix(y1)
  y2 <- as.matrix(y2)
  if (ncol(y1) != ncol(y2))
    stop("Number of time points must match")
  m1 <- y1[,1]
  m2 <- y2[,1]
  v1 <- y1[,2]*y1[,2]
  v2 <- y2[,2]*y2[,2]
  n1 <- y1[,3]
  n2 <- y2[,3]
  s <- ((n1 - 1) * v1 + (n2 - 1) * v2)/(n1 + n2 - 2)
  t.stat <- abs(m1 - m2)/sqrt(s * (1/n1 + 1/n2))
  weighted.mean(t.stat, w = (n1 + n2 - 2)/(n1 + n2), na.rm = TRUE)
}

# Comparing two curves with SD for each point
# using group permutations and an average T statistics
#
# NOT working the curves are always equal!!!
#
compareTwoGCurves <- function (group, y, q, nsim = 100, fun = meanAbsT)
{
    group <- as.vector(group)
    g <- unique(group)
    if (length(g) != 2)
        stop("Must be exactly 2 groups")
    stat.obs <- fun(y[group == g[1], , drop = FALSE], y[group ==
        g[2], , drop = FALSE])
    asbig <- 0
    for (i in 1:nsim) {
        pgroup <- ave(group, q, FUN = sample)
        stat <- fun(y[pgroup == g[1], , drop = FALSE], y[pgroup ==
            g[2], , drop = FALSE])
        if (abs(stat) >= abs(stat.obs))
            asbig <- asbig + 1
    }
    list(stat = stat.obs, p.value = asbig/nsim)
}

# Comparing two curves with SD for each point
# testing for (y1-y1)/(y1+y2)/2 have a normal distribution
# or that it is equal to 0 so they come from the same population
#
# NOT WORK for Dq curves very similar are always different
#
diffNormT <-function (y1, y2)
{
  if (is.null(dim(y1)) || is.null(dim(y2)))
    return(NA)
  y1 <- as.matrix(y1)
  y2 <- as.matrix(y2)
  if (ncol(y1) != ncol(y2))
    stop("Number of time points must match")
  m1 <- y1[,1]
  m2 <- y2[,1]
  v1 <- y1[,2]*y1[,2]
  v2 <- y2[,2]*y2[,2]
  n1 <- y1[,3]
  n2 <- y2[,3]

  s <- sqrt(v1/n1 + v2/n2)
  d <- (m1 - m2)/(s*(m1+m2)/2)
  qqnorm(d)
  print(shapiro.test(d))
  print(t.test((m1-m2),mu=0))
}

# Comparing two curves with SD for each point using monte-carlo
# assuming each point have a normal distribution
# (Faster than average T )
#
# NOT WORKING The Dq curves are always equal!!
#
compareTwoCurvesMC <- function (group, y, sd,nsim = 1000)
{
  vstat <- double(nsim)
  group <- as.vector(group)
  g <- unique(group)
  if (length(g) != 2)
    stop("Must be exactly 2 groups")
  y1 <- y[group == g[1]]
  y2 <- y[group == g[2]]
  sd1 <-sd[group == g[1]]
  sd2 <-sd[group == g[2]]
  stat.obs <- sum((y1-y2)^2) # mean(abs(y1-y2))
  asbig <- 0
  l <- length(y1)
  for (i in 1:nsim) {
    z1=rnorm(l,y1,sd1)
    z2=rnorm(l,y2,sd2)

    stat <- sum((z1-z2)^2)
    vstat[i] <- stat
    if (abs(stat) >= abs(stat.obs))
      asbig <- asbig + 1
  }
  list(dist = vstat, stat = stat.obs, p.value = asbig/nsim)
}

# Comparing two curves with SD for each point with multiple T-tests
# using Hommel procedure to adjust p
#
# WORKS but difficult to say if the curves are different because it
# test only the points.
# In general for Dq the range q=0.5-3 is significative
# and the rest is not.
#
# If I use the fisher test to combine p it gives always significative
#
compareTwoCurvesT <- function (group, y, sd,n)
{
#  group <- as.vector(group)
  g <- unique(group)
  if (length(g) != 2)
    stop("Must be exactly 2 groups")
  y1 <- y[group == g[1]]
  y2 <- y[group == g[2]]
  sd1 <-sd[group == g[1]]
  sd2 <-sd[group == g[2]]
  sd1 <- sd1*sd1
  sd2 <- sd2*sd2
  stat <- (y1-y2)/sqrt((sd1/n)+(sd2/n))
  df <- (sd1/n+sd2/n)^2/( (sd1/n)^2 / (n-1) + (sd2/n)^2 / (n-1))
  #p.adjust <- p.adjust(pt(stat,df),method="hommel")
  p <- pt(stat,df)
  #print(ks.test(y1,y2))
  #print(t.test(y1-y2,mu=0))
  return(list("stat"=stat,"p"=p))
}

# Fisher procedure to combine p.value from multiple T test in one p.value
#
Fisher.test <- function(p) {
  Xsq <- -2*sum(log(p))
  p.val <- 1-pchisq(Xsq, df = 2*length(p))
  return(c(Xsq = Xsq, p.value = p.val))
}


do_log_reg = function(df_sub, alpha, dir, feat_df) {
# Performs logistic regression on the data frame df_sub
# Arguments:
# df_sub - data frame; column y (the last column) represents response
# alpha - 0 for ridge, 1 for lasso, 0.5 for elastic net
# dir - directory to save results
# feat_df - data frame of miRNA and precursor names by index

	# Load glmnet
	library(glmnet)

	# get nrow (m) and ncol (n) of X, the matrix without the response
	m = nrow(df_sub)
	n = ncol(df_sub) - 1

	# define X as the matrix without the response
	X = data.matrix(df_sub[ ,1:n])
	# define y as the response
	y = df_sub$y

	# Check order of categories, print out
	factor_order = levels(y)
	write.csv(factor_order, file=paste(dir, "factor_order.csv", sep=""),
			 quote=FALSE, col.names=FALSE)
	# Do leave one out cross validation
	cv.out = cv.glmnet(X, y, family="binomial",
			type.measure="class", alpha=alpha, nfolds=m)
	loocv_misclass_rate = min(cv.out$cvm)

	# Plot misclassification rates from LOOCV vs lambda parameter
	jpeg(paste(dir, "loocv_misclassification_rates.jpeg", sep=""))
	plot(cv.out)
	dev.off()

	# Choose best lambda from LOOCV
	bestlam = cv.out$lambda.min

	# Do lasso logistic regression on all of the data using best lambda
	lasso.mod = glmnet(X, y, family="binomial", alpha=alpha)
	lasso.coef = predict(lasso.mod, type="coefficients", s=bestlam)

	# Print out coefficients
	indices = rownames(lasso.coef)
	nonzero_coef = matrix(, nrow=0, ncol=2)
	colnames(nonzero_coef) = c("index", "coef")
	for (i in 2:length(lasso.coef)) {
		if (abs(lasso.coef[i]) > 0) {
			feat_string = indices[i]
			index_string = substring(feat_string, 2)
			index = as.integer(index_string)
			new_coef = c(index, lasso.coef[i])
			nonzero_coef = rbind(nonzero_coef, new_coef)
		}
	}
	nonzero_coef_df = as.data.frame(nonzero_coef)
	lr_nonzero_coef_sorted = nonzero_coef_df[order(-abs(nonzero_coef_df$coef)),]
	rownames(lr_nonzero_coef_sorted) = NULL
	# get miRNA names, append to coefficeint table
	miRNA_names = feat_df$miRNA[lr_nonzero_coef_sorted$index]
	lr_nonzero_coef_sorted = cbind(lr_nonzero_coef_sorted, miRNA_names)

	write.csv(lr_nonzero_coef_sorted, file=paste(dir, "coefs.csv", sep=""),
			row.names=FALSE)

	# Do LOOCV manually, plot ROC curve
	# http://stackoverflow.com/questions/18292419/how-to-obtain-auc-using-leave-one-out-cross-validation-in-r
	# get predictions for each sample left out in LOOCV
	predictions = c()
	for (i in 1:m) {
		model = glmnet(X[-i,], y[-i], family="binomial")
		new_x = matrix(X[i,], nrow=1, ncol=n)
		predictions <- c(predictions, predict(model, newx=new_x, s=cv.out$lambda.min))
	}
	# Plot ROC curve
	library(pROC)
	jpeg(paste(dir, "roc_curve.jpeg", sep=""))
	bin_comp.loocv_roc = roc(y, predictions)
	plot(bin_comp.loocv_roc)
	dev.off()

	# Get AUC, also return loocv misclassification rate
	bin_comp.auc = auc(bin_comp.loocv_roc)
	return_set = list(y, predictions, bin_comp.auc, loocv_misclass_rate)
	return(return_set)
}


#This script will find the yield point, Young's modulus, and
#Poisson's ratio.
#License information:
#
#MIT License
#
#Copyright (c) 2019 Will Pisani
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

if (Sys.info()['sysname']=="Linux"){
  setwd("/path/to/directory/on/linux")
} else {
# Paths in Windows in R require \\ instead of \
 setwd("C:\\path\\to\\directory\\on\\Windows")

}

#Read in csv file
ymfile <- "your_file_name_here_sim_data_YMxData.csv"
ymfilename <- strsplit(ymfile,"\\.")[[1]]
ymdat <- read.csv(ymfile)

#create vectors for stress and strain
ymstress <- ymdat[,1]
ymaxstrain <- ymdat[,2]
ymtrstrain <- ymdat[,3]
ymtime <- ymdat[,4]

#Create new vectors containing data before chain slippage, change accordingly.

ymendpoint <- length(ymaxstrain)

ymstressnew <- ymstress[1:ymendpoint]
ymaxstrainnew <- ymaxstrain[1:ymendpoint]
ymtrstrainnew <- ymtrstrain[1:ymendpoint]

#If the beginning of Poisson's ratio plot is super weird, just do ymaxstrainnew[500:ymendpoint]
psaxstrainnew <- ymaxstrainnew
pstrstrainnew <- ymtrstrainnew
# psaxstrainnew <- ymaxstrainnew[600:1700]
# pstrstrainnew <- ymtrstrainnew[600:1700]

#fit a regular linear model to data, this is for the segmented command
lin.mod <- lm(ymstressnew ~ ymaxstrainnew)
lin2.mod <- lm(pstrstrainnew ~ psaxstrainnew)

#use segmented package to calculated breakpoint(s), for multiple use c(value,value) after psi=
#Young's modulus, value for psi is guess
segmented.mod <- segmented::segmented(lin.mod, seg.Z = ~ymaxstrainnew, psi=0.02)

#Get breakpoint x-axis value for use in the Poisson's ratio breakpoint analysis
ps_psi_guess <- segmented.mod$psi[2]

#use segmented package to calculate breakpoint for Poisson's ratio data
#Uses x-axis breakpoint value from Young's modulus analysis
segmentedps.mod <- segmented::segmented(lin2.mod, seg.Z = ~psaxstrainnew, psi=0.04)

#Extract coefficients
#Set more breaks to 1 if multiple breakpoints are needed
morebreaks <- 0

#Young's modulus average and standard error
ym_value <- summary(segmented.mod)$coefficients[2,1]
ym_stderror <- summary(segmented.mod)$coefficients[2,2]
if (morebreaks == 1) {
  ym_strainvalue1 <- segmented.mod$psi[3]
  ym_strainvalue2 <- segmented.mod$psi[4]
} else {
  ym_strainvalue <- segmented.mod$psi[2]
}

#This is used in the Young's modulus plot
modulus_value <- round(ym_value/1000,digits=1)  # To get it into GPa

#Intercept of line
ym_intercept <- summary(segmented.mod)$coefficients[1,1]
ym_intstderror <- summary(segmented.mod)$coefficients[1,2]

#Extract Poisson's ratio coefficients

#Poisson's ratio and standard error
ps_value <- summary(segmentedps.mod)$coefficients[2,1]
ps_stderror <- summary(segmentedps.mod)$coefficients[2,2]

#Poisson intercept
ps_intercept <- summary(segmentedps.mod)$coefficients[1,1]
ps_intstderror <- summary(segmentedps.mod)$coefficients[1,2]

#Write matrix
if (morebreaks == 1) {
  df_ymps <- data.frame(ym_value,ym_stderror,ym_strainvalue1,ym_strainvalue2,ym_intercept,ym_intstderror,ps_value,ps_stderror,ps_intercept,ps_intstderror)

} else {
  df_ymps <- data.frame(ym_value,ym_stderror,ym_strainvalue,ym_intercept,ym_intstderror,ps_value,ps_stderror,ps_intercept,ps_intstderror)
}
#Write coefficients to file
write.table(df_ymps,file=paste(ymfilename[1],"txt",sep="."),sep="\t")

# Get point at YM_value
ym_value <- segmented.mod$psi[2]
ym_value_stderror <- segmented.mod$psi[3]
ym_y_value <- segmented.mod$coefficients[2]*ym_value+segmented.mod$coefficients[1]

#Get point at Poisson value
ps_ax_value <- segmentedps.mod$psi[2] # x-axis value of breakpoint
ps_tr_value <- segmentedps.mod$coefficients[2]*ps_ax_value+ps_intercept

# Create moving average for journal article
ma <- function(x,n=5){filter(x,rep(1/n,n),sides=2)}
ymstressma <- ma(ymstress)
ymaxstrainma <- ma(ymaxstrain)

# Need to plot full stress strain curve
# pdf(paste(ymfilename[1],"_PEEKpaper_fullcurve",".pdf",sep=""))
# par(cex.lab=1.5,cex.axis=1.5)
# plot(ymaxstrainma,ymstressma,col="black",cex.lab=3,xlim=c(0,0.2),ylim=c(-50,max(ymstressnew)),xlab = 'True Strain',ylab = 'True Stress (MPa)')
# dev.off()

#Plot breakpoint analysis for Young's modulus
pdf(paste(ymfilename[1],"_zoomedin",".pdf",sep=""))
par(cex.lab=1.5,cex.axis=1.5)
# The below is for normal analysis. The second plot is for journal articles.
plot(ymaxstrainnew,ymstressnew,col="black",xlim=c(0,max(ymaxstrainnew)),ylim=c(min(ymstressnew),max(ymstressnew)),main = paste("Young's Modulus=",modulus_value,"GPa"),xlab = 'True Strain',ylab = 'True Stress (MPa)')
# plot(ymaxstrainnew,ymstressnew,col="black",xlim=c(0,max(ymaxstrainnew)),ylim=c(-50,max(ymstressnew)),xlab = 'True Strain',ylab = 'True Stress (MPa)')
#par(new = TRUE)
plot(segmented.mod,col="red",lwd=3,xlim=c(0,max(ymaxstrainnew)),ylim=c(min(ymstressnew),max(ymstressnew)),xlab = '',ylab = '',rug=FALSE,add=TRUE)
#par(new = TRUE)
points(ym_value,ym_y_value,pch=21,cex=4,col="lightskyblue",bg="lightskyblue",xlim=c(0,max(ymaxstrainnew)),ylim=c(min(ymstressnew),max(ymstressnew)),xlab = '',ylab = '')
dev.off()

#Plot breakpoint analysis for Poisson's ratio
ympoissonname <- paste(ymfilename[1],"_Poisson",sep="")
pdf(paste(ympoissonname,"pdf",sep="."))
plot(psaxstrainnew,pstrstrainnew,col="blue",xlim=c(0,max(psaxstrainnew)),ylim=c(-0.1,0.1),main = paste("Poisson's ratio =",abs(round(ps_value,digits=4))),xlab = 'True Axial Strain',ylab = 'True Transverse Strain')
par(new = TRUE)
plot(segmentedps.mod,col="red",xlim=c(0,max(psaxstrainnew)),ylim=c(-0.1,0.1),xlab = '',ylab = '',rug=FALSE)
par(new = TRUE)
plot(ps_ax_value,ps_tr_value,pch=24,col="black",bg="black",xlim=c(0,max(psaxstrainnew)),ylim=c(-0.1,0.1),xlab = '',ylab = '')
dev.off()


# Load library
library(dplyr)

## Define the rate column
murders <- mutate(murders, rate =  total / population * 100000, rank = rank(-rate))

# show the result and only include the state, rate, and rank columns, all in one line

filter (murders, region %in% c("Northeast", "West") & rate <1) %>% select(state, rate, rank)


library(tseries)
library("dplyr")
library(summarytools)
library(xlsx)
library(psych)
library(midasr)
library(broom)
library(ggplot2)
library(lmtest)
library(vars)
library(TSstudio)
library(mFilter)
library(forecast)
library(tidyverse)
library(caret)
library(leaps)
library(car)

#### FINAL DATA FOR ANALYSIS
data <- read.csv(file = 'data.csv', sep=",", dec=".", header=TRUE, stringsAsFactors = FALSE)
#data <- subset (data, select = -X)
data <- select_if(data, is.numeric)
data$exchange_balance. <- NULL
data$pctutxo_in_profit_change <- NULL
data$hodl_5y_7y_change <- NULL
data$hodl_7y_10y_change <- NULL
data$hodl_more_10y_change <- NULL
data$nvt_signal_change <- NULL
data$nvt_ratio <- NULL

View(data)

## Stationarity tests
# Hypothesis 0 (H0): Assumption of the test holds and is failed to be rejected at some level of significance.
# Hypothesis 1 (H1): Assumption of the test does not hold and is rejected at some level of significance.
# If p-value > alpha: Fail to reject the null hypothesis (i.e. not significant result).
# If p-value <= alpha: Reject the null hypothesis (i.e. significant result).
# If test statistic < critical value: Fail to reject the null hypothesis.
# If test statistic >= critical value: Reject the null hypothesis.
# ADF H0 = non-stationarity H1 = stationarity
# ADF critical values: -3.12 (10%), -3.41 (5%), -3.96 (1%)
# kpss.test null= stationarity
# pp.test null = NON-stationarity
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
# null hypothesis of homoskedasticity

x <- data$active_addresses_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$btc_returns
x = ts(x, frequency = 1)
adf.test(x)
x <- data$addresses_balance_1k_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$coin_days_destroyed
x = ts(x, frequency = 1)
adf.test(x)
x <- data$exchange_balancepct_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$exchange_netflow
x = ts(x, frequency = 1)
adf.test(x)
x <- data$fee_ratio_multiple_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hodl_24h
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hodl_1d_1w
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hodl_1w_1m
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hodl_1m_3m
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hodl_3m_6m_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hodl_6m_12m_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hodl_1y_2y_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hodl_2y_3y_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hodl_3y_5y_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$liveliness_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$nvt_ratio
x = ts(x, frequency = 1)
adf.test(x)
x <- data$nvt_signal_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$pctsupply_in_profit_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$pctutxo_in_profit_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$circ_supply_lastactive_1yplus_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$dormancy
x = ts(x, frequency = 1)
adf.test(x)
x <- data$hashrate_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$Gold_returns
x = ts(x, frequency = 1)
adf.test(x)
x <- data$m2_change
x = ts(x, frequency = 1)
adf.test(x)
x <- data$deficit_change
x = ts(x, frequency = 1)
adf.test(x)

## Descriptive statistics
summary(data)
StatDes <- summarytools::descr(data)
print(StatDes, short = FALSE)
write.xlsx(StatDes, file="descriptive_statistics.xlsx", sheetName="Sheet1",
           col.names=TRUE, row.names=TRUE, append=FALSE)

## Correlation matrix
out <- corr.test(data, y = NULL, use = "pairwise",method="pearson",adjust="holm",alpha=.05, ci=TRUE)
print(out, short = FALSE)
mat.c.p <- lower.tri(out$r)*out$r
mat.c.p
write.xlsx(mat.c.p, file="correlation1.xlsx", sheetName="Sheet1",
           col.names=TRUE, row.names=TRUE, append=FALSE)

out <- corr.test(data, y = NULL, use = "pairwise",method="kendall",adjust="holm",alpha=.05, ci=TRUE)
print(out, short = FALSE)
mat.c.p <- lower.tri(out$p)*out$p
mat.c.p
write.xlsx(mat.c.p, file="correlation2.xlsx", sheetName="Sheet2",
           col.names=TRUE, row.names=TRUE, append=FALSE)

### LINEAR REGRESSION
## Model auto selection

# forward elimination based on AIC
null<-lm(btc_returns~ 1, data=data) # 1 here means the intercept
full<-lm(btc_returns~ active_addresses_change + coin_days_destroyed + exchange_netflow + hodl_24h +
           hodl_1d_1w + hodl_1w_1m + hodl_1m_3m + hodl_3m_6m_change +
           hodl_6m_12m_change + hodl_1y_2y_change + hodl_2y_3y_change +
           hodl_3y_5y_change + dormancy +
           pctsupply_in_profit_change +
           addresses_balance_1k_change + hashrate_change + fee_ratio_multiple_change +
           exchange_balancepct_change + liveliness_change +
           circ_supply_lastactive_1yplus_change + Gold_returns + m2_change + deficit_change, data=data)
stepAIC(null, scope=list(lower=null, upper=full), data=data, direction='forward')

# stepwise based on AIC
null<-lm(btc_returns~ 1, data=data) # 1 here means the intercept
full<-lm(btc_returns~ active_addresses_change + coin_days_destroyed + exchange_netflow + hodl_24h +
           hodl_1d_1w + hodl_1w_1m + hodl_1m_3m + hodl_3m_6m_change +
           hodl_6m_12m_change + hodl_1y_2y_change + hodl_2y_3y_change +
           hodl_3y_5y_change + dormancy +
           pctsupply_in_profit_change +
           addresses_balance_1k_change + hashrate_change + fee_ratio_multiple_change +
           exchange_balancepct_change + liveliness_change +
           circ_supply_lastactive_1yplus_change + Gold_returns + m2_change + deficit_change, data=data)
stepAIC(null, scope=list(lower=null, upper=full), data=data, direction='both')

## General model based on stepwise/forward/backwards elimination
model = lm(btc_returns ~ pctsupply_in_profit_change + hodl_1d_1w +
             active_addresses_change + exchange_netflow + fee_ratio_multiple_change +
             hodl_1y_2y_change + deficit_change + hodl_1m_3m, data=data)
summary(model)
AIC(model)
# Tests on the residuals
# Residual plot
hist(residuals(model))
# Analysis of normality
residplot <- ggplot(aes(x=.fitted, y=.resid),data=model)+geom_point()+geom_hline(yintercept=0)+labs(x="Fitted Values",y="Residuals")
residplot
boxplot(residuals(model))
stdresid = rstandard(model)
qqnorm(stdresid, ylab="Standardized Residuals", xlab="Normal Scores", main="Are residuals normally distributed?")
qqline(stdresid)
# Normality test (an alternative is Jarque-Bera)
shapiro.test(residuals(model))
jarque.bera.test(residuals(model))
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
bptest(model)
# Breusch Godfrey test for serial correlation
bgtest(model, order = 2, data=data)
# if there is heteroskedasticity -> regression with robust standard errors
coeftest(model, vcov = vcovHAC)

## DEMAND
demand = lm(btc_returns~ active_addresses_change, data=data)
summary(demand)
AIC(demand)
# Tests on the residuals
# Normality test (an alternative is Jarque-Bera)
shapiro.test(residuals(demand))
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
bptest(demand)
# Breusch Godfrey test for serial correlation
bgtest(demand, order = 2, data=data)
## DEMAND ROBUST STANDARD ERRORS REGRESSION
coeftest(demand, vcov = vcovHAC)
linearHypothesis(demand, "active_addresses_change", vcov=vcovHAC)

## Demand controlled by security
demandsec = lm(btc_returns~ active_addresses_change + hashrate_change + fee_ratio_multiple_change, data=data)
summary(demandsec)
AIC(demandsec)
coeftest(demandsec, vcov = vcovHAC)
# Normality test (an alternative is Jarque-Bera)
shapiro.test(residuals(demandsec))
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
bptest(demandsec)
# Breusch Godfrey test for serial correlation
bgtest(demandsec, order = 2, data=data)

## Demand controlled by security and macro
demandmacro = lm(btc_returns~ active_addresses_change + hashrate_change + fee_ratio_multiple_change + Gold_returns + m2_change + deficit_change, data=data)
summary(demandmacro)
AIC(demandmacro)
reg_demandmacro <- tidy(demandmacro)
coeftest(demandmacro, vcov = vcovHAC)
# Normality test (an alternative is Jarque-Bera)
shapiro.test(residuals(demandmacro))
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
bptest(demandmacro)
# Breusch Godfrey test for serial correlation
bgtest(demandmacro, order = 2, data=data)

## SUPPLY
# stepwise based on AIC
null<-lm(btc_returns~ 1, data=data) # 1 here means the intercept
full<-lm(btc_returns~ hodl_24h + hodl_1d_1w + hodl_1w_1m + hodl_1m_3m + hodl_3m_6m_change +
           hodl_6m_12m_change + hodl_1y_2y_change + hodl_2y_3y_change + hodl_3y_5y_change +
           liveliness_change + coin_days_destroyed + dormancy + exchange_netflow + exchange_balancepct_change
         + circ_supply_lastactive_1yplus_change + addresses_balance_1k_change +
           pctsupply_in_profit_change, data=data, direction='both')
stepAIC(null, scope=list(lower=null, upper=full), data=data, direction='both')

supplyall = lm(btc_returns~ hodl_24h + hodl_1d_1w + hodl_1w_1m + hodl_1m_3m + hodl_3m_6m_change +
                 hodl_6m_12m_change + hodl_1y_2y_change + hodl_2y_3y_change + hodl_3y_5y_change +
                 liveliness_change + coin_days_destroyed + dormancy + exchange_netflow + exchange_balancepct_change
               + circ_supply_lastactive_1yplus_change + addresses_balance_1k_change +
                 pctsupply_in_profit_change, data=data)
summary(supplyall)

supply = lm(btc_returns ~ pctsupply_in_profit_change + hodl_1d_1w +
              exchange_netflow + hodl_24h + hodl_1y_2y_change + liveliness_change, data = data)
summary(supply)
AIC(supply)
# Normality test (an alternative is Jarque-Bera)
shapiro.test(residuals(supply))
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
bptest(supply)
# Breusch Godfrey test for serial correlation
bgtest(supply, order = 2, data=data)
coeftest(supply, vcov = vcovHAC)
# supply controlled by security
supplysec = lm(btc_returns~ pctsupply_in_profit_change + hodl_1d_1w +
                 exchange_netflow + hodl_24h + hodl_1y_2y_change + liveliness_change
               + hashrate_change + fee_ratio_multiple_change, data=data)
summary(supplysec)
AIC(supplysec)
coeftest(supplysec, vcov = vcovHAC)
# Normality test (an alternative is Jarque-Bera)
shapiro.test(residuals(supplysec))
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
bptest(supplysec)
# Breusch Godfrey test for serial correlation
bgtest(supplysec, order = 2, data=data)
# supply controlled by security and macro
supplymacro = lm(btc_returns ~ pctsupply_in_profit_change + hodl_1d_1w +
                   exchange_netflow + hodl_24h + hodl_1y_2y_change + liveliness_change
                 + hashrate_change + fee_ratio_multiple_change
                 + Gold_returns + m2_change + deficit_change, data=data)
summary(supplymacro)
AIC(supplymacro)
coeftest(supplymacro, vcov = vcovHAC)
# Normality test (an alternative is Jarque-Bera)
shapiro.test(residuals(supplymacro))
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
bptest(supplymacro)
# Breusch Godfrey test for serial correlation
bgtest(supplymacro, order = 2, data=data)

## SECURITY REGRESSION
security = lm(btc_returns ~ hashrate_change + fee_ratio_multiple_change, data=data)
summary(security)
AIC(security)
bptest(security)
coeftest(security, vcov = vcovHAC)
# Normality test (an alternative is Jarque-Bera)
shapiro.test(residuals(security))
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
bptest(security)
# Breusch Godfrey test for serial correlation
bgtest(security, order = 2, data=data)

## MACRO REGRESSION
macro = lm(btc_returns ~ Gold_returns + m2_change + deficit_change, data=data)
summary(macro)
AIC(macro)
coeftest(macro, vcov = vcovHAC)
# Normality test (an alternative is Jarque-Bera)
shapiro.test(residuals(macro))
# Test d'hétéroscédasticité (Breusch-Pagan - bptest)
bptest(macro)
# Breusch Godfrey test for serial correlation
bgtest(macro, order = 2, data=data)

### VAR Regression
# data
btc_returns <- ts(data$btc_returns, frequency = 365)
active_addresses_change <- ts(data$active_addresses_change, frequency = 365)
hodl_24h <- ts(data$hodl_24h, frequency = 365)
hodl_1d_1w <- ts(data$hodl_1d_1w, frequency = 365)
hodl_1w_1m <- ts(data$hodl_1w_1m, frequency = 365)
hodl_1m_3m <- ts(data$hodl_1m_3m, frequency = 365)
hodl_3m_6m_change <- ts(data$hodl_3m_6m_change, frequency = 365)
hodl_6m_12m_change <- ts(data$hodl_6m_12m_change, frequency = 365)
hodl_1y_2y_change <- ts(data$hodl_1y_2y_change, frequency = 365)
hodl_2y_3y_change <- ts(data$hodl_2y_3y_change, frequency = 365)
hodl_3y_5y_change <- ts(data$hodl_3y_5y_change, frequency = 365)
liveliness_change <- ts(data$liveliness_change, frequency = 365)
coin_days_destroyed <- ts(data$coin_days_destroyed, frequency = 365)
dormancy <- ts(data$dormancy, frequency = 365)
exchange_netflow <- ts(data$exchange_netflow, frequency = 365)
exchange_balancepct_change <- ts(data$exchange_balancepct_change, frequency = 365)
circ_supply_lastactive_1yplus_change <- ts(data$circ_supply_lastactive_1yplus_change, frequency = 365)
addresses_balance_1k_change <- ts(data$addresses_balance_1k_change, frequency = 365)
pctsupply_in_profit_change <- ts(data$pctsupply_in_profit_change, frequency = 365)
hashrate_change <- ts(data$hashrate_change, frequency = 365)
fee_ratio_multiple_change <- ts(data$fee_ratio_multiple_change, frequency = 365)
Gold_returns <- ts(data$Gold_returns, frequency = 365)
m2_change <- ts(data$m2_change, frequency = 365)
deficit_change <- ts(data$deficit_change, frequency = 365)

var_data <- cbind(btc_returns, active_addresses_change, hodl_24h, hodl_1d_1w, hodl_1w_1m,
                  hodl_1m_3m, hodl_3m_6m_change,
                  hodl_6m_12m_change, hodl_1y_2y_change, hodl_2y_3y_change,
                  hodl_3y_5y_change, liveliness_change, coin_days_destroyed,
                  dormancy, exchange_netflow, exchange_balancepct_change, circ_supply_lastactive_1yplus_change,
                  addresses_balance_1k_change, pctsupply_in_profit_change,
                  hashrate_change, fee_ratio_multiple_change, Gold_returns, m2_change, deficit_change)

#1 BEST BTC RETURNS MODEL
var_data <- cbind(btc_returns, active_addresses_change, pctsupply_in_profit_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model1 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model1)
# pctsupply_in_profit_change 0.04424,	Adjusted R-squared: 0.03599
# active_addresses_change 0.4459,	Adjusted R-squared: 0.4411
# btc_returns 0.269,	Adjusted R-squared: 0.2626
# Model diagnostics
# autocorrelation
Serial1 <- serial.test(var_model1, lags.pt = 8, type = "BG")
Serial1
# heteroscedasticity
# ARCH effects are clustered volatility areas in a time series excessive volatility
# changing the variance of the residuals, far from our assumption of constant variance
Arch1 <- arch.test(var_model1, lags.multi = 8, multivariate.only = TRUE)
Arch1
# Normality of residuals
Norm1 <- normality.test(var_model1, multivariate.only = TRUE)
Norm1

## Granger causality
GrangerRRP<- causality(var_model1, cause = "btc_returns")
GrangerRRP
GrangerRRP<- causality(var_model1, cause = "active_addresses_change")
GrangerRRP
GrangerRRP<- causality(var_model1, cause = "pctsupply_in_profit_change")
GrangerRRP

## Impulse Response Functions
btc_irf <- irf(var_model1, impulse = "btc_returns", response = "btc_returns", n.ahead = 20, boot = TRUE)
plot(btc_irf, ylab = "btc_returns", main = "btc_returns shock to btc_returns")
activeadd_irf <- irf(var_model1, impulse = "btc_returns", response = "active_addresses_change", n.ahead = 20, boot = TRUE)
plot(activeadd_irf, ylab = "active_addresses_change", main = "btc_returns shock to active_addresses_change")
pctsupply_irf <- irf(var_model1, impulse = "btc_returns", response = "pctsupply_in_profit_change", n.ahead = 20, boot = TRUE)
plot(pctsupply_irf, ylab = "pctsupply_in_profit_change", main = "btc_returns shock to pctsupply_in_profit_change")
pctsupply_irf <- irf(var_model1, impulse = "pctsupply_in_profit_change", response = "btc_returns", n.ahead = 20, boot = TRUE)
plot(pctsupply_irf, ylab = "pctsupply_in_profit_change", main = "btc_returns shock to pctsupply_in_profit_change")

#2
var_data <- cbind(btc_returns, active_addresses_change, coin_days_destroyed)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model2 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model2)
# error: Error in solve.default(Sigma) :
# system is computationally singular: reciprocal condition number = 5.31661e-18

#3
var_data <- cbind(btc_returns, active_addresses_change, exchange_netflow)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model3 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model3)
# exchange_netflow 0.0238,	Adjusted R-squared: 0.01537
# active_addresses_change 0.4464,	Adjusted R-squared: 0.4416
# btc_returns 0.08789,	Adjusted R-squared: 0.08001

#4
var_data <- cbind(btc_returns, active_addresses_change, hodl_24h)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model4 <- VAR(var_data, p = 10, type = "const", season = NULL, exog = NULL)
summary(var_model4)
# hodl_24h 0.6172,	Adjusted R-squared: 0.613
# active_addresses_change 0.4572,	Adjusted R-squared: 0.4513
# btc_returns 0.09002,	Adjusted R-squared: 0.08016

#5
var_data <- cbind(btc_returns, active_addresses_change, hodl_1d_1w)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model5 <- VAR(var_data, p = 10, type = "const", season = NULL, exog = NULL)
summary(var_model5)
# hodl_1d_1w 0.9046,	Adjusted R-squared: 0.9036
# active_addresses_change 0.4584,	Adjusted R-squared: 0.4526
# btc_returns 0.08734,	Adjusted R-squared: 0.07746

#6
var_data <- cbind(btc_returns, active_addresses_change, hodl_1w_1m)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model6 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model6)
# hodl_1w_1m 0.9846,	Adjusted R-squared: 0.9845
# active_addresses_change 0.4483,	Adjusted R-squared: 0.4436
# btc_returns 0.08068,	Adjusted R-squared: 0.07273

#7 MEILLEUR MODÈLE OFFRE ET DEMANDE
var_data <- cbind(btc_returns, active_addresses_change, hodl_1m_3m)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model7 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model7)
# hodl_1m_3m 0.996,	Adjusted R-squared: 0.996
# active_addresses_change 0.4487,	Adjusted R-squared: 0.444
# btc_returns 0.07987,	Adjusted R-squared: 0.07192
# Model diagnostics
# autocorrelation
Serial1 <- serial.test(var_model7, lags.pt = 8, type = "BG")
Serial1
# heteroscedasticity
# ARCH effects are clustered volatility areas in a time series excessive volatility
# changing the variance of the residuals, far from our assumption of constant variance
Arch1 <- arch.test(var_model7, lags.multi = 8, multivariate.only = TRUE)
Arch1
# Normality of residuals
Norm1 <- normality.test(var_model7, multivariate.only = TRUE)
Norm1

## Granger causality
GrangerRRP<- causality(var_model7, cause = "btc_returns")
GrangerRRP
GrangerRRP<- causality(var_model7, cause = "active_addresses_change")
GrangerRRP
GrangerRRP<- causality(var_model7, cause = "hodl_1m_3m")
GrangerRRP

## Impulse Response Functions
btc_irf <- irf(var_model1, impulse = "btc_returns", response = "btc_returns", n.ahead = 20, boot = TRUE)
plot(btc_irf, ylab = "btc_returns", main = "btc_returns shock to btc_returns")
activeadd_irf <- irf(var_model1, impulse = "btc_returns", response = "active_addresses_change", n.ahead = 20, boot = TRUE)
plot(activeadd_irf, ylab = "active_addresses_change", main = "btc_returns shock to active_addresses_change")
pctsupply_irf <- irf(var_model1, impulse = "btc_returns", response = "pctsupply_in_profit_change", n.ahead = 20, boot = TRUE)
plot(pctsupply_irf, ylab = "pctsupply_in_profit_change", main = "btc_returns shock to pctsupply_in_profit_change")
pctsupply_irf <- irf(var_model1, impulse = "pctsupply_in_profit_change", response = "btc_returns", n.ahead = 20, boot = TRUE)
plot(pctsupply_irf, ylab = "pctsupply_in_profit_change", main = "btc_returns shock to pctsupply_in_profit_change")

#8
var_data <- cbind(btc_returns, active_addresses_change, dormancy)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model8 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model8)
# dormancy 0.2043,	Adjusted R-squared: 0.1974
# active_addresses_change 0.4451,	Adjusted R-squared: 0.4403
# btc_returns 0.081,	Adjusted R-squared: 0.07306

#9
var_data <- cbind(btc_returns, active_addresses_change, addresses_balance_1k_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model9 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model9)
# addresses_balance_1k_change 0.008167,	Adjusted R-squared: -0.0004018
# active_addresses_change 0.4453,	Adjusted R-squared: 0.4405
# btc_returns 0.08005,	Adjusted R-squared: 0.0721

#10
var_data <- cbind(btc_returns, active_addresses_change, exchange_balancepct_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model10 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model10)
# exchange_balancepct_change 0.02256,	Adjusted R-squared: 0.01411
# active_addresses_change 0.4454,	Adjusted R-squared: 0.4406
# btc_returns 0.08636,	Adjusted R-squared: 0.07847

#11
var_data <- cbind(btc_returns, active_addresses_change, circ_supply_lastactive_1yplus_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model11 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model11)
# circ_supply_lastactive_1yplus_change 0.1346,	Adjusted R-squared: 0.1271
# active_addresses_change 0.4452,	Adjusted R-squared: 0.4404
# btc_returns 0.08246,	Adjusted R-squared: 0.07453

#12
var_data <- cbind(btc_returns, active_addresses_change, hodl_3m_6m_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model12 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model12)
# hodl_3m_6m_change 0.1151,	Adjusted R-squared: 0.1074
# active_addresses_change 0.446,	Adjusted R-squared: 0.4412
# btc_returns 0.08101,	Adjusted R-squared: 0.07307

#13
var_data <- cbind(btc_returns, active_addresses_change, hodl_6m_12m_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model13 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model13)
# hodl_6m_12m_change 0.1422,	Adjusted R-squared: 0.1348
# active_addresses_change 0.4469,	Adjusted R-squared: 0.4421
# btc_returns 0.07828,	Adjusted R-squared: 0.07032

#14
var_data <- cbind(btc_returns, active_addresses_change, hodl_1y_2y_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model14 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model14)
# hodl_1y_2y_change  0.1189,	Adjusted R-squared: 0.1113
# active_addresses_change 0.4473,	Adjusted R-squared: 0.4425
# btc_returns 0.09433,	Adjusted R-squared: 0.08651

#15
var_data <- cbind(btc_returns, active_addresses_change, hodl_2y_3y_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model15 <- VAR(var_data, p = 10, type = "const", season = NULL, exog = NULL)
summary(var_model15)
# hodl_2y_3y_change  0.07127,	Adjusted R-squared: 0.06121
# active_addresses_change 0.4466,	Adjusted R-squared: 0.4406
# btc_returns 0.08559,	Adjusted R-squared: 0.07569

#16
var_data <- cbind(btc_returns, active_addresses_change, hodl_3y_5y_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model16 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model16)
# hodl_3y_5y_change  0.07568,	Adjusted R-squared: 0.06769
# active_addresses_change 0.4446,	Adjusted R-squared: 0.4398
# btc_returns 0.07826,	Adjusted R-squared: 0.0703

#17
var_data <- cbind(btc_returns, active_addresses_change, liveliness_change)
lagselect <- VARselect(var_data, type = "const")
lagselect$selection
var_model16 <- VAR(var_data, p = 8, type = "const", season = NULL, exog = NULL)
summary(var_model16)
# liveliness_change  0.1952,	Adjusted R-squared: 0.1882
# active_addresses_change 0.4455,	Adjusted R-squared: 0.4407
# btc_returns 0.08278,	Adjusted R-squared: 0.07486