# Given a data frame (df) returns the same df without the class columns
factors.remove <- function (df)
{
  factors <- names(Filter(is.factor, df))
  return(df[,which(names(df) != factors)])
}

factors.get <- function (df)
{
  factors <- names(Filter(is.factor, df))
  return(df[,which(names(df) == factors)])
}

auc_all <- function (df)
{
  predictor = factors.get(df)

  level_count = length(levels(predictor))

  df_names <- c()
  df_aucs <- c()

  for(name in names(factors.remove(df))) {
    if (level_count > 2) {
      r <- pROC::multiclass.roc(predictor, df[,name])
      a <- as.numeric(r$auc)
    }else {
      a <- pROC::auc(predictor, df[,name])
    }
    df_names <- c(df_names, name)
    df_aucs <- c(df_aucs, a)
  }

  return(data.frame(names=df_names, aucs=df_aucs))
}

svm_rfe__single_step <- function(X, y, ...) {

  library(kernlab)

  # keep track of the iteration during which
  # a feature was eliminated
  ii <- rep(NA, ncol(X))
  i <- 0
  while ( any(is.na(ii)) ) {
    # indices of remaining features
    not_elim_yet <- which(is.na(ii))
    # train the classifier on the remaining features
    fit <- ksvm(X[,not_elim_yet], y, scaled = FALSE, ...)
    # compute the feature weights
    sv_i <- alphaindex(fit)[[1]]
    w <- t( coef(fit)[[1]] ) %*% X[ sv_i, not_elim_yet ]
    # eliminate the feature with the smallest squared weight
    to_elim <- not_elim_yet[ head(order( w * w ), 1) ]
    ii[to_elim] <- i
    i <- i + 1
  }
  # convert iterations into ranks
  print (i)
  print (ii)
  i - ii
}

calculate.confusion <- function(states, clusters)
{
  # generate a confusion matrix of cols C versus states S
  d <- data.frame(state = states, cluster = clusters)
  td <- as.data.frame(table(d))
  # convert from raw counts to percentage of each label
  pc <- matrix(ncol=max(clusters),nrow=0) # k cols
  for (i in 1:9) # 9 labels
  {
    total <- sum(td[td$state==td$state[i],3])
    pc <- rbind(pc, td[td$state==td$state[i],3]/total)
  }
  rownames(pc) <- td[1:9,1]
  return(pc)
}

assign.cluster.labels <- function(cm, k)
{
  # take the cluster label from the highest percentage in that column
  cluster.labels <- list()
  for (i in 1:k)
  {
    cluster.labels <- rbind(cluster.labels, row.names(cm)[match(max(cm[,i]), cm[,i])])
  }

  # this may still miss some labels, so make sure all labels are included
  for (l in rownames(cm))
  {
    if (!(l %in% cluster.labels))
    {
      cluster.number <- match(max(cm[l,]), cm[l,])
      cluster.labels[[cluster.number]] <- c(cluster.labels[[cluster.number]], l)
    }
  }
  return(cluster.labels)
}

calculate.accuracy <- function(states, clabels)
{
  matching <- Map(function(state, labels) { state %in% labels }, states, clabels)
  tf <- unlist(matching, use.names=FALSE)
  return (sum(tf)/length(tf))
}

# Remove Outliers from Dataframe using Grubbs test
grubbs.RemoveOutliersOnDataframe <- function(x, factorCol) {
    for (name in colnames(x)) {
        test <- x[,c(name)]
        grubbs.result <- grubbs.test(test)
        pv <- grubbs.result$p.value
        if (is.na(pv)) {
            pv <- 1
        }
        while(pv < 0.05) {
            outlierValue <- as.numeric(strsplit(grubbs.result$alternative," ")[[1]][3])
            roundedtest <- round(test, 6)
            indexOfOutlier <- which(roundedtest ==  round(outlierValue, 6))[1]
            x <- x[-c(indexOfOutlier),]
            if(!missing(factorCol)) {
              factorCol <- factorCol[-c(indexOfOutlier)]
            }
            # else {
            #   x + y
            # }
            test <- x[,c(name)]
            grubbs.result <- grubbs.test(test)
            pv <- grubbs.result$p.value
            # p-value goes to 0 when all the values are equal
            if (is.na(pv) || (sum(abs(diff(test))) == 0)) {
                pv <- 1
            }
        }
    }
    return (cbind(factorCol,x))
}

calc_ROC_2Classes <- function(probabilities, known_truth, model.name=NULL)
{
  library(dplyr)
  outcome <- as.numeric(factor(known_truth))-1
  pos <- sum(outcome) # total known positives
  neg <- sum(1-outcome) # total known negatives
  pos_probs <- outcome*probabilities # probabilities for known positives
  neg_probs <- (1-outcome)*probabilities # probabilities for known negatives
  true_pos <- sapply(probabilities,
                     function(x) sum(pos_probs>=x)/pos) # true pos. rate
  false_pos <- sapply(probabilities,
                      function(x) sum(neg_probs>=x)/neg)
  if (is.null(model.name))
    result <- data.frame(true_pos, false_pos)
  else
    result <- data.frame(true_pos, false_pos, model.name)
  result %>% arrange(false_pos, true_pos)
}

####################################
## Hack to return multiple values ##
####################################
':=' <- function(lhs, rhs) {
  frame <- parent.frame()
  lhs <- as.list(substitute(lhs))
  if (length(lhs) > 1)
    lhs <- lhs[-1]
  if (length(lhs) == 1) {
    do.call(`=`, list(lhs[[1]], rhs), envir=frame)
    return(invisible(NULL))
  }
  if (is.function(rhs) || is(rhs, 'formula'))
    rhs <- list(rhs)
  if (length(lhs) > length(rhs))
    rhs <- c(rhs, rep(list(NULL), length(lhs) - length(rhs)))
  for (i in 1:length(lhs))
    do.call(`=`, list(lhs[[i]], rhs[[i]]), envir=frame)
  return(invisible(NULL))
}

# Function that recieves dataframe and select the specified number of features using a specific feature selection method
selectFeaturesWithFSMethods <- function(data_train, data_train_whc, number_features, fs) { #whc means with highly correlated as this is multivariate and should deal with those relations
  if (fs == 'FSCR') { # Fisher score (FSCR)
    library(PredPsych)
    fisher.score <- fscore(data_train, 1, seq(2,ncol(data_train)), silent = FALSE)
    df_fisher_score <- data.frame(fisher.score)
    colnames(df_fisher_score) <- c("fscore")
    df_fisher_score <- df_fisher_score[order(df_fisher_score$fscore, decreasing = TRUE), , drop = FALSE]
    namesOfFeature <- rownames(df_fisher_score)
    selectedFeatures <- namesOfFeature[seq(1, number_features)]

    label_selectedFeatures <- c("Label", selectedFeatures)
    joint_df <- data_train[ , label_selectedFeatures]

  }
  else if (fs == 'RELF') { # Relief (RELF)
    library(CORElearn)
    relief_score <- CORElearn::attrEval(LABEL_COL, data_train, "Relief")
    df_relief_score <- data.frame(relief_score)
    colnames(df_relief_score) <- c("reliefscore")
    df_relief_score <- df_relief_score[order(df_relief_score$reliefscore, decreasing = TRUE), , drop = FALSE]
    namesOfFeature <- rownames(df_relief_score)
    selectedFeatures <- namesOfFeature[seq(1, number_features)]

    label_selectedFeatures <- c("Label", selectedFeatures)
    joint_df <- data_train[ , label_selectedFeatures]

  }
  else if (fs == 'TSCR') { # T-test (t-score) (TSCR)
    library(stats)
    group <- data_train$Label
    t_test_score <- lapply(data_train[,-1], function(x) { stats::t.test(x ~ group)$statistic })
    t_test_score_unlist <- unlist(t_test_score,use.names=TRUE)
    df_t_test_score <- data.frame(matrix(t_test_score_unlist))
    rownames(df_t_test_score) <- c(colnames(data_train[,-1]))
    colnames(df_t_test_score) <- c("ttestscore")
    df_t_test_score <- df_t_test_score[order(df_t_test_score$ttestscore, decreasing = TRUE), , drop = FALSE]
    namesOfFeature <- rownames(df_t_test_score)
    selectedFeatures <- namesOfFeature[seq(1, number_features)]

    label_selectedFeatures <- c("Label", selectedFeatures)
    joint_df <- data_train[ , label_selectedFeatures]

  }
  else if (fs == 'CHSQ') { # Chi-square (CHSQ)
    group <- data_train$Label
    chi_square_score <- lapply(data_train[,-1], function(x) { chisq.test(cbind(-1 * min(x) + x, group))$statistic })
    chi_square_score_unlist <- unlist(chi_square_score,use.names=TRUE)
    df_chi_square_score <- data.frame(matrix(chi_square_score_unlist))
    rownames(df_chi_square_score) <- c(colnames(data_train[,-1]))
    colnames(df_chi_square_score) <- c("chisquaretestscore")
    df_chi_square_score <- df_chi_square_score[order(df_chi_square_score$chisquaretestscore, decreasing = TRUE), , drop = FALSE]
    namesOfFeature <- rownames(df_chi_square_score)
    selectedFeatures <- namesOfFeature[seq(1, number_features)]

    label_selectedFeatures <- c("Label", selectedFeatures)
    joint_df <- data_train[ , label_selectedFeatures]

  }
  else if (fs == 'WLCX') { # Wilcoxon (WLCX)
    group <- data_train$Label
    wilcox_score <- lapply(data_train[,-1], function(x) { wilcox.test( x, as.numeric(group))$statistic })
    wilcox_score_unlist <- unlist(wilcox_score,use.names=TRUE)
    df_wilcox_score <- data.frame(matrix(wilcox_score_unlist))
    rownames(df_wilcox_score) <- c(colnames(data_train[,-1]))
    colnames(df_wilcox_score) <- c("wilcoxtestscore")
    df_wilcox_score <- df_wilcox_score[order(df_wilcox_score$wilcoxtestscore, decreasing = FALSE), , drop = FALSE]
    namesOfFeature <- rownames(df_wilcox_score)
    selectedFeatures <- namesOfFeature[seq(1, number_features)]

    label_selectedFeatures <- c("Label", selectedFeatures)
    joint_df <- data_train[ , label_selectedFeatures]

  }
  else if (fs == 'GINI') { # Gini index (GINI)
    library(CORElearn)
    gini_index_score <- CORElearn::attrEval(LABEL_COL, data_train, "Gini")
    df_gini_index_score <- data.frame(gini_index_score)
    colnames(df_gini_index_score) <- c("giniscore")
    df_gini_index_score <- df_gini_index_score[order(df_gini_index_score$giniscore, decreasing = TRUE), , drop = FALSE]
    namesOfFeature <- rownames(df_gini_index_score)
    selectedFeatures <- namesOfFeature[seq(1, number_features)]

    label_selectedFeatures <- c("Label", selectedFeatures)
    joint_df <- data_train[ , label_selectedFeatures]

  }
  else if (fs == 'MIM') { # Mutual information maximization (MIM)
    library(entropy)
    group <- data_train$Label
    mim_score <- lapply(data_train[,-1], function(x) { mi.empirical(discretize2d(x, as.numeric(group), numBins1=16, numBins2=16)) })
    mim_score_unlist <- unlist(mim_score, use.names=TRUE)
    df_mim_score <- data.frame(matrix(mim_score_unlist))
    rownames(df_mim_score) <- c(colnames(data_train[,-1]))
    colnames(df_mim_score) <- c("mimscore")
    df_mim_score <- df_mim_score[order(df_mim_score$mimscore, decreasing = TRUE), , drop = FALSE]
    namesOfFeature <- rownames(df_mim_score)
    selectedFeatures <- namesOfFeature[seq(1, number_features)]

    label_selectedFeatures <- c("Label", selectedFeatures)
    joint_df <- data_train[ , label_selectedFeatures]
  }
  else if (fs == 'mRMR') { # Minimum redundancy maximum relevance (MRMR)
    # MINIMUM REDUNDANCY MAXIMUM RELEVANCE
    library(mRMRe)
    df_asNumeric <- data_train_whc
    df_asNumeric$Label <- as.numeric(df_asNumeric$Label)
    dd <- mRMR.data(data = df_asNumeric)#[ , -c(LABEL_COL)]
    # For mRMR.classic-like results
    # Number of features MRMR
    num_features <-  number_features
    ensemble <- mRMR.ensemble(data = dd, target_indices = c(1), solution_count = 1, feature_count = num_features)
    causality(ensemble)
    cols_mrmr <- unlist(solutions(ensemble))
    df_filtered <- df_asNumeric[, c(cols_mrmr)]

    factorCol <- as.factor(data_train_whc[, LABEL_COL])
    joint_df <- cbind(data_train_whc[, LABEL_COL], df_filtered)
    colnames(joint_df) <- c('Label', colnames(df_filtered))
    #joint_df$Label <- as.factor(data_train_whc[, LABEL_COL])

  }
  else if (fs == 'JMI') { # Joint mutual information (JMI)
    library(praznik)
    group <- data_train_whc$Label
    df_jmi <- praznik::JMIM(data_train_whc[,-1], group, k =  number_features) #, threads = 0

    selectedFeaturesJMI <- names(df_jmi$score)

    label_selectedFeaturesJMI <- c("Label", selectedFeaturesJMI)
    joint_df <- data_train_whc[ , label_selectedFeaturesJMI]

  }
  return (list('df'=joint_df, 'fs_method'=fs, 'n_features'=number_features))
}

############################################################################
## https://johanndejong.wordpress.com/2018/04/04/nested-cross-validation/ ##
############################################################################

glm_train_and_validate <- function(data, data_withHighCorr, fold, n_feat, fs) {
  library(stats)
  library(PRROC)
  list_data_fs_fold_fs_nfeat <- selectFeaturesWithFSMethods(data_train = data[-fold,], data_train_whc = data_withHighCorr[-fold,], number_features = n_feat, fs=fs)
  data_fs_fold <- list_data_fs_fold_fs_nfeat$df
  fs_method <- list_data_fs_fold_fs_nfeat$fs_method
  n_features <- list_data_fs_fold_fs_nfeat$n_features
  #c(data_fs_fold, fs_method, n_features) := selectFeaturesWithFSMethods(data_train = data[-fold,], data_train_whc = data_withHighCorr[-fold,], number_features = n_feat, fs=fs)
  cols_fs <- colnames(data_fs_fold)
  # Train an SVM, excluding the fold
  fit <- stats::glm(Label ~ ., family = binomial(), data = data_fs_fold#,#data[-fold,],
              )
  # Predict the fold
  if (fs != 'mRMR' && fs != 'JMI') {
    yh <- predict(fit, newdata = data[fold,cols_fs], type = "response")#probabilities
    # Compare the predictions to the labels
    posneg <- split(yh, data$Label[fold])#posneg <- split(yh[1,], data$Label[fold])
  } else {
    yh <- predict(fit, newdata = data_withHighCorr[fold,cols_fs], type = "response")#probabilities
    # Compare the predictions to the labels
    posneg <- split(yh, data_withHighCorr$Label[fold])#posneg <- split(yh[1,], data$Label[fold])
  }
  # Return the AUC under the ROC
  PRROC::roc.curve(posneg[[1]], posneg[[2]])$auc
}

# Function for doing a k-fold cross-validation for each C in CC
cv_glm <- function( data, dataWHC, k, NumFeaturesList, FeatureSelectionList, seed = NULL) {
  # Set the seed, if given
  if (!is.null(seed)) {
    set.seed(seed)
  }

  list_NF_FS <- list(nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_NF_FS <- do.call(expand.grid, list_NF_FS)

  # For each value of the hyperparameter C ...
  auc <- mapply(function(n_feat,fs) {
    folds <- createFolds(data$Label, k = k)
    # For each fold ...

    sapply(folds, function(fold) {
      # Train an SVM, and validate on the fold
      glm_train_and_validate(data, dataWHC, fold, n_feat, fs)
    })
  }, n_feat=grid_search_NF_FS$nFS, fs=grid_search_NF_FS$FS)
  auc
}

ncv_glm <- function(data, dataWHC, k, NumFeaturesList, FeatureSelectionList, n_reps = 1, seed = 123) {
  if (!is.null(seed)) {
    set.seed(seed)
  }
  list_NF_FS <- list(nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_NF_FS <- do.call(expand.grid, list_NF_FS)

  folds <- createFolds(data$Label, k = k)
  # For each fold ...
  auc <- replicate(n_reps, {
    sapply(folds, function(fold) {
      # Do a cross-validation for each C
      auc <- cv_glm(data[-fold,], dataWHC[-fold,], k, NumFeaturesList, FeatureSelectionList, seed = seed)
      # Select the C with the highest AUC
      max_nFS <- grid_search_NF_FS$nFS[which.max(apply(auc, 2, mean))]
      max_FS <- grid_search_NF_FS$FS[which.max(apply(auc, 2, mean))]

      glm_train_and_validate(data, dataWHC, fold, max_nFS, max_FS)
    })
  })
  auc
}

lda_train_and_validate <- function(data, data_withHighCorr, fold, n_feat, fs) {
  library(MASS)
  library(PRROC)
  data_fs_fold <- selectFeaturesWithFSMethods(data_train = data[-fold,], data_train_whc = data_withHighCorr[-fold,], number_features = n_feat, fs=fs)
  cols_fs <- colnames(data_fs_fold$df)
  # Train an SVM, excluding the fold
  data_df <- data_fs_fold$df
  fit <- MASS::lda(Label ~ ., data = data_df)
  # Predict the fold
  if (fs != 'mRMR' && fs != 'JMI') {
    yh <- predict(fit, newdata = data[fold,cols_fs], type = "probabilities")
    # Compare the predictions to the labels
    posneg <- split(yh$posterior[,1], data$Label[fold])#posneg <- split(yh[1,], data$Label[fold])
  } else {
    yh <- predict(fit, newdata = data_withHighCorr[fold,cols_fs], type = "probabilities")#probabilities
    # Compare the predictions to the labels
    posneg <- split(yh$posterior[,1], data_withHighCorr$Label[fold])#posneg <- split(yh[1,], data$Label[fold])
  }
  # yh <- predict(fit, newdata = data[fold,cols_fs], type = "probabilities")# predict(fit, newdata = data[fold,cols_fs], type = "probabilities")
  # # Compare the predictions to the labels
  # posneg <- split(yh$posterior[,1], data$Label[fold])
  # Return the AUC under the ROC
  PRROC::roc.curve(posneg[[1]], posneg[[2]])$auc
}

# Function for doing a k-fold cross-validation for each C in CC
cv_lda <- function( data, dataWHC, k, NumFeaturesList, FeatureSelectionList, seed = NULL) {
  # Set the seed, if given
  if (!is.null(seed)) {
    set.seed(seed)
  }

  list_NF_FS <- list(nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_NF_FS <- do.call(expand.grid, list_NF_FS)

  # For each value of the hyperparameter C ...
  auc <- mapply(function(n_feat,fs) {
    folds <- createFolds(data$Label, k = k)
    # For each fold ...
    sapply(folds, function(fold) {
      # Train an SVM, and validate on the fold
      lda_train_and_validate(data, dataWHC, fold, n_feat, fs)
    })
  }, n_feat=grid_search_NF_FS$nFS, fs=grid_search_NF_FS$FS)
  auc
}

ncv_lda <- function(data, dataWHC, k, NumFeaturesList, FeatureSelectionList, n_reps = 1, seed = 123) {
  if (!is.null(seed)) {
    set.seed(seed)
  }
  list_NF_FS <- list(nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_NF_FS <- do.call(expand.grid, list_NF_FS)

  folds <- createFolds(data$Label, k = k)
  # For each fold ...
  auc <- replicate(n_reps, {
    sapply(folds, function(fold) {
    # Do a cross-validation for each C
    auc <- cv_lda(data[-fold,], dataWHC[-fold,], k, NumFeaturesList, FeatureSelectionList, seed = seed)
    # Select the C with the highest AUC
    max_nFS <- grid_search_NF_FS$nFS[which.max(apply(auc, 2, mean))]
    max_FS <- grid_search_NF_FS$FS[which.max(apply(auc, 2, mean))]

    lda_train_and_validate(data, dataWHC, fold, max_nFS, max_FS)
  })
  })
  auc
}

glmnet_train_and_validate <- function(data, data_withHighCorr, alpha, lambda, fold, n_feat, fs) {
  library(glmnet)
  library(PRROC)
  data_train_k_1_fold <- data[-fold,]
  data_train_whc_k_1_fold <- data_withHighCorr[-fold,]

  preprocessParams_k_1_fold <- caret::preProcess(data_train_k_1_fold, method=c("center", "scale"), na.remove=TRUE, verbose=FALSE);
  data_train_k_1_fold <- stats::predict(preprocessParams_k_1_fold, data_train_k_1_fold)

  preprocessParams_whc_k_1_fold <- caret::preProcess(data_train_whc_k_1_fold, method=c("center", "scale"), na.remove=TRUE, verbose=FALSE);
  data_train_whc_k_1_fold <- stats::predict(preprocessParams_whc_k_1_fold, data_train_whc_k_1_fold)

  data_fs_fold <- selectFeaturesWithFSMethods(data_train = data_train_k_1_fold, data_train_whc = data_train_whc_k_1_fold, number_features = n_feat, fs=fs)
  cols_fs <- colnames(data_fs_fold$df)
  data_df <- data_fs_fold$df
  # Train an SVM, excluding the fold
  fit <- glmnet::glmnet(as.matrix(data_df[,-c(1)]), as.matrix(data_df[,c(1)]), family=c("binomial"), alpha = alpha, lambda = lambda)
  # Predict the fold
  if (fs != 'mRMR' && fs != 'JMI') {
    data_nhc <- data[fold,]
    data_nhc <- stats::predict(preprocessParams_k_1_fold, data_nhc)
    data_pred <- data_nhc[,cols_fs]
    # data_pred <- stats::predict(preprocessParams_k_1_fold, data_pred)

    yh <- predict(fit, newx = as.matrix(data_pred[,-c(1)]), type = "response")
    # Compare the predictions to the labels
    posneg <- split(yh[,1], data$Label[fold])#posneg <- split(yh[1,], data$Label[fold])
  } else {
    data_whc <- data_withHighCorr[fold,]
    data_whc <- stats::predict(preprocessParams_whc_k_1_fold, data_whc)
    data_whc_pred <- data_whc[,cols_fs]
    #
    # data_whc_pred <- stats::predict(preprocessParams_whc_k_1_fold, data_whc_pred)
    #
    yh <- predict(fit, newx = as.matrix(data_whc_pred[,-c(1)]), type = "response")#probabilities
    # Compare the predictions to the labels
    posneg <- split(yh[,1], data_withHighCorr$Label[fold])#posneg <- split(yh[1,], data$Label[fold])
  }
  # Return the AUC under the ROC
  PRROC::roc.curve(posneg[[1]], posneg[[2]])$auc
}

# Function for doing a k-fold cross-validation for each C in CC
cv_glmnet <- function( data, dataWHC, k, AlphaList, LambdaList, NumFeaturesList, FeatureSelectionList, seed = NULL) {
  # Set the seed, if given
  if (!is.null(seed)) {
    set.seed(seed)
  }

  list_Alpha_Lambda_NF_FS <- list(alpha = AlphaList, lambda = LambdaList, nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_Alpha_Lambda_NF_FS <- do.call(expand.grid, list_Alpha_Lambda_NF_FS)

  # For each value of the hyperparameter C ...
  auc <- mapply(function(alpha, lambda, n_feat, fs) {
    folds <- createFolds(data$Label, k = k)
    print(paste0("alpha: ",alpha))
    print(paste0("lambda: ",lambda))
    print(paste0("n_feat: ",n_feat))
    print(paste0("fs: ",fs))
    # For each fold ...
    sapply(folds, function(fold) {
      # Train an GLMNET, and validate on the fold
      glmnet_train_and_validate(data, dataWHC, alpha, lambda, fold, n_feat, fs)
    })
  }, alpha=grid_search_Alpha_Lambda_NF_FS$alpha, lambda=grid_search_Alpha_Lambda_NF_FS$lambda, n_feat=grid_search_Alpha_Lambda_NF_FS$nFS, fs=grid_search_Alpha_Lambda_NF_FS$FS)
  auc
}

ncv_glmnet <- function(data, dataWHC, k, AlphaList, LambdaList, NumFeaturesList, FeatureSelectionList, n_reps = 1, seed = 123) {
  if (!is.null(seed)) {
    set.seed(seed)
  }
  list_HP_NF_FS <- list(alpha = AlphaList, lambda = LambdaList, nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_HP_NF_FS <- do.call(expand.grid, list_HP_NF_FS)

  folds <- createFolds(data$Label, k = k)
  # For each fold ...
  auc <- replicate(n_reps, {
    sapply(folds, function(fold) {
      # Do a cross-validation for each C
      auc <- cv_glmnet(data[-fold,], dataWHC[-fold,], k, AlphaList, LambdaList, NumFeaturesList, FeatureSelectionList, seed = seed)
      # Select the C with the highest AUC
      max_alpha <- grid_search_HP_NF_FS$alpha[which.max(apply(auc, 2, mean))]
      max_lambda <- grid_search_HP_NF_FS$lambda[which.max(apply(auc, 2, mean))]
      max_nFS <- grid_search_HP_NF_FS$nFS[which.max(apply(auc, 2, mean))]
      max_FS <- grid_search_HP_NF_FS$FS[which.max(apply(auc, 2, mean))]

      glmnet_train_and_validate(data, dataWHC, max_alpha, max_lambda, fold, max_nFS, max_FS)
    })
  })
  auc
}

# KNN
# fit.knn <- caret::train(frm, data=joint_df, method="knn", metric=metric, trControl=control)
# knn(train, test, cl, k = 1, l = 0, prob = tru, use.all = TRUE)
knn_train_and_validate <- function(data, data_withHighCorr, k_knn, fold, n_feat, fs) {
  library(glmnet)
  library(PRROC)
  data_fs_fold <- selectFeaturesWithFSMethods(data_train = data[-fold,], data_train_whc = data_withHighCorr[-fold,], number_features = n_feat, fs=fs)
  cols_fs <- colnames(data_fs_fold$df)
  data_df <- data_fs_fold$df
  # Train an SVM, excluding the fold
  # fit <- class::knn(data_df[,-c(1)], data[fold,cols_fs], cl=data[-fold,]$Label, k_knn, prob = TRUE)
  # data_test <- data[fold,cols_fs]
  if (fs != 'mRMR' && fs != 'JMI') {
    data_test <- data[fold,cols_fs]
  } else {
    data_test <- data_withHighCorr[fold,cols_fs]
  }
  fit <- class::knn(data_df[,-c(1)], data_test[,-c(1)], cl=data_df[,c(1)], k_knn, prob = TRUE)
  # Predict the fold
  # yh <- predict(fit, newdata = data[fold,cols_fs], type = "probabilities")
  #yh <- predict(fit, newdata = data_test[,-c(1)], type = "probabilities")
  prob <- attr(fit, "prob")
  posneg <- split(prob, data$Label[fold])
  # Compare the predictions to the labels
  # posneg <- split(yh[,1], data$Label[fold])
  # Return the AUC under the ROC
  PRROC::roc.curve(posneg[[1]], posneg[[2]])$auc
}

# Function for doing a k-fold cross-validation for each C in CC
cv_knn <- function( data, dataWHC, k, KList, NumFeaturesList, FeatureSelectionList, seed = NULL) {
  # Set the seed, if given
  if (!is.null(seed)) {
    set.seed(seed)
  }

  list_K_NF_FS <- list(k_knn = KList, nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_K_NF_FS <- do.call(expand.grid, list_K_NF_FS)

  # For each value of the hyperparameter C ...
  auc <- mapply(function(k_knn, n_feat,fs) {
    folds <- createFolds(data$Label, k = k)
    # For each fold ...
    sapply(folds, function(fold) {
      # Train an GLMNET, and validate on the fold
      knn_train_and_validate(data, dataWHC, k_knn, fold, n_feat, fs)
    })
  }, k_knn=grid_search_K_NF_FS$k_knn, n_feat=grid_search_K_NF_FS$nFS, fs=grid_search_K_NF_FS$FS)
  auc
}

ncv_knn <- function(data, dataWHC, k, KList, NumFeaturesList, FeatureSelectionList, n_reps = 1, seed = 123) {
  if (!is.null(seed)) {
    set.seed(seed)
  }
  list_HP_NF_FS <- list(k_knn = KList, nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_HP_NF_FS <- do.call(expand.grid, list_HP_NF_FS)

  folds <- createFolds(data$Label, k = k)
  # For each fold ...
  auc <- replicate(n_reps, {
    sapply(folds, function(fold) {
    # Do a cross-validation for each C
    auc <- cv_knn(data[-fold,], dataWHC[-fold,], k, KList, NumFeaturesList, FeatureSelectionList, seed = seed)
    # Select the C with the highest AUC
    max_k <- grid_search_HP_NF_FS$k_knn[which.max(apply(auc, 2, mean))]
    max_nFS <- grid_search_HP_NF_FS$nFS[which.max(apply(auc, 2, mean))]
    max_FS <- grid_search_HP_NF_FS$FS[which.max(apply(auc, 2, mean))]

    knn_train_and_validate(data, dataWHC, max_k, fold, max_nFS, max_FS)
  })
  })
  auc
}

# Naive Bayes
# fit.nb <- caret::train(frm, data=joint_df, method="nb", metric=metric, trControl=control)
nb_train_and_validate <- function(data, data_withHighCorr, fold, n_feat, fs) {
  library(e1071)
  library(PRROC)
  data_fs_fold <- selectFeaturesWithFSMethods(data_train = data[-fold,], data_train_whc = data_withHighCorr[-fold,], number_features = n_feat, fs=fs)
  cols_fs <- colnames(data_fs_fold$df)
  data_df <- data_fs_fold$df
  # Train an SVM, excluding the fold
  data_df$Label <- factor(data_df$Label)
  fit <- e1071::naiveBayes(Label~., data=data_df) #knn(data_fs_fold, data[fold,cols_fs], cl=data_fs_fold$Label, k_knn, prob = TRUE)
  # Predict the fold
  if (fs != 'mRMR' && fs != 'JMI') {
    data$Label
    yh <- predict(fit, newdata = data[fold,cols_fs], type = "raw")
    # Compare the predictions to the labels
    posneg <- split(yh[,1], data$Label[fold])#posneg <- split(yh[1,], data$Label[fold])
  } else {
    yh <- predict(fit, newdata = data_withHighCorr[fold,cols_fs], type = "raw")#probabilities
    # Compare the predictions to the labels
    posneg <- split(yh[,1], data_withHighCorr$Label[fold])#posneg <- split(yh[1,], data$Label[fold])
  }
  # yh <- predict(fit, newdata = data[fold,cols_fs], type = "probabilities")
  # # Compare the predictions to the labels
  # posneg <- split(yh[,1], data$Label[fold])
  # Return the AUC under the ROC
  PRROC::roc.curve(posneg[[1]], posneg[[2]])$auc
}

# Function for doing a k-fold cross-validation for each C in CC
cv_nb <- function( data, dataWHC, k, NumFeaturesList, FeatureSelectionList, seed = NULL) {
  # Set the seed, if given
  if (!is.null(seed)) {
    set.seed(seed)
  }

  list_NF_FS <- list(nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_NF_FS <- do.call(expand.grid, list_NF_FS)

  # For each value of the hyperparameter C ...
  auc <- mapply(function(n_feat,fs) {
    folds <- createFolds(data$Label, k = k)
    # For each fold ...
    sapply(folds, function(fold) {
      # Train an GLMNET, and validate on the fold
      nb_train_and_validate(data, dataWHC, fold, n_feat, fs)
    })
  }, n_feat=grid_search_NF_FS$nFS, fs=grid_search_NF_FS$FS)
  auc
}

ncv_nb <- function(data, dataWHC, k, NumFeaturesList, FeatureSelectionList, n_reps = 1, seed = 123) {
  if (!is.null(seed)) {
    set.seed(seed)
  }
  list_NF_FS <- list(nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_NF_FS <- do.call(expand.grid, list_NF_FS)

  folds <- createFolds(data$Label, k = k)
  # For each fold ...
  auc <- replicate(n_reps, {
    sapply(folds, function(fold) {
      # Do a cross-validation for each C
      auc <- cv_nb(data[-fold,], dataWHC[-fold,], k, NumFeaturesList, FeatureSelectionList, seed = seed)
      # Select the C with the highest AUC
      max_nFS <- grid_search_NF_FS$nFS[which.max(apply(auc, 2, mean))]
      max_FS <- grid_search_NF_FS$FS[which.max(apply(auc, 2, mean))]

      nb_train_and_validate(data, dataWHC, fold, max_nFS, max_FS)
    })
  })
  auc
}

# Function for one round of training and validating an SVM
ksvm_train_and_validate <- function(data, data_withHighCorr, fold, C, sigma, n_feat, fs) {
  library(kernlab)
  data_fs_fold <- selectFeaturesWithFSMethods(data_train = data[-fold,], data_train_whc = data_withHighCorr[-fold,], number_features = n_feat, fs=fs)
  cols_fs <- colnames(data_fs_fold)
  # Train an SVM, excluding the fold
  fit <- kernlab::ksvm(Label ~ ., data = data_fs_fold,#data[-fold,],
                       kernel = "rbfdot", kpar = list(sigma=sigma), C = C, prob.model = TRUE, Label.weights = 1 / table(data$Label[-fold]))
  # Predict the fold
  yh <- predict(fit, newdata = data[fold,cols_fs], type = "probabilities")
  # Compare the predictions to the labels
  posneg <- split(yh[,1], data$Label[fold])
  # Return the AUC under the ROC
  PRROC::roc.curve(posneg[[1]], posneg[[2]])$auc
}

# Function for doing a k-fold cross-validation for each C in CC
cv_ksvm <- function( data, dataWHC, k, CC, SigmaList, NumFeaturesList, FeatureSelectionList, seed = NULL) {
  # Set the seed, if given
  if (!is.null(seed)) {
    set.seed(seed)
  }

  list_HP_NF_FS <- list(hpC = CC, hpS = SigmaList, nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_HP_NF_FS <- do.call(expand.grid, list_HP_NF_FS)

  # For each value of the hyperparameter C ...
  auc <- mapply(function(C, sigma,n_feat,fs) {
    folds <- createFolds(data$Label, k = k)
    # For each fold ...
    sapply(folds, function(fold) {
      # Train an SVM, and validate on the fold
      ksm_train_and_validate(data, dataWHC, fold, C, sigma, n_feat, fs)
    })
  }, C=grid_search_HP_NF_FS$hpC, sigma=grid_search_HP_NF_FS$hpS, n_feat=grid_search_HP_NF_FS$nFS, fs=grid_search_HP_NF_FS$FS)

  auc
}

ncv_svm <- function(data, dataWHC, k, CC, SigmaList, NumFeaturesList, FeatureSelectionList, n_reps = 1, seed = 123) {
  if (!is.null(seed)) {
    set.seed(seed)
  }
  list_HP_NF_FS <- list(hpC = CC, hpS = SigmaList, nFS = NumFeaturesList, FS = FeatureSelectionList)
  grid_search_HP_NF_FS <- do.call(expand.grid, list_HP_NF_FS)
  folds <- createFolds(data$Label, k = k)
  # For each fold ...
  auc <- replicate(n_reps, {
    sapply(folds, function(fold) {
      # Do a cross-validation for each C
      auc <- cv_ksvm(data[-fold,], dataWHC[-fold,], k, CC, SigmaList, NumFeaturesList, FeatureSelectionList, seed = seed)
      # Select the C with the highest AUC
      indx_max_C <- grid_search_HP_NF_FS$hpC
      indx_max_S <- grid_search_HP_NF_FS$hpS
      indx_max_nFS <- grid_search_HP_NF_FS$nFS
      indx_max_FS <- grid_search_HP_NF_FS$FS

      index_max_overall <- Reduce(intersect, list(indx_max_C, indx_max_S, indx_max_nFS, indx_max_FS))

      C <- grid_search_HP_NF_FS$hpC[index_max_overall]
      sigma <- grid_search_HP_NF_FS$hpS[index_max_overall]
      n_feat <- grid_search_HP_NF_FS$nFS[index_max_overall]
      fs <- grid_search_HP_NF_FS$FS[index_max_overall]
      # C <- CC[which.max(sapply(auc, mean))]
      # sigma <- SigmaList[which.max(sapply(auc, mean))]
      # n_feat <- NumFeaturesList[which.max(sapply(auc, mean))]
      # fs <- FeatureSelectionList[which.max(sapply(auc, mean))]
      # C  1, sample(C, 1), C)
      # Test this C on the test data
      ksvm_train_and_validate(data, dataWHC, fold, C, sigma, n_feat, fs)
    })
  })
  auc
}

results.model.cv <- function(model, roc_cv, ci_cv) {
  fold_indx_cv <- as.numeric(rownames(model$bestTune))

  auc_cv <- model$results$AUC[fold_indx_cv]
  kappa_cv <- model$results$Kappa[fold_indx_cv]
  acc_cv <- model$results$Accuracy[fold_indx_cv]

  auc_cv_SD <- model$results$AUCSD[fold_indx_cv]
  kappa_cv_SD <- model$results$KappaSD[fold_indx_cv]
  acc_cv_SD <- model$results$AccuracySD[fold_indx_cv]

  if (length(model$results$F1) != 0) {
    f1_cv <- model$results$F1[fold_indx_cv]
    sens_cv <- model$results$Sensitivity[fold_indx_cv]
    spec_cv <- model$results$Specificity[fold_indx_cv]
    ppv_cv <- model$results$Pos_Pred_Value[fold_indx_cv]
    npv_cv <- model$results$Neg_Pred_Value[fold_indx_cv]

    f1_cv_SD <- model$results$F1SD[fold_indx_cv]
    sens_cv_SD <- model$results$SensitivitySD[fold_indx_cv]
    spec_cv_SD <- model$results$SpecificitySD[fold_indx_cv]
    ppv_cv_SD <- model$results$Pos_Pred_ValueSD[fold_indx_cv]
    npv_cv_SD <- model$results$Neg_Pred_ValueSD[fold_indx_cv]
  } else {
    f1_cv <- model$results$Mean_F1[fold_indx_cv]
    sens_cv <- model$results$Mean_Sensitivity[fold_indx_cv]
    spec_cv <- model$results$Mean_Specificity[fold_indx_cv]
    ppv_cv <- model$results$Mean_Pos_Pred_Value[fold_indx_cv]
    npv_cv <- model$results$Mean_Neg_Pred_Value[fold_indx_cv]

    f1_cv_SD <- model$results$Mean_F1SD[fold_indx_cv]
    sens_cv_SD <- model$results$Mean_SensitivitySD[fold_indx_cv]
    spec_cv_SD <- model$results$Mean_SpecificitySD[fold_indx_cv]
    ppv_cv_SD <- model$results$Mean_Pos_Pred_ValueSD[fold_indx_cv]
    npv_cv_SD <- model$results$Mean_Neg_Pred_ValueSD[fold_indx_cv]
  }

  cv_results <- matrix(nrow = 8, ncol = 3, dimnames = list(c('AUC', 'Kappa', 'F1', 'Acc', 'Sens', 'Spec', 'PPV', 'NPV'), c('Mean', '95CI_Left', '95CI_Right')))
  error_auc_cv <- qnorm(0.975)*auc_cv_SD/sqrt(nrow(dataset)/3); left_auc_cv <- auc_cv-error_auc_cv; right_auc_cv <- auc_cv+error_auc_cv
  error_kappa_cv <- qnorm(0.975)*kappa_cv_SD/sqrt(nrow(dataset)/3); left_kappa_cv <- kappa_cv-error_kappa_cv; right_kappa_cv <- kappa_cv+error_kappa_cv
  error_f1_cv <- qnorm(0.975)*f1_cv_SD/sqrt(nrow(dataset)/3); left_f1_cv <- f1_cv-error_f1_cv; right_f1_cv <- f1_cv+error_f1_cv
  error_acc_cv <- qnorm(0.975)*acc_cv_SD/sqrt(nrow(dataset)/3); left_acc_cv <- acc_cv-error_acc_cv; right_acc_cv <- acc_cv+error_acc_cv
  error_sens_cv <- qnorm(0.975)*sens_cv_SD/sqrt(nrow(dataset)/3); left_sens_cv <- sens_cv-error_sens_cv; right_sens_cv <- sens_cv+error_sens_cv
  error_spec_cv <- qnorm(0.975)*spec_cv_SD/sqrt(nrow(dataset)/3); left_spec_cv <- spec_cv-error_spec_cv; right_spec_cv <- spec_cv+error_spec_cv
  error_ppv_cv <- qnorm(0.975)*ppv_cv_SD/sqrt(nrow(dataset)/3); left_ppv_cv <- ppv_cv-error_ppv_cv; right_ppv_cv <- ppv_cv+error_ppv_cv
  error_npv_cv <- qnorm(0.975)*npv_cv_SD/sqrt(nrow(dataset)/3); left_npv_cv <- npv_cv-error_npv_cv; right_npv_cv <- npv_cv+error_npv_cv

  # cv_results[1,]<-c(roc_cv$auc, ci_cv[1], ci_cv[3])
  cv_results[1,]<-c(auc_cv, left_auc_cv, right_auc_cv)
  cv_results[2,]<-c(kappa_cv, left_kappa_cv, right_kappa_cv)
  # if (length(c(f1_cv, left_f1_cv, right_f1_cv))!=0) {
  #   cv_results[3,]<-c(f1_cv, left_f1_cv, right_f1_cv)
  # }
  cv_results[3,]<-c(f1_cv, left_f1_cv, right_f1_cv)
  cv_results[4,]<-c(acc_cv, left_acc_cv, right_acc_cv)
  cv_results[5,]<-c(sens_cv, left_sens_cv, right_sens_cv)
  cv_results[6,]<-c(spec_cv, left_spec_cv, right_spec_cv)
  cv_results[7,]<-c(ppv_cv, left_ppv_cv, right_ppv_cv)
  cv_results[8,]<-c(npv_cv, left_npv_cv, right_npv_cv)

  return (cv_results)
}

multiClassSummaryOwn <- function(data, lev = NULL, model = NULL){
  #Check data
  if (!all(levels(data[, "pred"]) == levels(data[, "obs"])))
    stop("levels of observed and predicted data do not match")

  has_class_probs <- all(lev %in% colnames(data))

  if(has_class_probs) {
    ## Overall multinomial loss
    lloss <- mnLogLoss(data = data, lev = lev, model = model)

    caret::: requireNamespaceQuietStop("ModelMetrics")
    caret::: requireNamespaceQuietStop("MLmetrics")

    #Calculate custom one-vs-all ROC curves for each class
    prob_stats <-
      lapply(levels(data[, "pred"]),
             function(x){
               #Grab one-vs-all data for the class
               obs  <- ifelse(data[,"obs"] == x, 1, 0)
               prob <- data[,x]
               roc_auc <- try(ModelMetrics::auc(obs, data[,x]), silent = TRUE)
               # browser()
               pr_auc <- try(MLmetrics::PRAUC(y_pred = data[,x],
                                              y_true = obs),
                             silent = TRUE)
               if(inherits(pr_auc, "try-error"))
                 pr_auc <- NA
               res <- c(ROC = roc_auc, AUC = pr_auc)
               return(res)
             })
    prob_stats <- do.call("rbind", prob_stats)
    prob_stats <- colMeans(prob_stats, na.rm = TRUE)
  }

  #Calculate confusion matrix-based statistics
  CM <- confusionMatrix(data[, "pred"], data[, "obs"],
                        mode = "everything", positive = positive_class)
  print(positive_class)

  #Aggregate and average class-wise stats
  #Todo: add weights
  # RES: support two classes here as well
  if (length(levels(data[, "pred"])) == 2) {
    class_stats <- CM$byClass
  } else {
    class_stats <- colMeans(CM$byClass)
    names(class_stats) <- paste("Mean", names(class_stats))
  }

  # Aggregate overall stats
  overall_stats <-
    if (has_class_probs)
      c(CM$overall,
        logLoss = as.numeric(lloss),
        AUC = unname(prob_stats["ROC"]),
        prAUC = unname(prob_stats["AUC"]))
  else
    CM$overall

  # Combine overall with class-wise stats and remove some stats we don't want
  stats <- c(overall_stats, class_stats)
  stats <- stats[! names(stats) %in% c('AccuracyNull', "AccuracyLower", "AccuracyUpper",
                                       "AccuracyPValue", "McnemarPValue",
                                       'Mean Prevalence', 'Mean Detection Prevalence')]

  # Clean names
  names(stats) <- gsub('[[:blank:]]+', '_', names(stats))

  # Change name ordering to place most useful first
  # May want to remove some of these eventually
  stat_list <- c("Accuracy", "Kappa", "Mean_F1",
                 "Mean_Sensitivity", "Mean_Specificity",
                 "Mean_Pos_Pred_Value", "Mean_Neg_Pred_Value",
                 "Mean_Precision", "Mean_Recall",
                 "Mean_Detection_Rate",
                 "Mean_Balanced_Accuracy")
  if(has_class_probs) stat_list <- c("logLoss", "AUC", "prAUC", stat_list)
  if (length(levels(data[, "pred"])) == 2) stat_list <- gsub("^Mean_", "", stat_list)

  stats <- stats[c(stat_list)]

  return(stats)
}


library(tidyverse)
library(BBmisc)
library(caTools)

simulate_viral_load <- function(ids, ct_alpha, ct_beta, ct_max, ct_min, e_alpha, e_beta, e_max, e_min, rct, gamma_shape=2, gamma_scale=2)
{
	n <- nrow(ids)
	ct <- rbeta(n, ct_alpha, ct_beta) * (ct_max - ct_min) + ct_min
	e <- rbeta(n, e_alpha, e_beta) * (e_max-e_min) + e_min
	vl <- rct / (1+e)^ct
	ids$id_E <- e
	ids$id_ct <- ct
	ids$id_vl <- vl

	vlshape <- tibble(
		t=seq(0,21,length.out=2101),
		vlshape=dgamma(t, shape=gamma_shape, scale=gamma_scale)
	)
	vlshape$vlshape <- vlshape$vlshape / max(vlshape$vlshape)
	len <- nrow(subset(vlshape, t <= 1))
	i1 <- sample(1:(which(vlshape$t == 18)[1]), n, replace=TRUE)
	i2 <- i1 + len * 3
	max_vl <- rct / (1 + e)^ct

	vl1 <- max_vl * vlshape$vlshape[i1]
	vl2 <- max_vl * vlshape$vlshape[i2]

	ct1 <- log(rct/vl1) / log(1+e)
	ct2 <- log(rct/vl2) / log(1+e)

	ids$id_ct1 <- ct1
	ids$id_ct2 <- ct2
	ids$id_vl1 <- vl1
	ids$id_vl2 <- vl2
	return(ids)
}

simulate_infection <- function(ids, prevalence, spread, containment)
{
	# Sample initial individuals
	dat <- tibble(
		id = sample(ids$id, nrow(ids) * prevalence, replace=FALSE),
		spread = rpois(length(id), spread)
		) %>%
		inner_join(ids, ., by="id")

	new_infecteds <- lapply(1:nrow(dat), function(i)
	{
		loc <- sample(1:3, dat$spread[i], replace=TRUE, prob=containment)
		return(c(
			sample(subset(ids, circle == dat$circle[i])$id, min(dat$count[i], sum(loc==1)), replace=FALSE),
			sample(subset(ids, location == dat$location[i])$id, sum(loc==2), replace=FALSE),
			sample(ids$id, sum(loc==3), replace=FALSE)
		))
	}) %>% unlist %>% unique
	ids$infected <- ids$id %in% c(dat$id, new_infecteds)
	ids <- ids %>%
		group_by(location) %>%
		mutate(location_outbreak = sum(infected >= 2)) %>%
		ungroup()

	# remove vl for anyone not infected
	ids$id_vl[ids$infected==FALSE] <- 0
	ids$id_vl1[ids$infected==FALSE] <- 0
	ids$id_vl2[ids$infected==FALSE] <- 0
	# ids$cvl[ids$infected==FALSE] <- 0

	return(ids)
}

allocate_pools <- function(ids, pool_size, random=FALSE)
{
	random_pools <- function(x, pool_size)
	{
		npool <- ceiling(length(x) / pool_size)
		rep(1:npool, each=pool_size)[1:length(x)] %>% sample
	}

	if(random)
	{
		ids$assay_pool <- random_pools(1:nrow(ids), pool_size)
		ids <- ids %>%
			group_by(assay_pool) %>%
			mutate(poolsize=n()) %>%
			ungroup()
		return(ids)
	}

	# First break up large circles
	temp1 <- subset(ids, count > pool_size) %>%
		group_by(circle) %>%
		mutate(
			poolbreak = cut(1:n(), ceiling(n()/pool_size)) %>% as.numeric(),
			pool = paste0(circle, "-", poolbreak)
		) %>% ungroup()
	temp2 <- subset(ids, count <= pool_size) %>%
		mutate(
			poolbreak = 1,
			pool = paste0(circle, "-", poolbreak)
		)
	ids <- bind_rows(temp1, temp2)
	dat <- ids %>%
		group_by(pool) %>%
		summarise(poolsize=n(), .groups="drop")
	# Note that `cut` tries to make even cuts. this might not be optimal
	# Use bin packing algorithm to assign to pools
	dat$assay_pool <- BBmisc::binPack(dat$poolsize, pool_size)
	ids <- inner_join(ids, dat, by="pool") %>%
		group_by(assay_pool) %>%
		mutate(poolsize = n()) %>% ungroup()
	return(ids)
}

assay_sensitivity_quad <- function(dilution, baseline, beta)
{
	vec <- -beta * (dilution-1)^2 + baseline
	vec[vec < 0] <- 0
	vec
}

assay_sensitivity_decay <- function(dilution, baseline, beta)
{
	exp(-(dilution-1) * beta) * baseline
}

assay_sensitivity_sigmoid <- function(dilution)
{
	1 / (1 + exp(-dilution/4+4)) * -1 + 1
}

assay_ppv <- function(sensitivity, prevalence, specificity)
{
	sensitivity * prevalence / (sensitivity * prevalence + (1-specificity) * (1-prevalence))
}

lfd_prob <- function(x, asym, xmid, scal)
{
	asym / (1 + exp((xmid - x)/scal))
}

simulate_testing <- function(ids, ctthresh, rct, pcr_fp, lfd_Asym, lfd_xmid, lfd_scal, lfd_fp)
{
	ids$id_detected <- ids$id_ct < ctthresh
	ids$id_detected1 <- ids$id_ct1 < ctthresh
	ids$id_detected2 <- ids$id_ct2 < ctthresh
	ids$id_detected[!ids$infected] <- rbinom(sum(!ids$infected), 1, pcr_fp)
	ids$id_detected1[!ids$infected] <- rbinom(sum(!ids$infected), 1, pcr_fp)
	ids$id_detected2[!ids$infected] <- rbinom(sum(!ids$infected), 1, pcr_fp)
	ids$id_lfd_detected <- rbinom(nrow(ids), 1, lfd_prob(ids$id_ct, lfd_Asym, lfd_xmid, lfd_scal))
	ids$id_lfd_detected1 <- rbinom(nrow(ids), 1, lfd_prob(ids$id_ct1, lfd_Asym, lfd_xmid, lfd_scal))
	ids$id_lfd_detected2 <- rbinom(nrow(ids), 1, lfd_prob(ids$id_ct2, lfd_Asym, lfd_xmid, lfd_scal))
	ids$id_lfd_detected[!ids$infected] <- rbinom(sum(!ids$infected), 1, lfd_fp)
	ids$id_lfd_detected1[!ids$infected] <- rbinom(sum(!ids$infected), 1, lfd_fp)
	ids$id_lfd_detected2[!ids$infected] <- rbinom(sum(!ids$infected), 1, lfd_fp)

	detected_pools <- ids %>% group_by(assay_pool) %>%
		summarise(
			pool_ninfected = sum(infected),
			pool_infected = pool_ninfected > 0,
			pool_E = min(id_E),
			pool_vl = sum(id_vl),
			pool_vl1 = sum(id_vl1),
			pool_vl2 = sum(id_vl2),
			pool_Rn = pool_vl / n() * (1 + pool_E)^ctthresh,
			pool_Rn1 = pool_vl1 / n() * (1 + pool_E)^ctthresh,
			pool_Rn2 = pool_vl2 / n() * (1 + pool_E)^ctthresh,
			pool_ct = log(rct / pool_vl) / log((1 + pool_E)),
			pool_ct1 = log(rct / pool_vl1) / log((1 + pool_E)),
			pool_ct2 = log(rct / pool_vl2) / log((1 + pool_E)),
			pool_detected = pool_ct < ctthresh,
			pool_detected1 = pool_ct1 < ctthresh,
			pool_detected2 = pool_ct2 < ctthresh,
			.groups="drop"
		)
	detected_pools$pool_detected[!detected_pools$pool_infected] <- rbinom(sum(!detected_pools$pool_infected), 1, pcr_fp)
	detected_pools$pool_detected1[!detected_pools$pool_infected] <- rbinom(sum(!detected_pools$pool_infected), 1, pcr_fp)
	detected_pools$pool_detected2[!detected_pools$pool_infected] <- rbinom(sum(!detected_pools$pool_infected), 1, pcr_fp)
	ids <- inner_join(ids, detected_pools, by="assay_pool")
	ids <- ids %>% group_by(circle) %>%
		mutate(
			circle_detected = any(pool_detected),
			circle_detected1 = any(pool_detected1),
			circle_detected2 = any(pool_detected2)
		)
	ids <- ids %>%
		group_by(location) %>%
		mutate(
			ind_outbreak_detected = sum(id_detected) > 2,
			pool_outbreak_detected = sum(pool_detected) > 2,
			poolfollowup_outbreak_detected = sum(pool_detected * id_detected) > 2
		) %>% ungroup()
	return(ids)
}

summarise_simulations <- function(ids, cost_samplingkit, cost_test, cost_lfd)
{
	npool <- length(unique(ids$assay_pool))
	nfollowup <- sum(ids$pool_detected)

	ob <- group_by(ids, location) %>%
		summarise(
			outbreak = any(location_outbreak),
			ind_outbreak_detected = any(ind_outbreak_detected),
			pool_outbreak_detected = any(pool_outbreak_detected),
			poolfollowup_outbreak_detected = any(poolfollowup_outbreak_detected),
			.groups="drop"
		)

	tibble(
		nstudents = nrow(ids),
		true_prevalence = sum(ids$infected) / nrow(ids),
		prevalence.ind_tests = sum(ids$id_detected) / nstudents,
		prevalence.ind_tests1 = sum(ids$id_detected1) / nstudents,
		prevalence.ind_tests2 = sum(ids$id_detected2) / nstudents,
		prevalence.pool_tests = sum(ids$pool_detected) / nstudents,
		prevalence.pool_tests1 = sum(ids$pool_detected1) / nstudents,
		prevalence.pool_tests2 = sum(ids$pool_detected2) / nstudents,
		prevalence.poolfollowup_tests = sum(ids$pool_detected & ids$id_detected) / nstudents,
		prevalence.poolfollowup_tests1 = sum(ids$pool_detected1 & ids$id_detected1) / nstudents,
		prevalence.poolfollowup_tests2 = sum(ids$pool_detected2 & ids$id_detected2) / nstudents,

		cost.ind_tests = nrow(ids) * cost_samplingkit + nrow(ids) * cost_test,
		cost.pool_tests = nrow(ids) * cost_samplingkit + npool * cost_test,
		cost.poolfollowup_tests = cost.pool_tests + nfollowup * cost_test,
		cost.lfd = nrow(ids) * cost_lfd,

		reagentuse.ind_tests = nrow(ids),
		reagentuse.pool_tests = npool,
		reagentuse.poolfollowup_tests = npool + nfollowup,

		sensitivity.ind_tests = sum(ids$infected & ids$id_detected) / sum(ids$infected),
		sensitivity.ind_tests1 = sum(ids$infected & ids$id_detected1) / sum(ids$infected),
		sensitivity.ind_tests2 = sum(ids$infected & ids$id_detected2) / sum(ids$infected),
		sensitivity.pool_tests = sum(ids$pool_detected * ids$infected) / sum(ids$infected),
		sensitivity.pool_tests1 = sum(ids$pool_detected1 * ids$infected) / sum(ids$infected),
		sensitivity.pool_tests2 = sum(ids$pool_detected2 * ids$infected) / sum(ids$infected),
		sensitivity.poolfollowup_tests = sum(ids$pool_detected * ids$infected * ids$id_detected) / sum(ids$infected),
		sensitivity.poolfollowup_tests1 = sum(ids$pool_detected1 * ids$infected * ids$id_detected1) / sum(ids$infected),
		sensitivity.poolfollowup_tests2 = sum(ids$pool_detected2 * ids$infected * ids$id_detected2) / sum(ids$infected),
		sensitivity.lfd = sum(ids$infected & ids$id_lfd_detected) / sum(ids$infected),
		sensitivity.lfd1 = sum(ids$infected & ids$id_lfd_detected1) / sum(ids$infected),
		sensitivity.lfd2 = sum(ids$infected & ids$id_lfd_detected2) / sum(ids$infected),
		sensitivity.lfd_ever = sum(ids$infected & (ids$id_lfd_detected1 | ids$id_lfd_detected2)) / sum(ids$infected),

		specificity.ind_tests = sum(!ids$id_detected & !ids$infected) / sum(!ids$infected),
		specificity.ind_tests1 = sum(!ids$id_detected1 & !ids$infected) / sum(!ids$infected),
		specificity.ind_tests2 = sum(!ids$id_detected2 & !ids$infected) / sum(!ids$infected),
		specificity.pool_tests = sum(!ids$pool_detected & !ids$infected) / sum(!ids$infected),
		specificity.pool_tests1 = sum(!ids$pool_detected1 & !ids$infected) / sum(!ids$infected),
		specificity.pool_tests2 = sum(!ids$pool_detected2 & !ids$infected) / sum(!ids$infected),
		specificity.poolfollowup_tests = 1 - sum(ids$pool_detected & ids$id_detected & !ids$infected) / sum(!ids$infected),
		specificity.poolfollowup_tests1 = 1 - sum(ids$pool_detected1 & ids$id_detected1 & !ids$infected) / sum(!ids$infected),
		specificity.poolfollowup_tests2 = 1 - sum(ids$pool_detected2 & ids$id_detected2 & !ids$infected) / sum(!ids$infected),
		specificity.lfd = sum(!ids$id_lfd_detected & !ids$infected) / sum(!ids$infected),
		specificity.lfd1 = sum(!ids$id_lfd_detected1 & !ids$infected) / sum(!ids$infected),
		specificity.lfd2 = sum(!ids$id_lfd_detected2 & !ids$infected) / sum(!ids$infected),
		specificity.lfd_ever = sum(!(ids$id_lfd_detected1 | ids$id_lfd_detected2) & !ids$infected) / sum(!ids$infected),

		sensitivity.outbreak.ind_tests = sum(ob$ind_outbreak_detected) / sum(ob$outbreak),
		sensitivity.outbreak.pool_outbreak_detected = sum(ob$pool_outbreak_detected) / sum(ob$outbreak),
		sensitivity.outbreak.poolfollowup_outbreak_detected = sum(ob$poolfollowup_outbreak_detected) / sum(ob$outbreak),

		specificity.outbreak.ind_tests = sum(!ob$ind_outbreak_detected & !ob$outbreak) / sum(!ob$outbreak),
		specificity.outbreak.pool_outbreak_detected = sum(!ob$pool_outbreak_detected & !ob$outbreak) / sum(!ob$outbreak),
		specificity.outbreak.poolfollowup_outbreak_detected = sum(!ob$poolfollowup_outbreak_detected & !ob$outbreak) / sum(!ob$outbreak)
	)
}

run_simulation <- function(ids, param, containment)
{
	stopifnot(nrow(param) == 1)
	stopifnot(param$containment %in% names(containment))
	cont <- containment[[param$containment]]

	ids <- simulate_viral_load(ids, param$ct_alpha, param$ct_beta, param$ct_max, param$ct_min, param$e_alpha, param$e_beta, param$e_max, param$e_min, param$rct)
	ids <- simulate_infection(ids, param$prevalence, spread=param$spread, cont)
	ids <- allocate_pools(ids, param$pool_size, random=param$random_pooling)
	ids <- simulate_testing(ids, param$ctthresh, param$rct, param$pcr_fp, param$lfd_Asym, param$lfd_xmid, param$lfd_scal, param$lfd_fp)
	res <- summarise_simulations(ids, param$cost_samplingkit, param$cost_test, param$lfd_cost)
	return(bind_cols(param, res))
}


#!/usr/bin/env Rscript

library(quanteda)
library(tidyr)
library(topicmodels)
library(tidytext)
library(dplyr)
library(stringr)
library(LDAvis)
library(servr)

load("~/DigEc/stories_dtm.RData")

ap_lda = LDA(stories_dtm,
             k=10,
             control = list(seed = 1234, verbose=TRUE))

save(file = "~/DigEc/ap_lda.RData", list = c("ap_lda"))


# Use SigOpt to tune a text classifier in R
# Learn more about SigOpt's R Client:
# https://sigopt.com/docs/overview/r

install.packages("devtools", repos = "http://cran.us.r-project.org")
library(devtools)
install_github("sigopt/SigOptR")
library(SigOptR)
install.packages("rjson", repos = "http://cran.us.r-project.org")
library(rjson)
install.packages("text2vec", repos = "http://cran.us.r-project.org")
library(text2vec)
install.packages("glmnet", repos = "http://cran.us.r-project.org")
library(glmnet)

# Learn more about authenticating the SigOpt API:
# https://sigopt.com/docs/overview/authentication
Sys.setenv(SIGOPT_API_TOKEN="YOUR_API_TOKEN_HERE")

# load text training data
POSITIVE_TEXT <- fromJSON(file="https://public.sigopt.com/POSITIVE_list.json")
NEGATIVE_TEXT <- fromJSON(file="https://public.sigopt.com/NEGATIVE_list.json")

# optimization metric : see blogpost http://blog.sigopt.com/post/133089144983/sigopt-for-ml-automatically-tuning-text
sentiment_metric <- function(POS_TEXT, NEG_TEXT, params) {
  min_ngram <- params$min_n_gram
  max_ngram <- min_ngram + params$n_gram_offset
  min_doc_freq <- exp(params$log_min_df)
  max_doc_freq <- min_doc_freq + params$df_offset
  text = c(POSITIVE_TEXT, NEGATIVE_TEXT)

  # Construct a matrix representation of the text
  it <- itoken(text, tolower, word_tokenizer)
  vocab <- create_vocabulary(it, ngram = c(min_ngram, max_ngram))
  pruned_vocab = prune_vocabulary(vocab, doc_proportion_min = min_doc_freq, doc_proportion_max = max_doc_freq)
  it <- itoken(text, tolower, word_tokenizer)
  vectorizer <- vocab_vectorizer(pruned_vocab)

  X <- create_dtm(it, vectorizer)
  y <- c(rep(1, length(POSITIVE_TEXT)), rep(0, length(NEGATIVE_TEXT)))

  # Perform cross-validation
  num_folds = 5
  cv_accuracies = c()
  for(i in 1:num_folds) {
    cv_split <- sample(2, nrow(X), replace=TRUE, prob=c(0.7, 0.3))
    X_train <- X[cv_split==1, ]
    y_train <- y[cv_split==1]
    X_valid <- X[cv_split==2, ]
    y_valid <- y[cv_split==2]

    fit <- glmnet(X_train, y_train, family = "binomial", lambda=exp(params$log_reg_coef), alpha=params$l1_coef)
    prediction <-predict(fit, X_valid, type="class")

    correct_predictions <- prediction == y_valid
    accuracy <- sum(correct_predictions)/nrow(X_valid)
    cv_accuracies <- c(accuracy, cv_accuracies)
  }

  return(c(mean(cv_accuracies), sd(cv_accuracies)))
}

experiment <- create_experiment(list(
  name="Sentiment LR Classifier (R)",
  parameters=list(
    list(name="l1_coef",       type="double", bounds=list(min=0, max=1.0)),
    list(name="log_reg_coef",  type="double", bounds=list(min=log(0.000001), max=log(100.0))),
    list(name="min_n_gram",    type="int",    bounds=list(min=1, max=2)),
    list(name="n_gram_offset", type="int",    bounds=list(min=0, max=2)),
    list(name="log_min_df",    type="double", bounds=list(min=log(0.00000001), max=log(0.1))),
    list(name="df_offset",     type="double", bounds=list(min=0.01, max=0.25))
  ),
  # Run the Optimization Loop between 10x - 20x the number of parameters
  observation_budget=60
))

# run experimentation loop
for(i in 1:experiment$observation_budget) {
  suggestion <- create_suggestion(experiment$id)

  opt_metric <- sentiment_metric(POSITIVE_TEXT, NEGATIVE_TEXT, suggestion$assignments)

  create_observation(experiment$id, list(
    suggestion=suggestion$id,
    value=opt_metric[1],
    value_stddev=opt_metric[2]
  ))
} # track progress on your experiment : https://sigopt.com/experiments


library(dplyr)
library(readr)
library(ggplot2)
library(GGally)
library(tidyr)
library(purrr)

# reading in the data
data_train <- read.csv('./data/raw/CompleteResponses.csv')
data_predict <- read.csv('./data/raw/SurveyIncomplete.csv')

# datatypes and columns names match so we can just combine the two datasets
str(data_train)
str(data_predict)

# no weird discrepancies in distributions based on key values
summary(data_train)
summary(data_predict)

# All values of categorical columns present in both datasets
as.data.frame(table(data_train$elevel))
as.data.frame(table(data_predict$elevel))
as.data.frame(table(data_train$car))
as.data.frame(table(data_predict$car))
as.data.frame(table(data_train$zipcode))
as.data.frame(table(data_predict$zipcode))

# we can see that all the predict data has brand
# values set as zero although these should be null. Fixing
plot(data_predict$brand)
data_predict$brand <- NA
data_predict$brand <- as.numeric(data_predict$brand)

# creating a column to mark which dataset is in question and combining them
data_train$train <- TRUE
data_predict$train <- FALSE
data <- union(data_train, data_predict)

# Coding categorical variables as factors with right levels values
data$brand <-
    factor(data$brand,
           levels = c(0, 1),
           labels = c("Acer", "Sony"))
data$elevel <- factor(
    data$elevel,
    levels = c(0, 1, 2, 3, 4),
    labels = c(
        "Less than High Scool Degree",
        "High School Degree",
        "Some College",
        "4-Year College Degree",
        "Master's, Doctoral or Professional Degree"
    )
)
data$car <- factor(
    data$car,
    levels = seq(1, 20),
    labels = c(
        "BMW",
        "Buick",
        "Cadillac",
        "Chevrolet",
        "Chrysler",
        "Dodge",
        "Ford",
        "Honda",
        "Hyundai",
        "Jeep",
        "Kia",
        "Lincoln",
        "Mazda",
        "Mercedes Benz",
        "Mitsubishi",
        "Nissan",
        "Ram",
        "Subaru",
        "Toyota",
        "None of the above"
    )
)
data$zipcode <- factor(
    data$zipcode,
    levels = seq(0, 8),
    labels = c(
        "New England",
        "Mid-Atlantic",
        "East North Central",
        "West North Central",
        "South Atlantic",
        "East South Central",
        "West South Central",
        "Mountain",
        "Pacific"
    )
)

# checking out general patterns
str(data)
summary(data)

# Big pair plot
ggally_mysmooth <- function(data, mapping, ...) {
    ggplot(data = data, mapping = mapping) +
        geom_density(mapping = aes_string(color = 'brand'), fill = NA)
}

ggpairs(
    # sample to make manageable, car and zipcode have too many values to plot
    subset(data[sample(nrow(data), size = 1000), ], select = -c(car, zipcode)),
    mapping = ggplot2::aes(color = brand),
    lower = list(
        continuous = wrap("points", alpha = 0.2, size = 0.3),
        combo = wrap("dot", alpha = 0.2, size = 0.3)
    ),
    diag = list(continuous = ggally_mysmooth),
    title = "Brand",
)

ggsave("./figures/pairs_plot.png",
       dpi = 600,
       limitsize = FALSE)

# OBSERVATIONS
# the relationship between numberical factors is essentially random
# There is a clear non-linear relationship between brand preferance and salary
# Less clear relationships also with age and credit

# Plotting all variables independently
qplot(data$salary, fill = data$train, bins=100)
qplot(data$credit, fill = data$train, bins=100)
qplot(data$age, fill = data$train, bins=61)
qplot(data$elevel, fill = data$train)
qplot(data$car, fill = data$train)
qplot(data$zipcode, fill = data$train)
qplot(data$brand, fill = data$train)

# OBSERVATIONS

# Have to be carefull with the predictions as the brands are not represented equally,
# so simple accuracy metrics in model optimization and comparison won't work

# All values numeric values have their distributions skewed at the extremes
# This is probably because exterme answers where just coded as over X or under X

# Categorical features are balanced between test and train set

# Checking for missing
sapply(data, function(x)
    sum(is.na(x)))

# checking for correlations with numerical variables --> miniscule
cor(data[, map_lgl(data, is.numeric)])


# author: Lara Habashy
# date: 2020-11-26

"Cleans and splits the default of credit card clients data (from http://archive.ics.uci.edu/ml/datasets/default+of+credit+card+clients).
Writes the training and test data to separate feather files.

Usage: src/clean_split_cred.r --input=<input> --out_dir=<out_dir>

Options:
--input=<input>       Path (including filename) to raw data (feather file)
--out_dir=<out_dir>   Path to directory where the cleaned, split data should be written
" -> doc

library(feather)
library(tidyverse)
library(caret)
library(docopt)
library(arrow)

set.seed(2020)

opt <- docopt(doc)
main <- function(input, out_dir){

  # read data and convert default to factor
  raw_data <- arrow::read_feather(input)
  dat <- janitor::row_to_names(raw_data, 1)
  df <- dat %>% janitor::clean_names()

  #convert factor features
  factor_features <- c('default_payment_next_month')
  df[factor_features] <- lapply(df[factor_features], function(x) as.factor(x))

  numeric_features <- c("limit_bal", "age",
                        "pay_0", "pay_2", "pay_3", "pay_4", "pay_5", "pay_6",
                        "bill_amt1","bill_amt2", "bill_amt3", "bill_amt4", "bill_amt5", "bill_amt6",
                        "pay_amt1", "pay_amt2" , "pay_amt3" , "pay_amt4","pay_amt5", "pay_amt6")

  df[numeric_features] <- lapply(df[numeric_features], function(x) as.numeric(x))

  categorical_features <- c("id", "sex", "education", "marriage")
  df[categorical_features] <- lapply(df[categorical_features], function(x) as.factor(x))

  #rename column and drop id feature
  cred_data <- df %>%
    rename(pay_1 = pay_0,
           default = default_payment_next_month) %>%
    relocate(pay_1, .before=pay_2) %>%
    select(-id)

  #encode unknown value as 0
  encode_function <- function(x){
    replace(x, x < -1, 0)
  }
  cred_data <- cred_data %>%
    mutate_at(c("pay_1", "pay_2", "pay_3", "pay_4", "pay_5", "pay_6"), encode_function)

  # split into training and test data sets
  training_rows <- cred_data %>%
    select(default) %>%
    pull() %>%
    createDataPartition(p = 0.75, list = FALSE)

  training_data <- cred_data %>%
    slice(training_rows)
  test_data <- cred_data %>%
    slice(-training_rows)

  try({
    dir.create(out_dir)
  })

  # write training and test data to feather files
  write_feather(training_data, paste0(out_dir, "/training.feather"))
  write_feather(test_data, paste0(out_dir, "/test.feather"))
}

main(opt[["--input"]], opt[["--out_dir"]])


#Plot level aggregation.
#Getting plot, site and global means and sd's for all observations made at the plot level.
#This is currently total basal area and %ECM trees.
#clear environment, source paths.
rm(list=ls())
source('paths.r')
source('NEFI_functions/hierarch_plot.means_JAGS.r')

#load data
plot_data <- readRDS(dp1.10098.00_plot.level.path)

#y-values to constrain some things.
core_obs <- readRDS(core_obs.path)

#get plot level uncertainty on relEM
#if relEM <= 0, logit transform to -10.
#if relEM => 1, logit transform to  10.
relEM.sim <- list()
for(i in 1:1000){
  all <- rnorm(nrow(plot_data),plot_data$basal_live, plot_data$basal_live_sd)
   EM <- rnorm(nrow(plot_data),plot_data$basal_ECM , plot_data$basal_ECM_sd)
   relEM <- EM / all
   for(k in 1:length(relEM)){
     if(relEM[k] < 0.0001){relEM[k] <- 0.0001}
     if(relEM[k] > 0.9999){relEM[k] <- 0.9999}
   }
   b.relEM <- boot::logit(relEM)
   relEM.sim[[i]] <- b.relEM
}
relEM.sim <- do.call(cbind,relEM.sim)
b.relEM <- rowMeans(relEM.sim)
b.relEM_sd <- matrixStats::rowSds(relEM.sim)

#plot level output.
plot.out <- plot_data
plot.out$b.relEM <- b.relEM
plot.out$b.relEM_sd <- b.relEM_sd

#aggregate up to site and glboal level
basal_live_ag <- hierarch_plot.means_JAGS(plot_data$basal_live, plot_site = plot_data$siteID)
basal_dead_ag <- hierarch_plot.means_JAGS(plot_data$basal_dead, plot_site = plot_data$siteID)
basal_ECM_ag  <- hierarch_plot.means_JAGS(plot_data$basal_ECM , plot_site = plot_data$siteID)
basal_bECM_ag <- hierarch_plot.means_JAGS(plot.out$b.relEM   , plot_site = plot.out$siteID)

#add plots to plot-level that are in y-observations but not present in this data product yet.
to_add <- as.character(unique(core_obs[!(core_obs$plotID %in% plot.out$plotID),]$plotID))
to_add.site <- substring(to_add,1,4)
to_add <- data.frame(to_add.site, to_add)
colnames(to_add) <- c('siteID','plotID')
plot.out <- plyr::rbind.fill(plot.out, to_add)

#site and global level output.
basal_live.site <- basal_live_ag$site.table[,c('siteID','Mean','SD')]
basal_live.glob <- basal_live_ag$glob.table[,c('Mean','SD')]
colnames(basal_live.site)[2:3] <- c('basal_live','basal_live_sd')
basal_dead.site <- basal_dead_ag$site.table[,c('siteID','Mean','SD')]
basal_dead.glob <- basal_dead_ag$glob.table[,c('Mean','SD')]
colnames(basal_dead.site)[2:3] <- c('basal_dead','basal_dead_sd')
basal_ECM.site  <- basal_ECM_ag$site.table [,c('siteID','Mean','SD')]
basal_ECM.glob  <- basal_ECM_ag$glob.table [,c('Mean','SD')]
colnames(basal_ECM.site)[2:3] <- c('basal_ECM','basal_ECM_sd')
basal_bECM.site <- basal_bECM_ag$site.table[,c('siteID','Mean','SD')]
basal_bECM.glob <- basal_bECM_ag$glob.table[,c('Mean','SD')]
colnames(basal_bECM.site)[2:3] <- c('b.relEM','b.relEM_sd')

#site level merge.
site.out <- merge(basal_live.site, basal_dead.site, all = T)
site.out <- merge(site.out, basal_ECM.site, all = T)
site.out <- merge(site.out, basal_bECM.site, all = T)
#add in sites in y data not present here.
to_add <- as.character(unique(core_obs[!(core_obs$siteID %in% site.out$siteID),]$siteID))
to_add <- data.frame(to_add)
colnames(to_add) <- 'siteID'
site.out <- plyr::rbind.fill(site.out,to_add)

#global level merge.
glob.out <- rbind(basal_live.glob,basal_dead.glob,basal_ECM.glob, basal_bECM.glob)
pred <- c('basal_live','basal_dead','basal_ECM','b.relEM')
glob.out <- cbind(pred,glob.out)

#save output.----
saveRDS(plot.out, plot_plot.path)
saveRDS(site.out, plot_site.path)
saveRDS(glob.out, plot_glob.path)


args <- commandArgs(trailingOnly = TRUE)
in_file <- args[1]
out_file <- args[2]

set.seed(as.integer(Sys.getenv("RANDOM_SEED")))

data <- read.csv(in_file)
data["tipped"] <- as.factor(data$tipped)
data["pickup_datetime"] <- as.Date(data$pickup_datetime,
                                   format = "%Y-%m-%d %H:%M:%S")
data["dropoff_datetime"] <- as.Date(data$dropoff_datetime,
                                    format = "%Y-%m-%d %H:%M:%S")

model <- glm(tipped ~
                passenger_count +
                trip_distance +
                trip_time_in_secs +
                direct_distance,
             data = data,
             family = binomial(link = "logit"))
saveRDS(model, file = out_file)


# install.packages("blockrand")
# install.packages("psych")

# library(psych)
# require(blockrand)

condition <-  block.random( n= 150,c(block = 3,drug = 2))
headTail(condition)
condition
write.csv(condition,"randomized_design.csv")
pairs.panels(condition)


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

modelo = nnetar(co2)
print(modelo)

prev= forecast(modelo, h=24)
print(prev)
autoplot(prev)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/9.1.RNA.r


library("rjson")

##########################################################################
##########################################################################
Rmap_read_data = function(env) {
  with(env,{

    readdata = function(filename,...) {
      read.csv(sprintf('%s/%s.csv',opt$data_directory,filename),...)
    }
    readclean = function(filename,...) {
      read.csv(sprintf('%s/%s.csv',opt$clean_directory,filename),...)
    }

    #########################################################
    infprofile <- readdata("serial_interval")$fit
    Tip <- 30
    infprofile <- infprofile[1:Tip]
    infprofile <- infprofile/sum(infprofile)
    D <- length(infprofile)

    Tdp <- 21
    presymptomdays <- 2
    Tdpnz <- Tdp - presymptomdays
    Adp <- 5.8
    Bdp <- 0.948
    testdelayprofile <- pgamma(1:Tdpnz,shape=Adp,rate=Bdp)
    testdelayprofile <- testdelayprofile/testdelayprofile[Tdpnz]
    testdelayprofile <- testdelayprofile - c(0.0,testdelayprofile[1:(Tdpnz-1)])
    testdelayprofile <- c(rep(0, presymptomdays), testdelayprofile)

    # data about areas
    df <- readdata("areas",row.names=1)
    N <- nrow(df)
    areas <- rownames(df)
    quoted_areas <- sapply(areas,function(s) paste('"',s,'"',sep=''))
    geoloc <- df[,1:2]
    population <- df[,3]

    # NHS region data
    sparse_region <- df[,4:12]
    N_region <- ncol(sparse_region)
    region_df <- readdata("nhs_regions", row.names=1)
    regions <- rownames(region_df)
    quoted_regions <- sapply(regions,function(s) paste('"',s,'"',sep=''))

    geodist <- readdata("distances",row.names=1)
    colnames(geodist) <- areas

    # read data about how to split UK into regions to model for full model
    js = fromJSON(file="data/region-groupings.json") ### TODO FIX
    inferred_region = sparse_region
    modelled_region = 0*sparse_region
    for (i in 1:9) {
      modelled_region[js[[i]],i]=1
    }
    stopifnot(all(inferred_region<=modelled_region))

    # Use counts from uk_cases in case updated
    cases <- readdata("cases")
    ind <- sapply(cases[,2], function(s)
        !(s %in% c('Outside Wales','Unknown','...17','...18'))
    )
    cases <- cases[ind,]
    AllCount <- cases[,3:ncol(cases)]
    Tall <- ncol(AllCount)
    dates <- as.Date(colnames(AllCount), format='X%Y.%m.%d')
    colnames(AllCount) <- dates
    rownames(AllCount) <- areas

    if (!identical(opt$stage, "clean")) {
      if (opt$cleaned_sample_id>0) {
        sample_id = opt$cleaned_sample_id
        Clean_latent = readclean(paste('Clatent_sample',sample_id,sep=''),
          row.names=1)
        Clean_recon = readclean(paste('Crecon_sample',sample_id,sep=''),
          row.names=1)
        print(paste(
         'Using samples from ',
         opt$clean_directory,'/Clatent_sample',sample_id,'.csv',
         sep=''
        ))
      } else {
        Clean_latent <- readclean('Clatent_median', row.names=1)
        Clean_recon <- readclean('Crecon_median', row.names=1)
        print(paste(
          'Using samples from ',
          opt$clean_directory,'/Clatent_median',
          sep=''
        ))
      }
    }

    #########################################################
    # Radiation fluxes have also been tried, but found to not be significantly different from traffic models.
    # radiation_length_scales <- c(.1,.2,.5)
    # radiation_flux <- array(0,dim=c(N,N,length(radiation_length_scales)))
    # for (i in 1:length(radiation_length_scales)) {
    #   ls <- radiation_length_scales[i]
    #   df <- data.matrix(readdata(sprintf('radiation_flux_ls=%1.1f',ls),row.names=1))
    #   radiation_flux[,,i] <- df
    # }
    # colnames(radiation_flux) <- areas
    # rownames(radiation_flux) <- areas
    # dimnames(radiation_flux)[[3]] <- radiation_length_scales

    traffic_flux <- array(0, dim=c(N,N,2))
    traffic_flux[,,1] <- data.matrix(readdata('traffic_flux_row-normed', row.names=1))
    traffic_flux[,,2] <- data.matrix(readdata('traffic_flux_transpose_row-normed', row.names=1))
    colnames(traffic_flux) <- areas
    rownames(traffic_flux) <- areas

    alt_traffic_flux <- array(0, dim=c(N,N,2))
    alt_traffic_flux[,,1] <- data.matrix(readdata('uk_forward_commute_flow', row.names=1))
    alt_traffic_flux[,,2] <- data.matrix(readdata('uk_reverse_commute_flow', row.names=1))
    colnames(alt_traffic_flux) <- areas
    rownames(alt_traffic_flux) <- areas

  })
  if (!is.null(env$opt$limit_area) && !is.null(env$opt$limit_radius)) {
    source("sandbox/limit_data.r")
    limit_data_by_distance(env, env$opt$limit_area, env$opt$limit_radius)
    print("Limited data to areas:")
    print(env$areas)
  }
  env
}# Rmap_read_data
##########################################################################
##########################################################################


## Import and Format Qualtrics Design Data

## Read Design Data
desmat = read.csv("coded.design.v2.csv",header=TRUE)
desmat = desmat[,-1]

## Read Choice Data
XX = read.csv("homie.v1.csv",header=TRUE)

var.names = c("X0.Version",
              "Q4.2",
              "Q4.3",
              "Q4.4",
              "Q4.5",
              "Q4.6",
              "Q4.7",
              "Q4.8",
              "Q4.9",
              "Q4.10",
              "Q4.11",
              "Q4.12",
              "Q4.13")
choice.dat = XX[,var.names]

## Compute sample characteristics
nobs = nrow(choice.dat)
ntask = 12
nalt = 3
natt = ncol(desmat) - 3

regdata = NULL

for(i in 1:nobs){
  X = array(double(ntask*nalt*natt),dim=c(nalt,natt,ntask))
  Y = as.vector(choice.dat[i,2:13])
  Y = as.vector(as.matrix(Y))
  nver = choice.dat[i,"X0.Version"]
  tmp = desmat[which(desmat[,1]==nver),]
  for(j in 1:ntask){
    xtmp = as.matrix(tmp[which(tmp[,2]==j),4:(ncol(desmat))])
    X[,,j] = xtmp
  }
  regdata[[i]] = list(X = X, Y = Y)
}

#Z = cbind(1,XX$Non.Cust,XX$Non.Cust.Aware,XX$Non.Cust.NotAware)

# Z = choice.dat[,14:ncol(choice.dat)]
#
# ## mean center Z
# Zp = Z
#
# for(i in 1:nrow(Zp)){
#   Zp[i,] = Zp[i,] - apply(Z,2,mean)
# }
#
# Zp = cbind(1,Zp)

Zp = matrix(1,ncol=1,nrow=nobs)
Z = Zp
source("rhierMNL.r")
library(compiler)
crmnl = cmpfun(rmnl)
#out = crmnl(regdata,Z,1000,1,.4)
out = crmnl(regdata,Z,100000,100,.4)

save.image("homie.v1.rdata")

plot.ts(apply(out$llkeep,1,sum))
matplot(out$bbardraw,t="l")

cbind(
  apply(out$bbardraw[600:1000,],2,mean),
  t(apply(out$bbardraw[600:1000,],2,quantile,probs=c(.025,.975)))
)

# t(matrix(apply(out$bbardraw[600:1000,],2,mean),byrow=FALSE,ncol=ncol(Z)))
# t(matrix(apply(out$bbardraw[600:1000,],2,quantile,probs=c(.025)),byrow=FALSE,ncol=ncol(Z)))
# t(matrix(apply(out$bbardraw[600:1000,],2,quantile,probs=c(.975)),byrow=FALSE,ncol=ncol(Z)))

## Export individual level utilities

# bmat = matrix(double(natt*nobs),ncol=natt)
#
# for(i in 1:nobs){
#   bmat[i,] = apply(out$betadraw[600:1000,,i],2,mean)
# }
#
# write.csv(bmat,"bmat.lineaer.csv")


# get_marker_spillover_posnegpop.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

#' Get spillover coefficients using positive and negative populations
#'
#' Calculates spillover coefficients using positive and negative populations.
#'
#' @param flow.gate List of vectors with ids of gated events per sample.
#' @param flow.control List with data and metadata of a set of controls.
#' @param asp List with AutoSpill parameters.
#'
#' @return Matrix with spillover coefficients.
#'
#' @references Roca \emph{et al}:
#'     AutoSpill: A method for calculating spillover coefficients to compensate
#'     or unmix high-parameter flow cytometry data.
#'     \emph{bioRxiv} 2020.06.29.177196;
#'     \href{https://doi.org/10.1101/2020.06.29.177196}{doi:10.1101/2020.06.29.177196}
#'     (2020).
#'
#' @seealso \code{\link{get.marker.spillover}}, \code{\link{gate.flow.data}},
#'     \code{\link{read.flow.control}}, and \code{\link{get.autospill.param}}.
#'
#' @export

get.marker.spillover.posnegpop <- function( flow.gate, flow.control, asp )
{
    marker.spillpopu.zero <- rep( 0, flow.control$marker.n )
    names( marker.spillpopu.zero ) <- flow.control$marker

    marker.spillpopu <- mclapply( flow.control$sample, function( samp )
    {
        marker.proper <- samp

        marker.proper.expr <- flow.control$expr.data.tran[
            which( flow.control$event.sample == samp )[ flow.gate[[ samp ]] ],
            marker.proper ]

        marker.expr.n <- length( marker.proper.expr )

        # identify extreme expression values

        expr.trim.n <- round( marker.expr.n * asp$rlm.trim.factor )

        marker.proper.expr.low <- sort( marker.proper.expr )[ expr.trim.n ]
        marker.proper.expr.high <- sort( marker.proper.expr,
            decreasing = TRUE )[ expr.trim.n ]

        marker.spillpopu.coef <- marker.spillpopu.zero

        for ( marker in flow.control$marker )
            if ( marker == marker.proper )
                marker.spillpopu.coef[ marker ] <- 1.0
            else
            {
                marker.expr <- flow.control$expr.data.tran[
                    which( flow.control$event.sample == samp )[
                        flow.gate[[ samp ]] ],
                    marker ]

                marker.expr.low <- sort( marker.expr )[ expr.trim.n ]
                marker.expr.high <- sort( marker.expr, decreasing = TRUE )[
                    expr.trim.n ]

                # trim expression values for both markers

                expr.trim.idx <- which (
                    marker.proper.expr > marker.proper.expr.low &
                    marker.proper.expr < marker.proper.expr.high &
                    marker.expr > marker.expr.low &
                    marker.expr < marker.expr.high
                )

                marker.proper.expr.trim <- marker.proper.expr[ expr.trim.idx ]

                # identify distribution modes with 2-means clustering

                marker.proper.expr.trim.cluster <-
                    kmeans( marker.proper.expr.trim, 2 )

                cluster.neg.idx <- ifelse(
                    marker.proper.expr.trim.cluster$centers[ 1 ] <
                        marker.proper.expr.trim.cluster$centers[ 2 ], 1, 2 )
                cluster.pos.idx <- ifelse( cluster.neg.idx == 1, 2, 1 )

                cluster.neg.x <- marker.proper.expr.trim.cluster$centers[
                    cluster.neg.idx ]
                cluster.pos.x <- marker.proper.expr.trim.cluster$centers[
                    cluster.pos.idx ]

                # identify minimum of distribution between modes

                marker.proper.expr.trim.density <-
                    density( marker.proper.expr.trim )

                marker.proper.expr.trim.density.fun <- splinefun(
                    marker.proper.expr.trim.density$x,
                    marker.proper.expr.trim.density$y )

                marker.proper.expr.trim.density.min <- optimize(
                    marker.proper.expr.trim.density.fun,
                    c( cluster.neg.x, cluster.pos.x ) )$minimum

                # identify extreme values at untrimmed sides of modes

                marker.proper.expr.neg.high.bool <- marker.proper.expr.trim <
                    marker.proper.expr.trim.density.min

                if ( sum( marker.proper.expr.neg.high.bool ) > expr.trim.n )
                    marker.proper.expr.neg.high <- sort(
                        marker.proper.expr.trim[
                            marker.proper.expr.neg.high.bool ],
                        decreasing = TRUE )[ expr.trim.n ]
                else
                    marker.proper.expr.neg.high <- sort(
                        marker.proper.expr.trim )[ 2 ]

                marker.proper.expr.pos.low.bool <- marker.proper.expr.trim >
                    marker.proper.expr.trim.density.min

                if ( sum( marker.proper.expr.pos.low.bool ) > expr.trim.n )
                    marker.proper.expr.pos.low <- sort(
                        marker.proper.expr.trim[
                            marker.proper.expr.pos.low.bool ] )[ expr.trim.n ]
                else
                    marker.proper.expr.pos.low <- sort(
                        marker.proper.expr.trim, decreasing = TRUE )[ 2 ]

                # identify indices of negative and positive events

                expr.neg.trim.idx <- expr.trim.idx[
                    marker.proper.expr.trim < marker.proper.expr.neg.high ]

                expr.pos.trim.idx <- expr.trim.idx[
                    marker.proper.expr.trim > marker.proper.expr.pos.low ]

                # get spillover coefficient

                marker.expr.median.diff <-
                    flow.control$transform.inv[[ marker ]](
                        median( marker.expr[ expr.pos.trim.idx ] ) ) -
                    flow.control$transform.inv[[ marker ]](
                        median( marker.expr[ expr.neg.trim.idx ] ) )

                marker.proper.expr.median.diff <-
                    flow.control$transform.inv[[ marker.proper ]](
                        median( marker.proper.expr[ expr.pos.trim.idx ] ) ) -
                    flow.control$transform.inv[[ marker.proper ]](
                        median( marker.proper.expr[ expr.neg.trim.idx ] ) )

                marker.spillpopu.coef[ marker ] <-
                    marker.expr.median.diff / marker.proper.expr.median.diff
            }

        marker.spillpopu.coef
    },
    mc.cores = get.worker.process( asp$worker.process.n ) )

    marker.spillpopu <- do.call( rbind, marker.spillpopu )
    rownames( marker.spillpopu ) <- flow.control$marker

    marker.spillpopu
}


## by peter m crosta: pmcrosta at gmail
### Functions for oaxac decompositions in R given sample means and regression coefficients as inputs.

setwd('~/CSVs')
# read in means file
meansraw <- read.csv('means.csv', header=T, stringsAsFactors=F)

# read in coeffs file
coeffsraw <- read.csv('coeffs.csv', header=T, stringsAsFactors=F)

meansraw <- meansraw[meansraw$X!="",]
coeffsraw <- coeffsraw[coeffsraw$X!="",]

coefnames <- coeffsraw$X
sumnames <- meansraw$X

coefcol <- colnames(coeffsraw)
sumcol <- colnames(meansraw)

oaxaca <- function(mods) UseMethod("oaxaca")

oaxaca.default <- function(mods) {
    ## Input is a charactervector. Likely taken from a list
    mod1 <- mods[1]
    mod2 <- mods[2]
    ### get model coefficients
    m1 <- as.numeric(coeffsraw[, which(mod1==coefcol)])
    m2 <- as.numeric(coeffsraw[, which(mod2==coefcol)])

    names(m1)<-coefnames
    names(m2)<-coefnames

    m1 <- na.omit(m1)
    m2 <- na.omit(m2)

    ## get means
    s1 <- as.numeric(meansraw[, which(mod1==sumcol)])
    s2 <- as.numeric(meansraw[, which(mod2==sumcol)])

    names(s1)<-sumnames
    names(s2)<-sumnames

    s1 <- na.omit(s1)
    s2 <- na.omit(s2)

    if (substr(mod1,1,1)=="r") depvar <- "readdep" else if (substr(mod1,1,1)=="m") depvar <- "mathdep"

    k <- NROW(m1)
    k1 <- NROW(m2)
    if (k != k1) stop("models are not the same size")

    W <- list("W = 1 (Oaxaca, 1973)" = diag(1, k),
              "W = 0 (Blinder, 1973)" = diag(0, k),
              "W = 0.5 (Reimers 1983)" = diag(0.5, k))

    mnames <- names(m1)[-which(names(m1)=="Constant")]
    X1 <- c(s1[mnames], 1)
    X2 <- c(s2[mnames], 1)

    Q <- sapply(W, function(w) crossprod(X1 - X2, w %*% m1 + (diag(1, k) - w) %*% m2))
    U <- sapply(W, function(w) (crossprod(X1, diag(1, k) - w) + crossprod(X2, w)) %*% (m1 - m2))

    attcoeff <- c("_Iattdec_2", "_Iattdec_3", "_Iattdec_4", "_Iattdec_5", "_Iattdec_6", "_Iattdec_7", "_Iattdec_8", "_Iattdec_9", "_Iattdec_10")

    #Qa <- sapply(W, function(w) crossprod(X1['lnattend'] - X2['lnattend'], w[1] %*% m1['lnattend'] + (diag(1, 1) - w[1]) %*% m2['lnattend']))
    #Ua <- sapply(W, function(w) (crossprod(X1['lnattend'], diag(1, 1) - w[1]) + crossprod(X2['lnattend'], w[1])) %*% (m1['lnattend'] - m2['lnattend']))

    Qa <- Ua <- 0
    for (ii in attcoeff) {
        Qa <- Qa + sapply(W, function(w) crossprod(X1[ii] - X2[ii], w[1] %*% m1[ii] + (diag(1, 1) - w[1]) %*% m2[ii]))
        Ua <- Ua + sapply(W, function(w) (crossprod(X1[ii], diag(1, 1) - w[1]) + crossprod(X2[ii], w[1])) %*% (m1[ii] - m2[ii]))
    }

    KK<-length(X1)
    Qdetail <- sapply(W, function(w) sapply(1:KK, function(jj) crossprod(X1[jj] - X2[jj], w[1] %*% m1[jj] + (diag(1, 1) - w[1]) %*% m2[jj])))
    Udetail <- sapply(W, function(w) sapply(1:KK, function(jj) (crossprod(X1[jj], diag(1, 1) - w[1]) + crossprod(X2[jj], w[1])) %*% (m1[jj] - m2[jj])))
    rownames(Qdetail) <- rownames(Udetail) <- c(mnames, "Constant")

    # Var-covar matrices
    setwd('~/outregs')
    VB1 <- as.matrix(read.table(paste(mod1, 'mat.txt', sep='')))
    VB2 <- as.matrix(read.table(paste(mod2, 'mat.txt', sep='')))

    VX1 <- as.matrix(read.table(paste(mod1, 'cor.txt', sep='')))
    VX2 <- as.matrix(read.table(paste(mod2, 'cor.txt', sep='')))

    dep1 <- s1[depvar]
    dep2 <- s2[depvar]
    Ddep <- dep1-dep2

    ans <- list(R = Ddep,
              VR = crossprod(X1, VB1) %*% X1 + crossprod(m1, VX1) %*% m1 + sum(diag(VX1 %*% VB1)) +
              crossprod(X2, VB2) %*% X2 + crossprod(m2, VX2) %*% m2 + sum(diag(VX2 %*% VB2)))

    VQ <- sapply(W, function(w)
              sum(diag((VX1 + VX2) %*% (w %*% tcrossprod(VB1, w) + (diag(1, k) - w) %*% tcrossprod(VB2, diag(1, k) - w)))) +
              crossprod(X1 - X2, w %*% tcrossprod(VB1, w) + (diag(1, k) - w) %*% tcrossprod(VB2, diag(1, k) - w)) %*% (X1 - X2) +
              crossprod(w %*% m1 + (diag(1, k) - w) %*% m2, VX1 + VX2) %*% (w %*% m1 + (diag(1, k) - w) %*% m2))
    VU <- sapply(W, function(w)
              sum(diag((crossprod(diag(1, k) - w, VX1) %*% (diag(1, k) - w) + crossprod(w, VX2) %*% w) %*% (VB1 + VB2))) +
              crossprod(crossprod(diag(1, k) - w, X1) + crossprod(w, X2), VB1 + VB2) %*% (crossprod(diag(1, k) - w, X1) + crossprod(w, X2))+
              crossprod(m1 - m2, crossprod(diag(1, k) - w, VX1) %*% (diag(1, k) - w) + crossprod(w, VX2) %*% w) %*% (m1 - m2))

    ans$Q <- Q
    ans$U <- U
    ans$VQ <- VQ
    ans$VU <- VU
    ans$W <- W
    ans$Qa <- Qa
    ans$Ua <- Ua
    ans$call <- match.call()
    ans$mod1 <- mod1
    ans$mod2 <- mod2
    ans$Qdetail <- Qdetail
    ans$Udetail <- Udetail
    class(ans) <- "oaxaca"
    ans

}

print.oaxaca <- function(x) {
  se <- sqrt(x$VQ)
  zval <- x$Q / se
  decomp <- cbind(Explained = x$Q, StdErr = se, "z-value" = zval, "Pr(>|z|)" = 2*pnorm(-abs(zval)))
  cat("\nBlinder-Oaxaca decomposition\n\nCall:\n")
  print(x$call)
  cat(x$mod1, ' ', x$mod2, "\n")
  decomp <- matrix(nrow = 1, ncol = 4)
  decomp[1, c(1, 2)] <- c(x$R, sqrt(x$VR))
  decomp[1, 3] <- c(decomp[, 1] / decomp[, 2])
  decomp[1, 4] <- c(2 * pnorm(-abs(decomp[, 3])))
  colnames(decomp) <- c("Difference", "StdErr", "z-value", "Pr(>|z|)")
  rownames(decomp) <- "Mean"
  cat("\n")
  print(zapsmall(decomp))
  cat("\nLinear decomposition:\n")
  for (i in 1:3) {
    cat(paste("\nWeight: ", names(x$W[i]), "\n"))
    decomp <- cbind(Difference = c(x$Q[i], x$U[i]), StdErr = c(sqrt(x$VQ[i]), sqrt(x$VU[i])))
    decomp <- cbind(decomp, "z-value" = decomp[, 1] / decomp[, 2])
    decomp <- cbind(decomp, "Pr(>|z|)" = 2 * pnorm(-abs(decomp[, 3])))
    decomp <- cbind(decomp, c(x$Qa[i], x$Ua[i]))
    colnames(decomp) <- c("Difference", "StdErr", "z-value", "Pr(>|z|)", "attendance")
    rownames(decomp) <- c("Explained", "Unexplained")
    print(zapsmall(decomp))
  }
  cat("\n")
}

write.oaxaca <- function(x) {
    if (class(x) != "oaxaca") stop("Input needs to be of class oaxaca")
  #cat(x$mod1, ' ', x$mod2, "\n")
  decomp <- matrix(nrow = 3, ncol = 5)
  decomp[1, c(1, 2)] <- c(x$R, sqrt(x$VR))
  decomp[1, 3] <- c(decomp[1, 1] / decomp[1, 2])
  decomp[1, 4] <- c(2 * pnorm(-abs(decomp[1, 3])))
  colnames(decomp) <- c("Difference", "StdErr", "z-value", "Pr(>|z|)", paste(x$mod1, x$mod2, sep=''))
  if (substr(x$mod1,1,1)=="r") depvar <- "Reading" else if (substr(x$mod1,1,1)=="m") depvar <- "Math"
  rownames(decomp) <- c(depvar, "Explained", "Unexplained")
    i<-3
    decomp[2,1] <- x$Q[i]
    decomp[3,1] <- x$U[i]
    decomp[2,2] <- sqrt(x$VQ[i])
    decomp[3,2] <- sqrt(x$VU[i])
    decomp[2,3] <- decomp[2, 1] / decomp[2, 2]
    decomp[3,3] <- decomp[3, 1] / decomp[3, 2]
    decomp[2,4] <- 2 * pnorm(-abs(decomp[2, 3]))
    decomp[3,4] <- 2 * pnorm(-abs(decomp[3, 3]))
    decomp[2,5] <- x$Qa[i]
    decomp[3,5] <- x$Ua[i]
    zapsmall(decomp)
}

detail.oaxaca <- function(x, depth=6) {
  if (class(x) != "oaxaca") stop("Input needs to be of class oaxaca")
  ##only deal with Cotton/Reimers
  Qdet <- sort(x$Qdetail[,3])
  Udet <- sort(x$Udetail[,3])
  Qh <- head(Qdet, depth)
  Qt <- tail(Qdet, depth)
  Uh <- head(Udet, depth)
  Ut <- tail(Udet, depth)
  Qsum <- cbind(Qh, names(Qt), Qt)
  Usum <- cbind(Uh, names(Ut), Ut)
  ret.list <- list(Qsum, Usum)
}

### Below is code specific to the analysis
### which decompositions do we want to do?
### coefcol[-1] lists the options:
### math, reading
### pooled, fixed effects
### racedum1-5, econdum1-4
### remember: race: amerindian, asian, black, hispanic, white
### remember: econ: not poor, free lunch, reduced lunch, other dis

## For pooled and FE models: white-black, white-hispanic, hispanic-black
##              notpoor-free, notpoor-reduced, notpoor-other

## This becomes: 5-3, 5-4, 4-3; 1-2, 1-3, 1-4
grouprace <- list(
 c('mpa4racedum5C', 'mpa4racedum3C'),
 c('rpa4racedum5C', 'rpa4racedum3C'),
 c('mfa4racedum5C', 'mfa4racedum3C'),
 c('rfa4racedum5C', 'rfa4racedum3C'),

 c('mpa4racedum5C', 'mpa4racedum4C'),
 c('rpa4racedum5C', 'rpa4racedum4C'),
 c('mfa4racedum5C', 'mfa4racedum4C'),
 c('rfa4racedum5C', 'rfa4racedum4C'),

 c('mpa4racedum4C', 'mpa4racedum3C'),
 c('rpa4racedum4C', 'rpa4racedum3C'),
 c('mfa4racedum4C', 'mfa4racedum3C'),
 c('rfa4racedum4C', 'rfa4racedum3C'))

groupecon <- list(
 c('mpa4econdum1C', 'mpa4econdum2C'),
 c('rpa4econdum1C', 'rpa4econdum2C'),
 c('mfa4econdum1C', 'mfa4econdum2C'),
 c('rfa4econdum1C', 'rfa4econdum2C'),

 c('mpa4econdum1C', 'mpa4econdum3C'),
 c('rpa4econdum1C', 'rpa4econdum3C'),
 c('mfa4econdum1C', 'mfa4econdum3C'),
 c('rfa4econdum1C', 'rfa4econdum3C'),

 c('mpa4econdum1C', 'mpa4econdum4C'),
 c('rpa4econdum1C', 'rpa4econdum4C'),
 c('mfa4econdum1C', 'mfa4econdum4C'),
 c('rfa4econdum1C', 'rfa4econdum4C'))

oax.race<-lapply(grouprace, oaxaca)
oax.econ<-lapply(groupecon, oaxaca)

## oaxaca print out function
lapply(oax.race, write.oaxaca)
lapply(oax.econ, write.oaxaca)

## print out detailed decomposition
race.det <- lapply(oax.race, detail.oaxaca)
names(race.det) <- sapply(grouprace, function(x) paste(x, collapse=''))
race.det

econ.det <- lapply(oax.econ, detail.oaxaca)
names(econ.det) <- sapply(groupecon, function(x) paste(x, collapse=''))
econ.det


pattern_count <- function(text, pattern) {
  count <- 0
  pattern_length <- nchar(pattern)
  for (i in 0:(nchar(text) - pattern_length)) {
    if (substr(rep(text), i + 1, i + pattern_length) == pattern)
      count <- count + 1
  }
  return(count)
}

# message("Text")
# text <- scan("stdin", what="character", nlines=1)
# message("Pattern")
# pattern <- scan("stdin", what="character", nlines=1)

# print(pattern_count(text, pattern))


rm(list = ls())

list_offpring <- function(x, Data) {
  sapply(Data$I, function(y) x[which(x[,1] == y), 2])
}

list_parent <- function(x, Data) {
  sapply(Data$I, function(y) x[which(x[,2] == y), 1L])
}

newprune <- function(tree) {

  # Creating variables
  Dat       <- new.env()
  Dat$n     <- max(tree)
  Dat$tree  <- tree
  Dat$count <- 0L
  Dat$I     <- 1L:Dat$n
  Dat$idx   <- integer(Dat$n)

  Dat$Off   <- list_offpring(tree, Dat)
  Dat$Par   <- list_parent(tree, Dat)

  # Methods
  Dat$nexti <- function(i) {
    Dat$count  <- Dat$count + 1L
    Dat$idx[i] <- Dat$count
  }

  Dat
}

preorder_prune <- function(i, Data, f = function(i, d) {1+1}) {

  if (Data$idx[i] != 0)
    return(NULL)

  # Take it to the dad
  for (j in Data$Par[[i]]) {
    preorder_prune(j, Data, f)
  }

  # Increasing counters
  if (Data$idx[i] != 0)
    return(NULL)

  Data$nexti(i)

  # Calling the user function
  f(i, Data)

  # Fetching the offspring
  for (j in Data$Off[[i]])
    preorder_prune(j, Data, f)

  return(Data)

}

# A fake tree
tree <- c("i", "a", "i", "f", "f", "b", "f", "c", "h", "i", "i", "g", "g", "d", "g", "e") #, "j", "i")
# tree <- c(tree, "i", "c")
lvls <- match(tree, letters)
tree <- matrix(lvls, ncol=2, byrow = TRUE)
tree <- matrix(lvls, ncol=2, byrow = TRUE)

# Function to recode the tree
recode_tree <- function(i, D) {

  # Initializing the tree
  if (!length(D$new_tree)) {
    D$new_tree <- NULL
    D$Nnode    <- which(sapply(D$Off, length) > 0)
  }

  if (length(D$Par[[i]]))
    D$new_tree <- rbind(
      D$new_tree,
      cbind(D$idx[D$Par[[i]]], D$count)
      )

}

edgelist_to_ape <- function(x) {
  structure(
    list(
      edge  = x,
      Nnode =
    )
  )
}

ans <- newprune(tree)
preorder_prune(1, ans, recode_tree)

oldpar <- par(no.readonly = TRUE)
par(mfrow=c(1, 2))
set.seed(1);plot(igraph::graph_from_edgelist(tree), layout = igraph::layout_as_tree)
set.seed(1);plot(igraph::graph_from_edgelist(ans$new_tree), layout = igraph::layout_as_tree)
par(oldpar)


std_eff <- dplyr::filter(example_proctor_data, compaction_effort == 'standard')
w_opt(std_eff, specific_gravity = Gs)


library(ggplot2)
library(data.table)
library(dplyr)

if(! exists("inputFile")){
  args <- commandArgs(TRUE)
  if(length(args) == 0){
    setwd("/scratch/cqs/shengq2/jennifer/20190906_lindsay_exomeseq_3772_hg38/bwa_refine_nosoftclip_featureCounts_table/result")
    inputFile<-"lindsay_exomeseq_3772.count"
    outputPrefix<-'lindsay_exomeseq_3772.count'
    sizeFactorFile<-"/scratch/cqs/shengq2/jennifer/20190906_lindsay_exomeseq_3772_hg38/bwa_refine_nosoftclip_gatk4_CNV_Germline_08_SizeFactor/result/lindsay_exomeseq_3772.txt.sizefactor"
  }else{
    inputFile<-args[1]
    outputPrefix<-args[2]
    sizeFactorFile<-args[3]
  }
}

cat(inputFile, "\n")
rawTable<-read.table(file=inputFile, sep="\t", header=T, row.names=1)

readSizeFactors<-function(fileName){
  sizeFactorsAll<-read.table(sizeFactorFile, sep="\t", header=T)
  sizeFactorsAll<-sizeFactorsAll[!is.na(sizeFactorsAll$SizeFactor),]
  sfMedian<-sizeFactorsAll %>% group_by(Sample) %>% summarise(Median=median(SizeFactor))

  result<-sfMedian$Median
  names(result)<-sfMedian$Sample
  return(result)
}

sizeFactors<-readSizeFactors(sizeFactorFile)

normData<-rawTable
for(col in colnames(normData)){
  normData[,col] = normData[,col] * sizeFactors[col]
}


#!/usr/bin/Rscript
#===============================================================================
#  Copyright (c)   berrygenomics 2015
#
#  DESCRIPTION: PCA
#
#      OPTIONS: ---
#         BUGS: ---
#        NOTES: ---
#       AUTHOR: sunhy
#         MAIL: sunhuaiyu@berrygnomics.com
#      VERSION: 2.0
#      CREATED:
#===============================================================================
library(getopt)
Spec <- matrix(c(
    'input',       'i', 1, 'character',   'input file path                                                           must',
    'Chr',         'c', 1, 'integer',     'which Chr                                                                 must',
    'outdir',      'o', 1, 'character',   'output dir                                                                must',
    'prefile',     'p', 1, 'character',   'the prepare PCA files prefix                                              must',
    'rmPCs',       'R', 2, 'integer',     'need remove PCs number                                                    option',
    'rm_mean_pve', 'r', 2, 'numeric',     'the remove PCs PVE mean, this is useless when set rmPCs, default 0.7      option',
    'Merge',       'M', 2, 'integer',     'merge some bins to one, default 5                                         option',
    'redisseq',    'd', 2, 'character',   'the redis seqs matrix file, if set, will do redis seq correction          option'
), byrow=T, ncol=5)

opt <- getopt(Spec)

if (is.null(opt$input) | is.null(opt$prefile) | is.null(opt$Chr) ) {
    cat(getopt(Spec, usage=T))
    q(status=1)
}

options(scipen=200)

if (is.null(opt$Merge) ) { opt$Merge <- 5 }
if (is.null(opt$rm_mean_pve) ) { opt$rm_mean_pve <- 0.7 }
BIN_LENGTH <- 20000
bins_size <- opt$Merge * BIN_LENGTH
prefix <- gsub('.matrix', '', basename(opt$input))
prefix <- paste(opt$outdir, '/', prefix, sep='')

PCs_file <- paste(opt$prefile, '.PCs.txt', sep='')
singular_value_file <- paste(opt$prefile, '.SD_DIS.txt', sep='')
mean_sd_file <- paste(opt$prefile, '.mean_sd.txt', sep='')

input <- as.matrix(read.table(opt$input, header=F, row.names=1, stringsAsFactors=F, check.name=F, sep='\t'))
pre_PCs <- as.matrix(read.table(PCs_file, header=T, row.names=1, stringsAsFactors=F, sep='\t', check.name=F))
mean_sd <- as.matrix(read.table(mean_sd_file, header=T, row.names=1, stringsAsFactors=F, sep='\t', check.name=F))
singular_value <- as.matrix(read.table(singular_value_file, stringsAsFactors=F))

Ncol <- seq(1, ncol(input))

colnames(input) <- paste(opt$Chr, ':', (Ncol-1) * bins_size, '-', Ncol * bins_size - 1, sep="")
# some sample maybe some bins has NA, unexcept
x <- apply(input, 2, FUN=function(x){ sum(is.na(x)) == 0 })
input <- subset(input, select=x)

use.index <- which( colnames(input) %in% colnames(pre_PCs))

# x <- apply(input, 2, FUN=function(x){ sum(is.na(x)) })

# pca.use.matrix <- input[ , use.index]
pca.use.matrix <- subset(input, select=use.index)

use.index <- which (colnames(pre_PCs) %in% colnames(pca.use.matrix))
pre_PCs <- subset(pre_PCs, select=use.index)
mean_sd <- subset(mean_sd, select=use.index)

if ( ncol(pca.use.matrix) != ncol(pre_PCs) ) {
	cat('FATAL ERROR: pcas error ncols', file=stderr(), end='\n')
	q(status=1)
}
if ( ncol(pca.use.matrix) != ncol(mean_sd) ) {
	cat('FATAL ERROR: rdfile error ncols', file=stderr(), end='\n')
	q(status=1)
}

write.table(pca.use.matrix, file=paste(prefix, '.filter_na.matrix', sep=''), row.names=T, col.names=NA, quote=F, sep='\t')

## use redis seq number normalize
if ( !is.null(opt$redisseq) ) {
    library(zoo)
    Redisseq <- t(as.matrix(read.table(opt$redisseq, header=F, stringsAsFactors=F)))
    Redisseq <- Redisseq[opt$Chr, ]
    Redisseq <- rollapply(Redisseq, width=opt$Merge, by=opt$Merge, FUN=sum, partial=T, align='left')
    Redisseq <- Redisseq[use.index]
    pca.use.matrix <- t(apply(pca.use.matrix, 1, FUN=function(x) { x / Redisseq }))
    out_scale_matrix <- paste( prefix, '.redis_scale.txt', sep='')
    write.table(pca.use.matrix, file=out_scale_matrix, row.names=T, col.names=NA, quote=F, sep='\t')
}

## mean centered and output foldchange matrix

pca.use.matrix.fd <- t(apply(pca.use.matrix, 1, FUN=function(x) {x/mean_sd[1,]}))
write.table(pca.use.matrix.fd, file=paste(prefix, '.fd.matrix', sep=''), row.names=T, col.names=NA, quote=F, sep='\t')
fd_constancy <- apply(pca.use.matrix.fd, 1, FUN=function(x) { c(mean(x), sd(x)) })
colnames(fd_constancy) <- rownames(pca.use.matrix)
rownames(fd_constancy) <- c('Mean', 'Sd')
out_fd_mean_sd <- paste(prefix, '.fd.mean_sd.matrix', sep='')
write.table(fd_constancy, file=out_fd_mean_sd, row.names=T, col.names=NA, quote=F, sep='\t')

pca.use.matrix.center <- t(apply(pca.use.matrix, 1, FUN=function(x) { x - mean_sd[1, ] }))

write.table(pca.use.matrix.center, file=paste(prefix, '.centered.matrix', sep=''), row.names=T, col.names=NA, quote=F, sep='\t')

## remove PCs
if (is.null(opt$rmPCs)) {
    Remove.pc.number <- which(singular_value[, 2] ^ 2 >= (sum(singular_value[, 2] ^ 2) / nrow(pre_PCs)) * opt$rm_mean_pve)
    if ( length(Remove.pc.number) == 0 ) {
        Remove.pc.number <- c()
    }
    out_sd_remove_number <- paste( prefix, '.SD_REMOVE_NUMBER.txt', sep='')
    cat(paste(Remove.pc.number, sep='\t'), end='\n', file=stderr())
    cat(max(Remove.pc.number), end='\n', file=out_sd_remove_number)
}else{
    Remove.pc.number <- seq(1, opt$rmPCs)
    out_sd_remove_number <- paste(prefix, '.SD_REMOVE_NUMBER.txt', sep='')
    cat(paste(Remove.pc.number, sep='\t'), end='\n', file=stderr())
    cat(max(Remove.pc.number), end='\n', file=out_sd_remove_number)
}

#### use a formula to remove PCs

for (i in seq(1, nrow(pca.use.matrix.center)) ) {
	for (j in Remove.pc.number ) {
		principal <- sum(pca.use.matrix.center[i,]*pre_PCs[j])
		# cat(paste(principal,i,j,sep='\t'),end='\n', file=stderr())
		pca.use.matrix.center[i, ] <- pca.use.matrix.center[i, ] - pre_PCs[j, ] * sum( pca.use.matrix.center[i, ] * pre_PCs[j,])
	}
}

write.table(pca.use.matrix.center, file=paste(prefix, '.normalized.matrix', sep=''), row.names=T, col.names=NA, quote=F, sep='\t')

pca.use.matrix.center.zscore <- t(apply(pca.use.matrix.center, 1, FUN=function(x) { (x - mean(x))/sd(x) }))

write.table(pca.use.matrix.center.zscore, file=paste(prefix, '.normalized.zscore.matrix', sep=''), row.names=T, col.names=NA, quote=F, sep='\t')
#### plot every sample's zscore distribution

coor_x <- colnames(pca.use.matrix.center.zscore)
coor_x <- do.call(rbind, strsplit(coor_x, "[:-]", perl=T))
coor_x <- as.numeric(coor_x[, 2])
pdf(file=paste(prefix, '.zscore.dis.pdf', sep=''), width=12, height=9)
par(mfrow=c(3,1))
for (i in seq(1, nrow(pca.use.matrix.center.zscore))) {
	plot(coor_x/1000000, pca.use.matrix.center.zscore[i,],xlab='Pos(M)',ylab='zscore',main=rownames(pca.use.matrix.center)[i],pch=20,col='blue')
}
dev.off()


library(ggvis)

mtcars %>%
  ggvis(~cyl, ~mpg) %>%
  layer_boxplots() %>%
  save_spec("boxplot/boxplot-continuous.json")

mtcars %>%
  ggvis(~factor(cyl), ~mpg) %>%
  layer_boxplots() %>%
  save_spec("boxplot/boxplot-categorical.json")

dat <- data.frame(x = c('a','a','a','b','b','b'), y = c(1:3, 2:4))
dat %>%
  ggvis(x = ~x, y = ~y) %>%
  layer_boxplots() %>%
  save_spec("boxplot/boxplot-no-outliers.json")