set.seed(2019)

######################################################
## logistic regression on win-move vs other proportion
######################################################

##

model_binomial = brm(
  formula = win_move ~ coplayer_type * condition * tvj_semprag_type + (1 | item),
  family = "bernoulli",
  data = filter(d_analysis, training_successful == 1),
  prior = c(prior_string("normal(0,30)", class = "b")),
  iter = 3000,
  warmup = 1000,
  control = list(max_treedepth = 15)
)

post_samples_binomial = posterior_samples(model_binomial) %>%
  as_tibble() %>%
  select( - lp__) %>%
  select(-contains("_item"))
newcolnames = str_replace(names(post_samples_binomial), "b_", "") %>%
  str_replace("condition", "") %>%
  str_replace("coplayer_type", "") %>%
  str_replace("tvj_semprag_type", "")
names(post_samples_binomial) = newcolnames

bayesplot::mcmc_intervals(post_samples_binomial)

#################################
## main effect of Sem-Prag Type?
#################################

## descriptive mean win-choice proportion
filter(d_analysis, training_successful == 1) %>%
  group_by(tvj_semprag_type) %>%
  summarize(mean_win_choice = mean(win_move))

# pragmatic players are more likely to choose the winning move
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic"),
  lower = list()
)

##################################
## main effects of Co-Player Type?
##################################

## descriptive mean win-choice proportion
filter(d_analysis, training_successful == 1) %>%
  group_by(coplayer_type) %>%
  summarize(mean_win_choice = mean(win_move)) %>%
  arrange(- mean_win_choice)

compare_groups(
  model_binomial,
  higher = list(coplayer_type = "cooperative"),
  lower = list(coplayer_type = "strategic")
)

compare_groups(
  model_binomial,
  higher = list(coplayer_type = "strategic"),
  lower = list(coplayer_type = "unstrategic")
)

## interpretation:
## highest proportion of win-choices for cooperative, then strategic, then unstrategic

#############################
## main effects of condition?
#############################

## descriptive mean win-choice proportion
filter(d_analysis, training_successful == 1) %>%
  group_by(condition) %>%
  summarize(mean_win_choice = mean(win_move)) %>%
  arrange(- mean_win_choice)

compare_groups(
  model_binomial,
  higher = list(condition = "all"),
  lower = list(condition = "number")
)

compare_groups(
  model_binomial,
  higher = list(condition = "all"),
  lower = list(condition = "none")
)

compare_groups(
  model_binomial,
  higher = list(condition = "none"),
  lower = list(condition = "some")
)

compare_groups(
  model_binomial,
  higher = list(condition = "some"),
  lower = list(condition = "ad_hoc")
)

## interpretation:
## ALL = NONE = NUMBER > SOME > AD HOC
## ALL, NONE and NUMBER partition together and are not distinct, but
## SOME has smaller win-choice proportion, as NONE and
## AD HOC has smaller win-choice proportion as SOME

########################################################
## main effect of Sem-Prag Type for each Co-Player Type?
########################################################

## pragmatic - cooperative
## ALL = NONE = NUMBER = SOME > AD HOC
filter(d_analysis, training_successful == 1, tvj_semprag_type == "pragmatic", coplayer_type == "cooperative") %>%
  group_by(condition) %>%
  summarize(mean_win_choice = mean(win_move)) %>%
  arrange(- mean_win_choice)

# SOME > AD HOC ? -> yes
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "cooperative", condition = "some"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "cooperative", condition = "ad_hoc")
)

# NUMBER > SOME ? -> no
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "cooperative", condition = "number"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "cooperative", condition = "some")
)

# ALL > NUMBER -> no!
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "cooperative", condition = "all"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "cooperative", condition = "number")
)

## pragmatic - unstrategic
## -> nothing is different!
filter(d_analysis, training_successful == 1, tvj_semprag_type == "pragmatic", coplayer_type == "unstrategic") %>%
  group_by(condition) %>%
  summarize(mean_win_choice = mean(win_move)) %>%
  arrange(- mean_win_choice)

# AD HOC > NUMBER -> no!
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "unstrategic", condition = "ad_hoc"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "unstrategic", condition = "number")
)

# pragmatic - strategic
## all the same
## -> only ALL, NUMBER and NONE are bigger than AD HOC, nothing else

filter(d_analysis, training_successful == 1, tvj_semprag_type == "pragmatic", coplayer_type == "strategic") %>%
  group_by(condition) %>%
  summarize(mean_win_choice = mean(win_move)) %>%
  arrange(- mean_win_choice)

# NONE > NUMBER -> no
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "none"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "number")
)

# NUMBER > SOME -> no!
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "number"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "some")
)

# NONE > SOME -> no
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "none"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "some")
)

# SOME > AD HOC -> maybe / barely
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "some"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "ad_hoc")
)

# NUMBER > AD HOC -> yes
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "number"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "strategic", condition = "ad_hoc")
)

## semantic - cooperative
## ALL = NONE = NUMBER > SOME > AD HOC

filter(d_analysis, training_successful == 1, tvj_semprag_type == "semantic", coplayer_type == "cooperative") %>%
  group_by(condition) %>%
  summarize(mean_win_choice = mean(win_move)) %>%
  arrange(- mean_win_choice)

# ALL > NUMBER ? -> no
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "cooperative", condition = "all"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "cooperative", condition = "number")
)

# NUMBER > SOME ? -> yes
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "cooperative", condition = "number"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "cooperative", condition = "some")
)

# SOME > AD HOC ? -> yes
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "cooperative", condition = "some"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "cooperative", condition = "ad_hoc")
)

## semantic - unstrategic
## ALL = NUMBER = NONE > SOME = AD HOC

filter(d_analysis, training_successful == 1, tvj_semprag_type == "semantic", coplayer_type == "unstrategic") %>%
  group_by(condition) %>%
  summarize(mean_win_choice = mean(win_move)) %>%
  arrange(- mean_win_choice)

# ALL > NUMBER ? -> no
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "all"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "number")
)

# NUMBER > NONE ? -> no
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "number"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "none")
)

# NONE > SOME  ? -> yes
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "none"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "some")
)

# NUMBER > SOME  ? -> yes
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "number"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "some")
)

# SOME > AD HOC ? -> no
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "some"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "unstrategic", condition = "ad_hoc")
)

## semantic - strategic
## ALL = NUMBER = NONE > SOME = AD HOC

filter(d_analysis, training_successful == 1, tvj_semprag_type == "semantic", coplayer_type == "strategic") %>%
  group_by(condition) %>%
  summarize(mean_win_choice = mean(win_move)) %>%
  arrange(- mean_win_choice)

# ALL > NUMBER ? -> no
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "all"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "number")
)

# NUMBER > NONE ? -> no
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "number"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "none")
)

# NONE > SOME  ? -> yes
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "none"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "some")
)

# NUMBER > SOME  ? -> yes
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "number"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "some")
)

# SOME > AD HOC ? -> yes
compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "some"),
  lower = list(tvj_semprag_type = "semantic", coplayer_type = "strategic", condition = "ad_hoc")
)

#########################################
## check against random choices
#########################################

predictor_values = extract_posterior_cell_means(model_binomial)$predictor_values

mean(predictor_values$`coplayer_type:strategic__condition:ad_hoc__tvj_semprag_type:semantic` > 1)

stop()

compare_groups(
  model_binomial,
  higher = list(tvj_semprag_type = "pragmatic", coplayer_type = "cooperative", condition = "some"),
  lower = list(tvj_semprag_type = "pragmatic", coplayer_type = "cooperative", condition = "ad_hoc")
)

all_comparisons = extract_posterior_cell_means(model_binomial)$all_cells_compared %>%
  as.tibble() %>% filter(co_player_type)

## interpretation:
### there is overal a higher proportion of win-choices for pragmatic participants

########################################################
## main effect of Sem-Prag Type for each Co-Player Type?
########################################################


#!/usr/bin/env Rscript
#
# Script to run MAPIT -- an R program that calculates marginal epistasis
# values for variants.
#
# run_mapit.r <directory with MAPIT code> <genotypes> <phenotypes> <output prefix>
#
# genotypes is assumed to be tab-delimited with chrom, pos, and rs columns
# before the genotypes. The genotypes should be 1 or 0, and the file should
# have column names. Missing data is imputed by taking the average.
#
# phenotypes is a two column file, with no header. The first column should
# be the strain and the second column should be the phenotype value.
#
# The p-values are calculated with the hybrid method to save time.
#

library(data.table)
library(CompQuadForm)
library(doParallel)
library(Rcpp)
library(RcppArmadillo)
library(RcppParallel)
library(optparse)

optlist = list(make_option('--output'),
               make_option('--maf', type='double', default=0.05),
               make_option('--extract'))
opts = parse_args(OptionParser(option_list=optlist),
                  positional_arguments=TRUE)
mapit_dir = opts[['args']][1]
geno_file = opts[['args']][2]
pheno_file = opts[['args']][3]
outprefix = opts[['options']][['output']]
min_maf = opts[['options']][['maf']]
extract_file = opts[['options']][['extract']]

source(file.path(mapit_dir, 'MAPIT.R'))
sourceCpp(file.path(mapit_dir, 'MAPIT.cpp'))
source(file.path(mapit_dir, 'QQPlot.R'))

## Genotypes and minor allele frequency filtering
genos = fread(geno_file, header=TRUE)
X = as.matrix(genos[, -(1:3)])
rownames(X) = genos[['rs']]

if(!is.null(extract_file)) {
    var_list = scan(extract_file, what='character')
    var_list = var_list[var_list %in% rownames(X)]
    X = X[var_list, ]
}

maf = apply(X, 1, function(x) {
            af = sum(x, na.rm=TRUE) / sum(!is.na(x))
            if(af > 0.5) {
                1-af
            } else {
                af
            }
})

X = X[maf >= min_maf, ]

X_imp = t(apply(X, 1, function(x) {
                m = mean(x, na.rm=TRUE)
                ifelse(is.na(x), m, x)
}))

## Phenotypes
phenos = read.csv(pheno_file, sep='\t', header=FALSE, as.is=TRUE,
                  colClasses=c('character', 'numeric'))
rownames(phenos) = phenos[, 1]
Y = phenos[as.character(colnames(X_imp)), 2]

## Get rid of individuals with missing data
X_filt = X_imp[, !is.na(Y)]
Y_filt = Y[!is.na(Y)]

cat('Running MAPIT\n', file=stderr())

## Run mapit with Davie's method for calculating p-values
mapit = MAPIT(X_filt, Y_filt, hybrid=TRUE)

## Write output files
#png(paste0(outprefix,'.qqplots.png'))
#ggd.qqplot(mapit[['pvalues']])

write.table(data.frame('rs'=rownames(X_filt),
                       'p'=mapit[['pvalues']],
                       'pve'=mapit[['pves']]),
            file=paste0(outprefix, '.tsv'),
            sep='\t', col.names=TRUE, row.names=FALSE, quote=FALSE)


out_file = 'output'
pdf('output.inner_distance_plot.pdf')
fragsize=rep(c(-248,-243,-238,-233,-228,-223,-218,-213,-208,-203,-198,-193,-188,-183,-178,-173,-168,-163,-158,-153,-148,-143,-138,-133,-128,-123,-118,-113,-108,-103,-98,-93,-88,-83,-78,-73,-68,-63,-58,-53,-48,-43,-38,-33,-28,-23,-18,-13,-8,-3,2,7,12,17,22,27,32,37,42,47,52,57,62,67,72,77,82,87,92,97,102,107,112,117,122,127,132,137,142,147,152,157,162,167,172,177,182,187,192,197,202,207,212,217,222,227,232,237,242,247),times=c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,1,0,1,0,0,2,0,0,2,0,0,0,1,0,1,1,0,0,0,1,0,0,0,0,0,0,0,0,1,0,0,1,0,1,0,0,0,0,0,0,0,1,0,1,1,0,1,0,1,0,0,0))
frag_sd = sd(fragsize)
frag_mean = mean(fragsize)
frag_median = median(fragsize)
write(x=c("Name","Mean","Median","sd"), sep="	", file=stdout(),ncolumns=4)
write(c(out_file,frag_mean,frag_median,frag_sd),sep="	", file=stdout(),ncolumns=4)
hist(fragsize,probability=T,breaks=100,xlab="mRNA insert size (bp)",main=paste(c("Mean=",frag_mean,";","SD=",frag_sd),collapse=""),border="blue")
lines(density(fragsize,bw=10),col='red')
dev.off()


# Creating the Cancha Classifier
library(readr)
library (dplyr)
library (tidyr)
library(caret)
library(ggplot2)

# Import the synthesized data

cantcha <- read_csv("data/Cantcha Data Gather (Responses) - Form Responses 1.csv")

#EDA of full dataset
df <- cantcha
names(df)
colnames(df) <- c("Timestamp",  "Photo", "Drink_name", "Colour", "Cartoony", "Fonts", "Informative", "Impression" ,"label")
dim (df)
str(df)
summary(df)

#row names
names(df)

df$label <- as.factor(df$label)

#how many classes - and what are they?
num_class <- length(unique(df$label))
uniqueClasses <- as.factor(unique(df$label))
cat("There are ", num_class, "unique classes, which are", uniqueClasses)

#class distribution
classDis<- as.data.frame(table(df$label))
names(classDis) <- c("label","count")
classDis
barplot(classDis)

#check that they all add up
sr <- sum(classDis$count)
nr <- nrow(df)
cat("The total of each class add up to the whole number of rows?",sr==nr )

# list all observations for missing values
sapply(df, function(x) sum(is.na(x)))

#change for the sample percentage (tested at 0.1, 1.0, and 0.5)
sample_pc <- 0.5
df_pc <- df[sample(nrow(df), nrow(df) * sample_pc / 100), ]
nrow(df_pc)

barplot(df$label, col = df$label)

#<begin>=====================================
# Dump redundant columns & shift class to the end column as 'label'

drop.cols <- c('Timestamp', 'Photo', "Drink_name", "Impression")
reduced <- df %>% select(-one_of(drop.cols))

#<end>=====================================

# test three algorithms

ctrl <- trainControl(method="repeatedcv", number=10, repeats=3)
# tested c5.0, SVM and KNN - with C5.0 performing on traning set best.
#C5.0Tree
set.seed(1)
mod.c5Tree <- train(label~., data=reduced, method="C5.0Tree", trControl=ctrl)
# svmRadial
set.seed(1)
mod.svm <- train(label~., data=reduced, method="svmRadial", trControl=ctrl)
# kNN
set.seed(1)
mod.knn <- train(label~., data=reduced, method="knn", trControl=ctrl)

# collect resamples
results <- resamples(list(C5.0Tree=mod.c5Tree, svm=mod.svm, kNN=mod.knn))

scales <- list(x=list(relation="free"), y=list(relation= "free"))
dotplot(results, scales=scales, conf.level = 0.99)

# outcome
# SVM delivers best performance
#========================================
# now tune the model
library(caret)
library(kernlab)
library(mlbench)
fitControl <- trainControl(method = "repeatedcv",
                           number = 10,
                           repeats = 10, returnResamp="all")
# Choose the features and classes

grid <- grid <- expand.grid(sigma = c(.01, .015, 0.2),
                            C = c(0.75, 0.9, 1, 1.1, 1.25))
mdl <- train(x=reduced[-5],
             y= reduced$label,
             method = "svmRadial",
             tuneGrid = grid,
             summaryFunction=twoClassSummary,	# Use AUC to pick the best model
             classProbs=TRUE,
             trControl=ctrl)
mdl
#show which attributes were most used

summary(mdl$finalModel)
summary(mdl$results)

# Tuning parameter 'model' was held constant at a value of tree
# Accuracy was used to select the optimal model using  the largest value.
# The final values used for the model were trials = 20, model = tree and winnow = FALSE.

# Testing the previous model on the testing set
TestRes <- predict(mdl, newdata = reduced[,-5], type="raw")
confusionMatrix(TestRes, reduced$label)

################################
# Set impression as the label  #
################################
drop.cols <- c('Timestamp', 'Photo', "Drink_name", "label")
reduced.1 <- df %>% select(-one_of(drop.cols))
reduced.1$Impression <- as.factor(reduced.1$Impression)
levels(reduced.1$Impression) <- c( "Clearly Alcohol",  "Clearly non-alcoholic", "Probably Alcohol", "Probably non-alcoholic", "Really can't tell" )

barplot(reduced.1$Impression)
# test three algorithms

ctrl <- trainControl(method="repeatedcv", number=10, repeats=3)
# tested c5.0, SVM and KNN - with C5.0 performing on traning set best.
#C5.0Tree
set.seed(1)
mod.c5Tree <- train(Impression~., data=reduced.1, method="C5.0Tree", trControl=ctrl)
# svmRadial
set.seed(1)
mod.svm <- train(Impression~., data=reduced.1, method="svmRadial", trControl=ctrl)
# kNN
set.seed(1)
mod.knn <- train(Impression~., data=reduced.1, method="knn", trControl=ctrl)

# collect resamples
results <- resamples(list(C5.0Tree=mod.c5Tree, svm=mod.svm, kNN=mod.knn))

scales <- list(x=list(relation="free"), y=list(relation= "free"))
dotplot(results, scales=scales, conf.level = 0.99)

pairs(reduced)

fitControl <- trainControl(method = "repeatedcv",
                           number = 10,
                           repeats = 10, returnResamp="all")
# Choose the features and classes

grid <- grid <- expand.grid(sigma = c(.01, .015, 0.2),
                            C = c(0.75, 0.9, 1, 1.1, 1.25))
mdl <- train(x=reduced.1[-5],
             y= reduced.1$Impression,
             method = "svmRadial",
             tuneGrid = grid,
             trControl=ctrl)
mdl
#show which attributes were most used

summary(mdl$finalModel)
summary(mdl$results)

# Tuning parameter 'model' was held constant at a value of tree
# Accuracy was used to select the optimal model using  the largest value.
# The final values used for the model were trials = 20, model = tree and winnow = FALSE.

# Testing the previous model on the testing set
TestRes <- predict(mdl, newdata = reduced.1[,-5], type="raw")
confusionMatrix(TestRes, reduced.1$Impression)
table(TestRes, reduced.1$Impression)


#' plot_reg
#'
#' function
#' @param lm a linear model
#' @param x character, predictor
#' @param ... extra arguments passed to plot
#' @export

plot_reg <- function(lm, x = NULL, ...) {
  function_call = match.call()
  form = as.formula(lm$call$formula)
  outcome = as.character(form[2])
  args <- list(...)

  if (is.null(x)) {
    split = function(x, split) trimws(strsplit(x, split = split)[[1]][1])

    pred = split(as.character(form[3]), split = "\\+")
    pred =  split(pred, "\\*")
    pred =  split(pred, "\\:")
    pred =  split(pred, "\\-")

  } else{
    pred = function_call$x
  }

  call  <-
    list(formula = as.formula(glue::glue("{outcome} ~ {pred}")),
         data = lm$call$data)
  if(length(args) > 0){
  call = append(call, args)
  }

  coefs = coef(lm)

  intercept <- coefs[grepl("intercept", names(coefs), ignore.case = T)]
  intercept <- ifelse(length(intercept) == 0, 0 , intercept)
  slope = coefs[names(coefs) == pred]

  do.call(plot, call)

  abline(a = intercept, b = slope)

}


deck <- read.csv('https://github.com/gumdropsteve/datasets/raw/master/deck.csv')

# assign deck to Blackjack dataframe
Blackjack <- deck
View(Blackjack)

# assign facecards the value of 10
facecard <- c('king', "queen", 'jack')
Blackjack$value[Blackjack$face %in% facecard]
Blackjack[Blackjack$face %in% facecard, ]
Blackjack$value[Blackjack$face %in% facecard] <- 10

# assign aces the value of NA
Blackjack$value[Blackjack$face == "ace"] <- NA
View(Blackjack)

# sreate dearts deck
Hearts <- deck
Hearts$value <- 0
View(Hearts)
Hearts$value[Hearts$suit == "hearts"] <- 1
Hearts$value[Hearts$suit == "spades" & Hearts$face == 'queen'] <- 13

# create deck2
deck2 <- deck
deck2$order <- 1:52

# shuffle3() creates a new shuffled deck
shuffle3<- function(curr_deck){
  mixer<- sample(1:52, size=52)
  curr_deck<- curr_deck[mixer, ]
  View(curr_deck)
}

# shuffle4() creates a new shuffled deck and assigns it to the global "deck"
shuffle4 <- function(curr_deck){
  mixer <- sample(1:52, size=52)
  curr_deck <- curr_deck[mixer, ]
  assign("deck", curr_deck[-1, ], envir=globalenv())
}

# deal two players from hearts deck.
deal_hearts <- function() {
  playhearts <- shuffle4(Hearts)
  h_player1 <- head(playhearts, 13)
  h_player2 <- tail(playhearts, 13)
  print("----Hearts player1----")
  print(h_player1)
  print("----Hearts player2----")
  print(h_player2)
}

# deal two players & dealer from blackjack deck.
deal_jacks <- function() {
  playjacks <- shuffle4(Blackjack)
  j_player1 <- head(playjacks, 2)
  j_player2 <- tail(playjacks, 2)
  dealer <- playjacks[c(10:11), 1:3]
  print("----Blackjack player1----")
  print(j_player1)
  print("----Blackjack player2----")
  print(j_player2)
  print("----Blackjack dealer----")
  print(dealer)
}

deal_jacks()


library(tidyverse)
library(dslabs)
data(murders)

murders %>%
  ggplot(aes(population, total, label = abb, color = region)) + geom_label()


library(foreign)
library(stringr)
library(plyr)
library(reshape2)
source("xtable.r")

# Data from http://pewforum.org/Datasets/Dataset-Download.aspx

# Load data -----------------------------------------------------------------

pew <- read.spss("pew.sav")
pew <- as.data.frame(pew)

religion <- pew[c("q16", "reltrad", "income")]
religion$reltrad <- as.character(religion$reltrad)
religion$reltrad <- str_replace(religion$reltrad, " Churches", "")
religion$reltrad <- str_replace(religion$reltrad, " Protestant", " Prot")
religion$reltrad[religion$q16 == " Atheist (do not believe in God) "] <- "Atheist"
religion$reltrad[religion$q16 == " Agnostic (not sure if there is a God) "] <- "Agnostic"
religion$reltrad <- str_trim(religion$reltrad)
religion$reltrad <- str_replace_all(religion$reltrad, " \\(.*?\\)", "")

religion$income <- c("Less than $10,000" = "<$10k",
  "10 to under $20,000" = "$10-20k",
  "20 to under $30,000" = "$20-30k",
  "30 to under $40,000" = "$30-40k",
  "40 to under $50,000" = "$40-50k",
  "50 to under $75,000" = "$50-75k",
  "75 to under $100,000" = "$75-100k",
  "100 to under $150,000" = "$100-150k",
  "$150,000 or more" = ">150k",
  "Don't know/Refused (VOL)" = "Don't know/refused")[religion$income]

religion$income <- factor(religion$income, levels = c("<$10k", "$10-20k", "$20-30k", "$30-40k", "$40-50k", "$50-75k",
  "$75-100k", "$100-150k", ">150k", "Don't know/refused"))

counts <- count(religion, c("reltrad", "income"))
names(counts)[1] <- "religion"

xtable(counts[1:10, ], file = "pew-clean.tex")

# Convert into the form in which I originally saw it -------------------------

raw <- dcast(counts, religion ~ income)
#pewraw<-raw[1:10, 1:10]
write.csv(raw, file = "pew-raw.csv")
#xtable(raw[1:10, 1:7], file = "pew-raw.tex")


#' Generate surrogate variables using the ewaff.sites syntax
#'
#' Provide a function to manually compute surrogate variables, using
#' the same syntax for submission of a ewaff.sites call
#'
#' Note: surrogate variables are computed using \code{\link{sva}}
#'
#' @param formula An object of class \code{\link{formula}}:
#' a symbolic description of the model to be fitted.
#' DNA methylation is referred to by the variable name 'methylation'.
#' @param methylation DNA methylation matrix, one row per CpG site,
#' one column per sample.
#' @param variable.of.interest Name of variable in the GLM model formula
#' for which to save summary statistics.
#' @param data Data frame providing variables referenced in model formula.
#' @param family (Default: gaussian).
#' @param n.sv Number of surrogate variables to compute (Default: 10).
#' @param most.variable Generate surrogate variables from the
#' given most variable CpG sites rather than the whole matrix (Default: NULL).
#' @param random.subset Generate surrogate variables from the
#' given percentage of randomly selected CpG sites rather than the whole matrix (Default: 0.05, i.e. 5 percent).
#' @param algorithm Algorithm to use, either "sva" or "smartsva" (Default: "sva").
#' @return Matrix containing surrogate variables computed
#'
#' @export
ewaff.sva <- function(formula,
                      variable.of.interest,
                      methylation,
                      data,
                      family=gaussian,
                      n.sv=10,
                      most.variable=NULL,
                      random.subset=0.05,
                      algorithm="sva",
                      ...) {
    design <- build.design.matrix(formula=formula,
                                  variable.of.interest=variable.of.interest,
                                  methylation=methylation,
                                  data=data,
                                  family=family,
                                  method="glm",
                                  generate.confounders=algorithm,
                                  n.confounders=n.sv,
                                  most.variable=most.variable,
                                  random.subset=random.subset,
                                  ...)$matrix
    design[,grep("^sv[0-9]+", colnames(design)),drop=F]
}


#' ms2mph
#'
#' Conversion speed from meter per second to knots.
#'
#' @param numeric  ms Speed in meter per second.
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  ms2mph
#'
#' @export
#'
#'
#'
#'

ms2mph<-function(ms)
{
  return (ms * 2.23694);
}


library(terra)
library(sf)
sf::sf_use_s2(FALSE)

#ne_bd = rast("data/HYP_50M_SR_W/HYP_50M_SR_W.tif")
ne_bd = rast("data/HYP_HR_SR_W/HYP_HR_SR_W.tif")

cb = st_read("data/ne_10m_admin_0_countries/ne_10m_admin_0_countries.shp")
ext = raster::extent(c(-12, 30, 35, 60))
cb = st_crop(cb, ext)
ne_bd = crop(ne_bd, ext)

neretva = st_read("neretva_rn/output/neretva_sm.gpkg")
st_crs(neretva) = 3035

ne_bd = project(ne_bd,"epsg:3035")
RGB(ne_bd) = 1:3
cb = st_transform(cb, 3035)

box = as.vector(ext(neretva)) + c(-1, 1, -1, 1)*10000
jpeg(file="docs/img/europe_map.jpg", width=2000, height=1800, bg="transparent")
terra::plot(ne_bd, maxcell = ncell(ne_bd))
plot(st_geometry(cb), add=TRUE, col="#00000000", border = "#333333aa", lwd=0.5)
rect(box[1], box[3], box[2], box[4], lwd=2)
text(box[2], box[4], "Neretva", pos=4, offset = 0.2, cex=3)
plot(st_geometry(neretva), add=TRUE, col="blue")
dev.off()


#' Network plotting function
#'
#' This function plots traffic networks, where the relative locations of nodes are meaningful (unlike conceptual networks).
#' @param nodes.x Vector of x-coordinates for node locations
#' @param nodes.y Vector of y-coordinates for node locations
#' @param link.node.matrix Two column matrix specifying nodes of origin and destination for each link
#' @param radius Radius of circles marking node locations. Defaults to 0.5.
#' @param link.sep Angular separation (as a fraction of pi radians) of entry/exit positions of bi-directional links. Defaults to 1/12.
#' @param link.label.offset Controls position of link labels relative to link. Detauls to 0.4.
#' @param LABEL.CEX Character expansion factor for link labels. Defaults to 1.
#' @param ARROW.LENGTH Controls length of arrow heads. Defaults to 0.4.
#' @param ARR.TYPE Controls appearance of arrow heads in Arrows function. Defaults to "triangle".
#' @param node.label Label nodes? Defaults to TRUE.
#' @param LINK.LABEL Label links? Defaults to TRUE.
#' @param RightAbove Further control for link label positions. Defaults to FALSE, which means that labels appear to left looking in direction of arrows. If TRUE, labels appear to the left/above links.
#' @return Produces a plot of the network
#' @keywords network plotting
#' @export
#' @examples
#' nodes.x <- c(2,7,12,2,7,12)
#' nodes.y <- c(7,7,7,2,2,2)
#' link.node.matrix <- rbind(c(1,2),c(1,4),c(2,5),c(3,2),c(3,6),c(4,5),c(6,5))
#' plotnet(nodes.x,nodes.y,link.node.matrix,ARROW.LENGTH=0.3,link.sep=0,radius=0.7,RightAbove=T)

plotnet <- function(nodes.x,nodes.y,link.node.matrix,radius=1/2,link.sep=1/12,link.label.offset=0.4,LABEL.CEX=1,ARROW.LENGTH=0.4,ARR.TYPE="triangle",node.label=TRUE,LINK.LABEL=TRUE,RightAbove=F){
  require(shape)
  n.nodes <- length(nodes.x)
  n.links <- nrow(link.node.matrix)
  if (length(link.sep) < n.links) link.sep <- rep(link.sep,length=n.links)
  plot(0,0,xlim=c(min(nodes.x)-radius,max(nodes.x)+radius),ylim=c(min(nodes.y)-radius,max(nodes.y)+radius),type="n",axes=F,xlab="",ylab="")
  symbols(nodes.x,nodes.y,circles=rep(radius,n.nodes),add=T,inches=FALSE,lwd=2)
  if (node.label) text(nodes.x,nodes.y,as.character(1:n.nodes),cex=LABEL.CEX,font=2)
  for (i in 1:n.links){
    from.node <- link.node.matrix[i,1]
    to.node <- link.node.matrix[i,2]
    from.x <- nodes.x[from.node]
    from.y <- nodes.y[from.node]
    to.x <- nodes.x[to.node]
    to.y <- nodes.y[to.node]

    theta <- atan2((to.y-from.y),(to.x-from.x))

    theta1 <- theta + pi*link.sep[i]
    theta2 <- theta - pi*link.sep[i]

    y1 <- from.y + radius*1.1*sin(theta1)
    y2 <- to.y - radius*1.1*sin(theta2)
    x1 <- from.x + radius*1.1*cos(theta1)
    x2 <- to.x - radius*1.1*cos(theta2)

    Arrows(x1,y1,x2,y2,lwd=1,arr.adj=1,arr.length=ARROW.LENGTH,arr.type=ARR.TYPE)

    if (LINK.LABEL) {
      if (!RightAbove){
        x.pos <- (x1+x2)/2-link.label.offset*sin(theta1)
        y.pos <- (y1+y2)/2+link.label.offset*cos(theta2)
      }
      if (RightAbove){
        x.pos <- (x1+x2)/2+abs(link.label.offset*sin(theta1))
        y.pos <- (y1+y2)/2+abs(link.label.offset*cos(theta2))
      }
      text(x.pos,y.pos,as.character(i),cex=LABEL.CEX,font=1)
    }
  }
}


#requires R package Rcpp, calling compiled cpp code from R
library(Rcpp)

#load the compiled cpp dynamic link library
dyn.load('R_ExaLT.so');

#call the function, named 'R_FPTAS', with 2 arguments, 1. table data file name, 2, column
.Call('R_ExaLT', 'minimal_example_R.txt', 'HIPK2')


filename <- "graph-needle-node-forces.txt"

plotforce <- function () {
   tab <-read.table ("graph-needle-node-forces.txt")
   refx <- t(tab[1])
   defx <- t(tab[2])
   force <- t(tab[3])
   avgforce <- ((c(force,0) + c(0,force)) * 0.5) [-1]
   fix <- t(tab[4])
   plot (defx[-1], force[-1] / (defx[-1] - defx[-length (defx)]), type="l",
         ylab="Needle force [N/m]",
         xlab="Deformed coordinates [m]"
         )
}

plotnodforce <- function () {
   tab <-read.table ("graph-needle-node-forces.txt")
   refx <- t(tab[1])
   defx <- t(tab[2])
   force <- t(tab[3])
   avgforce <- ((c(force,0) + c(0,force)) * 0.5) [-1]
   fix <- t(tab[4])
   plot (refx, force, type="l",
         ylab="Nodal force [N]",
         xlab="Reference coordinates [m]"
         )
}

plotavforce <- function () {
   tab <-read.table ("graph-needle-node-forces.txt")
   refx <- t(tab[1])
   defx <- t(tab[2])
   force <- t(tab[3])
   avgforce <- ((c(force,0) + c(0,force)) * 0.5) [-1]
   fix <- t(tab[4])
   plot (refx[-1], force[-1] / (defx[-1] - defx[-length (defx)]), type="l",
         ylab="Needle force [N/m]",
         xlab="Reference coordinate [m]"
         )
}

plotrefforce <- function () {
   tab <-read.table ("graph-needle-node-forces.txt")
   refx <- t(tab[1])
   defx <- t(tab[2])
   force <- t(tab[3])
   avgforce <- ((c(force,0) + c(0,force)) * 0.5) [-1]
   fix <- t(tab[4])
   plot (refx[-1], force[-1] / (defx[-1] - defx[-length (defx)]), type="l",
         ylab="Needle force [N/m]",
         xlab="Reference coordinate [m]"
         )
}


catToBin <- function(data) {
  bin.names <- levels(data)
  bin.data <- matrix(0, nrow=length(data), ncol=length(bin.names))
  for(idx in 1:length(data)){
    col.idx <- which(bin.names == data[idx])
    bin.data[idx,col.idx] <- 1
  }

  bin.data <- data.frame(bin.data)
  colnames(bin.data) <- bin.names

  return(bin.data)
}


include	defs

# ctoi - convert string at in(i) to integer, increment i

   integer function ctoi(in, i)
   character in (ARB)
   integer i

   integer d
   external index
   integer index

   # string digits "0123456789"
   character digits(11)
   data digits (1) /DIG0/,
      digits (2) /DIG1/,
      digits (3) /DIG2/,
      digits (4) /DIG3/,
      digits (5) /DIG4/,
      digits (6) /DIG5/,
      digits (7) /DIG6/,
      digits (8) /DIG7/,
      digits (9) /DIG8/,
      digits (10) /DIG9/,
      digits (11) /EOS/

   while (in (i) == BLANK | in (i) == TAB)
      i = i + 1
   for (ctoi = 0; in (i) != EOS; i = i + 1) {
      d = index (digits, in (i))
      if (d == 0)      # non-digit
	 break
      ctoi = 10 * ctoi + d - 1
      }

   return
   end


model_snowdepthtrans <- function (Sdepth = 0.0,
         Pns = 100.0){
    #'- Name: SnowDepthTrans -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: snow cover depth conversion
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: snow cover depth in cm
    #'- inputs:
    #'            * name: Sdepth
    #'                          ** description : snow cover depth Calculation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : m
    #'                          ** uri :
    #'            * name: Pns
    #'                          ** description : density of the new snow
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 100.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : cm/m
    #'                          ** uri :
    #'- outputs:
    #'            * name: Sdepth_cm
    #'                          ** description : snow cover depth in cm
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : cm
    #'                          ** uri :
    Sdepth_cm <- Sdepth * Pns
    return (list('Sdepth_cm' = Sdepth_cm))
}


rm(list = ls())
setwd("/home/csr2/gvcm_phone")
library(splines)
library(splines2)
library(Matrix)
library(nlme)
library(mgcv)
library(fda)
library(foreach)
library(iterators)
library(parallel)
library(doParallel)
library(modelr)

source('preparefunction_2.R')
#初值估计
ddata<-d9reorder
K_F = 5; nk0 = 5; CV_pre_gm<-list();DATA<-list();gm1<-list()
hType=2;h=c(0.5,0.5,0.5);NORM=3
set.seed(3)
split_K <- crossv_kfold(data.frame(cbind(ddata$X,ddata$U,ddata$Y)),k = K_F);
re = list();Sgm = list(); train_data = list(); test_data = list()
for(k in 1:K_F){
 index = split_K$train[[k]]$idx;len <- length(index);index_test = split_K$test[[k]]$idx
 test_data[[k]] <-list(X=ddata$X[index_test,],U=ddata$U[index_test],Y=ddata$Y[index_test])
 train_data[[k]] <- list(X=ddata$X[index,],U=ddata$U[index],Y=ddata$Y[index])
#interpolate to compute inital parameter
 inital.par <- weight.sp.fit(k,nk0)
 Sgm[[k]] <- data.frame(beta = inital.par[[1]], m =inital.par[[2]], dm = inital.par[[3]])
  print(k)
  k = k+1
 }
DATA = train_data;gm1 <- Sgm;
#dput(gm1,"/home/csr2/gvcm_phone/initial estimater by splines");
cl.cores <- detectCores()
numWorkers=K_F
cl <- makeCluster(numWorkers)
registerDoParallel(cl)
# choose spline as inital parameter into kernel repeat one step.
re <- foreach(iter=1:K_F,.packages=c('foreach','parallel')) %dopar% calculate_gvcm_parallel(iter)
stopCluster(cl)
stopImplicitCluster()
#dput(re,"/home/csr2/gvcm_phone/mcv_5k_seed_3_re_h0.27_norm3_sp")
pred_error_test=matrix(NA,K_F,1);pred_error_train=matrix(NA,K_F,1);P <- ncol(ddata$X)
for(k in 1:K_F){
len1 <- length(test_data[[k]]$U);TBeta <- matrix(NA,len1,P);TG <- matrix(NA,len1,1)
for(p in 1:P){TBeta[,p]<-approx(train_data[[k]]$U,re[[k]][,p],xout=test_data[[k]]$U,rule=2)$y}
TG = approx(rowSums(train_data[[k]]$X*re[[k]][,1:P]),re[[k]][,P+1],xout=rowSums(test_data[[k]]$X*TBeta),rule=2)$y
pred_error_train[k,] = mean(sapply(re[[k]][,P+1]-train_data[[k]]$Y,function(x) abs(x)),na.rm = TRUE)
pred_error_test[k,] = mean(sapply(TG-test_data[[k]]$Y,function(x) abs(x)),na.rm = TRUE)
k = k+1
print(k)
}
avg_pre_error_train= mean(pred_error_train)
avg_pre_error_test = mean(pred_error_test)
avg_pre_error_train
avg_pre_error_test
#save.image(file='gmcv_5k_seed_3.Rdata_h0.27_norm3_sp')

#DATA[[1]] = list(X = ddata$X[1:10000,],U=as.matrix(ddata$U[1:10000]),Y = ddata$Y[1:10000])
#gm0<-ini.fit(DATA[[1]],3,1);dput(gm0,"/home/stu1/gvcm_phone/initial estimater d9reorder");P=ncol(gm0[,1:(ncol(gm0)-2)]);N=nrow(gm0)
#gm0<-dget("/home/csr5/gvcm phone/result/initial estimater d9reorder");P=ncol(gm0[,1:(ncol(gm0)-2)]);N=nrow(gm0)
#par(mfrow=c(2,P+1)); for(i in 1:P){plot(d12$U,gm0[,i])}; plot(rowSums(gm0[,1:P]*d12$X),gm0[,1+P])


#Regression test download data against country metrics
downloadregression <- function(con){
    require(car)
    downdata <-dbReadTable(con,"Metrics2012wAkamai")
    #Scatterplot is diagnostic
    scatterplotMatrix(downdata[-(1:4)])
    #do I need to do more sophisticated analysis considering interaction between variables?
    lmresult <-lm(downbypop ~ economy+income+akaverage+akbroadband,downdata)
    capture.output(lmresult,of="download-regression.txt")
    par(mfrow=c(2,2))
    plot(lmresult)
    #todo: save useful plot

}

exploreprojections <- function(){
    require(maps)
    require(mapproj)
    require(rgdal)
    require(RSQLite)
    require(reshape)
    require(RColorBrewer)
    ne <- readOGR("osgeolivedata.sqlite","mapcountriesT",disambiguateFIDs=TRUE)

}

spatialauto <- function(){
    require(cshapes)
    require(psData)
    #load countries
    countrylist <- cshp(date=as.Date("2012-6-30"),useGW=TRUE)
    #make a neighborlist, warning this is CPU resource intensive
    countrynb <-distlist(date=as.Date("2012-6-30"),useGW=TRUE,type="mindist",tolerance=0.1)
    #swap in the ISO1AL2 country codes
    #match the country codes to data for correlation test

    #calculate spatial-autocorrelation

    #download polity IV database of governments, save to db
}

# Multiple plot function
# http://www.cookbook-r.com/Graphs/Multiple_graphs_on_one_page_%28ggplot2%29/
# ggplot objects can be passed in ..., or to plotlist (as a list of ggplot objects)
# - cols:   Number of columns in layout
# - layout: A matrix specifying the layout. If present, 'cols' is ignored.
#
# If the layout is something like matrix(c(1,2,3,3), nrow=2, byrow=TRUE),
# then plot 1 will go in the upper left, 2 will go in the upper right, and
# 3 will go all the way across the bottom.
#
multiplot <- function(..., plotlist=NULL, file, cols=1, layout=NULL) {
  require(grid)

  # Make a list from the ... arguments and plotlist
  plots <- c(list(...), plotlist)

  numPlots = length(plots)

  # If layout is NULL, then use 'cols' to determine layout
  if (is.null(layout)) {
    # Make the panel
    # ncol: Number of columns of plots
    # nrow: Number of rows needed, calculated from # of cols
    layout <- matrix(seq(1, cols * ceiling(numPlots/cols)),
                    ncol = cols, nrow = ceiling(numPlots/cols))
  }

 if (numPlots==1) {
    print(plots[[1]])

  } else {
    # Set up the page
    grid.newpage()
    pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout))))

    # Make each plot, in the correct location
    for (i in 1:numPlots) {
      # Get the i,j matrix positions of the regions that contain this subplot
      matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE))

      print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row,
                                      layout.pos.col = matchidx$col))
    }
  }
}


path <- '/home/maanitou/programming/fsharp/rufc/Samples/schrodinger/'

content_f <- read.table(paste(path, 'output_schrodinger_forward.txt', sep=""))
content_b <- read.table(paste(path, 'output_schrodinger_backward.txt', sep=""))

factor <- 1000000

Xf <- sapply(content_f, function(x) as.numeric(x)/factor)
Xb <- sapply(content_b, function(x) as.numeric(x)/factor)

par(mfrow=c(1,1))

plot(1:128, Xf[1,], type='l',  xlim=c(0,256), ylim=c(min(Xf),max(Xf)))
lines(1:128, Xf[2,], type='l')
lines(129:256, Xb[1,], type='l')
lines(129:256, Xb[2,], type='l')

for (i in 0:(nrow(Xf)/2-1)) {
  lines(1:128, Xf[2*i+1,], type='l', col='red', xlim=c(0,256), ylim=c(min(Xf),max(Xf)))
  lines(1:128, Xf[2*i+2,], type='l', col='black')
  lines(129:256, Xb[2*i+1,], type='l', col='red')
  lines(129:256, Xb[2*i+2,], type='l', col='black')
  #Sys.sleep(1)
}

#pdf(file="/home/maanitou/Desktop/PAT_2021/project/schrodinger.pdf", width=8, height=4)
par(mfrow=c(3,4), oma=c(0,0,0,0), mar=c(.5,.5,.5,.5))
  for (i in c(seq(0,999,91),999)) {
  #for (i in c(seq(0,4999,455),4999)) {
  #for (i in c(seq(0,1999,182),1999)) {
  plot(1:128, Xf[2*i+1,], type='l', col='black',
    xlim=c(0,256), ylim=c(min(Xf),max(Xf)),
    xlab="", ylab="", xaxt='n', yaxt='n')
  lines(1:128, Xf[2*i+2,], type='l', col='red')
  lines(129:256, Xb[2*i+1,], type='l', col='red')
  lines(129:256, Xb[2*i+2,], type='l', col='black')
  abline(v=128, lty=2)
}
#dev.off()


#' Standard SR plot with Beverton-Holt curve
#'
#' Scatterplot of SSB, R with underlying stock recruitment relationship (SR fit line ends at (S0, R0)).
#' @param asap name of the variable that read in the asap.rdat file
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotSRpredLine <- function(asap,save.plots,od,plotf){
  par(mfrow=c(1,1) )

  a<- asap$SR.parms$SR.alpha
  b<- asap$SR.parms$SR.beta
  S0.yr <- asap$SR.annual.parms[,2]
  ssb <- asap$SSB
  recr <- asap$N.age[,1]
  years <- seq(asap$parms$styr, asap$parms$endyr)
  nyears <- length(years)
  SR <- matrix(NA, (nyears-1), 3)
  SR[,1] <- years[1:(nyears-1)]
  SR[,2] <- ssb[1:(nyears-1)]
  SR[,3] <- recr[2:nyears]

  seq.ssb= seq(0, S0.yr[nyears], length.out=300)
  pred.r = a*seq.ssb/(b+seq.ssb)

  plot( SR[,2], SR[,3], type='p', col='black', pch=19,
        xlab="SSB (mt)", ylab="Recruits (000s)",
        ylim=c(0, 1.1*max(c(SR[,3], pred.r), na.rm=TRUE)),
        xlim=c(0, 1.1*max(SR[,2], S0.yr[nyears], na.rm=TRUE))  )

  lines(seq.ssb , pred.r,  col='red', lwd=2)

  if (save.plots==T) savePlot(paste0(od, "S_R.Pred.Line.",plotf), type=plotf)
  return()
}   # end function


#Rscript

################################################
##    Link between variables and themselves   ##
################################################

#####Packages : ggplot2
#               Cowplot
#               Car
#               faraway
#               dplyr
#               GGally
#               FactoMiner
#               factoextra
#               ggcorrplot

#####Load arguments

args <- commandArgs(trailingOnly = TRUE)

if (length(args) == 0) {
    stop("This tool needs at least one argument")
}else{
    table <- args[1]
    hr <- args[2]
    colli <- as.logical(args[3])
    vif <- as.logical(args[4])
    pca <- as.logical(args[5])
    interr <- as.logical(args[6])
    auto <- as.logical(args[7])
    spe <- as.numeric(args[8])
    col <- as.numeric(strsplit(args[9], ",")[[1]])
    var <- as.numeric(args[10])
    var2 <- as.numeric(args[11])
    var4 <- as.numeric(args[12])
}

if (hr == "false") {
  hr <- FALSE
}else{
  hr <- TRUE
}

if (length(col) == 1) {
stop("Please select two or more numerical columns")
}

#####Import data
data <- read.table(table, sep = "\t", dec = ".", header = hr, fill = TRUE, encoding = "UTF-8")
if (vif | pca) {
data_active <- data[col]
#Define the active individuals and the active variables for the PCA
}

if (colli | interr) {
colspe <- colnames(data)[spe]
}

if (colli) {
data_num <- data[col]
data_num$species <- data[, spe]
data_num <- data_num[grep("^$", data_num$spe, invert = TRUE), ]
}

if (interr | auto) {
colvar <- colnames(data)[var]
}

if (interr) {
colvar2 <- colnames(data)[var2]
colvar4 <- colnames(data)[var4]
}

#####Your analysis

####Independence of the observations####

acf_tb <- function(data, var) {
obj <- acf(data[, var], na.action = na.pass)
  return(obj)
}

acf_df <- function(data, var) {

tb <- data.frame(acf = acf_tb(data, var)$acf, lag = acf_tb(data, var)$lag)

  return(tb) # Lag: intervalle temporel entre mesures, fréquence à laquelle on mesure l'auto corrélation.
# ACF: indépendance temporelle
}

autocorr <- function(var1, var2) {
  cat("\nACF\n", var2$acf, file = "acf.txt", fill = 1, append = TRUE)
  graph <- ggplot2::ggplot() +
  ggplot2::geom_bar(ggplot2::aes(x = var2$lag, y = var2$acf), stat = "identity", position = "identity", fill = "midnightblue") +
  ggplot2::geom_hline(mapping = ggplot2::aes(yintercept = qnorm((1 + 0.95) / 2) / sqrt(var1$n.used)),
             linetype = "dashed") + # calcul interval de confiance à 95% sans correction du bruit blanc.
  ggplot2::geom_hline(mapping = ggplot2::aes(yintercept = -qnorm((1 + 0.95) / 2) / sqrt(var1$n.used)), linetype = "dashed") + ggplot2::labs(title = "Autocorrelation") + ggplot2::xlab("lag") + ggplot2::ylab("acf")
  ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))

  ggplot2::ggsave("autocorrelation.png", graph)
}

####Interractions####

graph <- function(data, var1, var2, var3) {
  graph <- ggplot2::ggplot(data, ggplot2::aes_string(x = var1, y = var2, group = var3, color = var3)) +
  ggplot2::geom_point() +
  ggplot2::geom_smooth(method = lm, se = FALSE) +
  ggplot2::theme(plot.title = ggplot2::element_text(color = "black", size = 12, face = "bold"))

return(graph)
}

# Put multiple panels
interraction <- function(data, var1, var2, var3, var4) {
  cat("\nSpecies\n", spe, file = "Species.txt", fill = 1, append = TRUE)
  if (mult1) {
      for (spe in unique(data[, var3])) {
      data_cut <- data[data[, var3] == spe, ]
      mult_graph <- graph(data_cut, var1, var2, var3) + ggplot2::facet_grid(cols = ggplot2::vars(data_cut[, var4]), scales = "free") +
      cowplot::background_grid(major = "xy", minor = "none") +
      cowplot::panel_border() + ggplot2::ggtitle("Interactions")

      ggplot2::ggsave(paste("interaction_of_", spe, ".png"), mult_graph, width = 10, height = 7)
      }
    }else{
    mult_graph <- graph(data, var1, var2, var3) + ggplot2::facet_grid(rows = ggplot2::vars(data[, var3]), cols = ggplot2::vars(data[, var4]), scales = "free") +
    cowplot::background_grid(major = "xy", minor = "none") +
    cowplot::panel_border() + ggplot2::ggtitle("Interactions")

    ggplot2::ggsave("interraction.png", mult_graph)
  }
}

####Collinearity among covariates####
# Create the plots

coli <- function(data, var) {
  if (mult2) {
    cat("\nThere is not enough data on these species they appear too few times in the tabular-file\n", file = "Data.txt", fill = 1, append = TRUE)
    for (spe in unique(data$species)) {
      nb_spe <- sum(data$species == spe)
      if (nb_spe <= 2) {
      cat(spe, file = "Data.txt", fill = 1, append = TRUE)
      }else{
      data_cut <- data[data$species == spe, ]
      nb <- ncol(data_cut)
      data_num <- data_cut[, -nb]
      graph <- GGally::ggpairs(data_num, ggplot2::aes(color = data_cut$species),
      lower = list(continuous = "points"), axisLabels = "internal")

      ggplot2::ggsave(paste0("collinarity_of_", spe, ".png"), graph, width = 20, height = 15)
      }
  }

  }else{
    nb <- ncol(data)
    data_cut <- data[, -nb]
    graph <- GGally::ggpairs(data_cut, ggplot2::aes(color = data[, var]),
    lower = list(continuous = "points"), axisLabels = "internal") +
  ggplot2::scale_colour_manual(values = c("#00AFBB", "#E7B800", "#FC4E07")) +
  ggplot2::scale_fill_manual(values = c("#00AFBB", "#E7B800", "#FC4E07"))

  ggplot2::ggsave("collinarity.png", graph)
  }
}

####PCA method####

plot_pca <- function(data) {
  #Correlation circle
  graph_corr <- factoextra::fviz_pca_var(active_data(data), col.var = "cos2",
                           gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
                           repel = TRUE #Avoid text overlap
                           )
  ggplot2::ggsave("Pca_circle.png", graph_corr)
}

plot_qual <- function(data) {
  #PCA results for variables
  var <- factoextra::get_pca_var(active_data(data))

  #representation quality
  graph_quality <- ggcorrplot::ggcorrplot(var$cos2[!apply(var$cos2, 1, anyNA), ], method = "circle",
  ggtheme = ggplot2::theme_gray,
  colors = c("#00AFBB", "#E7B800", "#FC4E07"))

  ggplot2::ggsave("Pca_quality.png", graph_quality)
}

#### Variance inflation factor ####

myvif <- function(mod) {
  v <- vcov(mod)
  assign <- attributes(model.matrix(mod))$assign
  if (names(coefficients(mod)[1]) == "(Intercept)") {
    v <- v[-1, -1]
    assign <- assign[-1]
  } else warning("No intercept: vifs may not be sensible.")
  terms <- labels(terms(mod))
  n_terms <- length(terms)
  if (n_terms < 2) stop("The model contains fewer than 2 terms")
  if (length(assign) > dim(v)[1]) {
     diag(tmp_cor) <- 0
     if (any(tmp_cor == 1.0)) {
        return("Sample size is too small, 100% collinearity is present")
     } else {
        return("Sample size is too small")
     }
  }
  r <- cov2cor(v)
  detr <- det(r)
  result <- matrix(0, n_terms, 3)
  rownames(result) <- terms
  colnames(result) <- c("GVIF", "Df", "GVIF^(1/2Df)")
  for (term in 1:n_terms) {
    subs <- which(assign == term)
    result[term, 1] <- det(as.matrix(r[subs, subs])) * det(as.matrix(r[-subs, -subs])) / detr
    result[term, 2] <- length(subs)
  }
  if (all(result[, 2] == 1)) {
    result <- data.frame(GVIF = result[, 1])
  } else {
    result[, 3] <- result[, 1] ^ (1 / (2 * result[, 2]))
  }
  invisible(result)
}
corvif1 <- function(dataz) {
    dataz <- as.data.frame(dataz)
    #correlation part
    tmp_cor <- cor(dataz, use = "complete.obs")
    return(tmp_cor)
}
corvif2 <- function(dataz) {
    dataz <- as.data.frame(dataz)
    #vif part
    form    <- formula(paste("fooy ~ ", paste(strsplit(names(dataz), " "), collapse = " + ")))
    dataz   <- data.frame(fooy = 1, dataz)
    lm_mod  <- lm(form, dataz)

    return(myvif(lm_mod))
}

#Autocorrelation
if (auto) {
obj1 <- acf_tb(data, var = colvar)
obj2 <- acf_df(data, var = colvar)
autocorr(var1 = obj1, var2 = obj2)
}

if (interr) {
#Interractions
mult1 <- ifelse(length(unique(data[, colspe])) <= 6, FALSE, TRUE)
interraction(data, var1 = colvar, var2 = colvar2, var3 = colspe, var4 = colvar4)
}

#Collinearity
if (colli) {
mult2 <- ifelse(length(unique(data[, spe])) < 3, FALSE, TRUE)
coli(data = data_num, var = spe)
}

#PCA
if (pca) {
active_data <- function(data) {
  #Calcul of PCA for the active data
  res_pca <- FactoMineR::PCA(data, graph = FALSE)

return(res_pca)
}

#eigenvalue
eig_val <- capture.output(factoextra::get_eigenvalue(active_data(data_active)))

cat("\nwrite table with eigenvalue. \n--> \"", paste(eig_val, "\"\n", sep = ""), file = "valeurs.txt", sep = "", append = TRUE)

plot_pca(data_active)
plot_qual(data_active)
}

#VIF
if (vif) {
#Compute 2 tables#
tb_corr <- as.data.frame(corvif1(dataz = data_active))
tb_corr <- cbind(x = rownames(tb_corr), tb_corr)
tb_vif <- corvif2(dataz = data_active)

write.table(tb_corr, "corr.tabular", row.names = FALSE, quote = FALSE, sep = "\t", dec = ".", fileEncoding = "UTF-8")

if (all(is.na(tb_vif))) {
  tb_vif <- NULL
  cat("Vif couldn't be calculated, selected data isn't correlated")
}else{
write.table(tb_vif, "vif.tabular", row.names = FALSE, quote = FALSE, sep = "\t", dec = ".", fileEncoding = "UTF-8")
}
}


#研究iso异丙醇的各方面的数据，乙醇的电导率在三者中最小
#随着流量、极间距离、针头半径不断变化的弯月面的高度和角度
#设定工作区间
setwd("D:/data")
library(xlsx)

#读取数据
#与流量变化有关的数据
men_qh<-read.xlsx("iso.xls", sheetName="flowrate_h", header=TRUE)
men_qa<-read.xlsx("iso.xls", sheetName="flowrate_a", header=TRUE)

#读取与极间距离有关的数据
men_dh<-read.xlsx("iso.xls", sheetName = "distance_h", header = TRUE)
men_da<-read.xlsx("iso.xls", sheetName = "distance_a", header = TRUE)

#读取与针头直径相关的数据
men_rh<-read.xlsx("iso.xls", sheetName = "radius_h", header = TRUE)
men_ra<-read.xlsx("iso.xls", sheetName = "radius_a", header = TRUE)

#规划figure界面
par(mfrow=c(2,1), mar=c(4,4,2,2), oma=c(2,1,1,1))

#按照流量、极间距离、针头直径相关划分为3张figure，每张两图

#保存pdf
pdf("iso_distance.pdf")

#########################研究ethanol与distance的关系#################

################################画图-高度曲线###########################
plot(men_dh$voltage, men_dh$X1, col=0, xaxs="i", xlim=c(1.1, 2.9), ylim=c(0.1, 1.0),
xlab="Distance (mm)", cex.lab=1, ylab="Height of Meniscus (mm)", main="Height with H  of Ethanol")

lines(lowess(men_dh$voltage, men_dh$X1), col="#458B74", pch=21, lwd=3, type="b", lty=2)

lines(lowess(men_dh$voltage, men_dh$X1.5), col="#FF00FF", pch=22, lwd=3, type="b", lty=2)

lines(lowess(men_dh$voltage, men_dh$X2), col="#EE0000", pch=23, lwd=3, type="b", lty=2)

lines(lowess(men_dh$voltage, men_dh$X3), col="#EEAD0E", pch=24, lwd=3, type="b", lty=2)

lines(lowess(men_dh$voltage, men_dh$X4), col="#27408B", pch=25, lwd=3, type="b", lty=2)

legend("topright", c("1mm", "1.5mm", "2mm", "3mm", "4mm"), inset=.02, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E", "#27408B"), pch=c(21,22,23,24,25), lwd=3, lty=2, cex=1.3)

##############################画图--角度曲线############################
plot(men_da$voltage, men_da$X1, col=0, xaxs="i", xlim=c(1.1, 2.9), ylim=c(50, 135),
xlab="Distance (mm)", cex.lab=1, ylab="Taylor Angle (°)", main="Angle with H of Ethanol")

lines(lowess(men_da$voltage, men_da$X1), col="#458B74", pch=21, lwd=3, type="b", lty=2)

lines(lowess(men_da$voltage, men_da$X1.5), col="#FF00FF", pch=22, lwd=3, type="b", lty=2)

lines(lowess(men_da$voltage, men_da$X2), col="#EE0000", pch=23, lwd=3, type="b", lty=2)

lines(lowess(men_da$voltage, men_da$X3), col="#EEAD0E", pch=24, lwd=3, type="b", lty=2)

lines(lowess(men_da$voltage, men_da$X4), col="#27408B", pch=25, lwd=3, type="b", lty=2)

legend("topleft", c("1mm", "1.5mm", "2mm", "3mm", "4mm"), inset=.02, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E", "#27408B"), pch=c(21,22,23,24,25), lwd=3, lty=2, cex=1.3)

mtext("Distance 2mm | Nozzle 24G | Flowrate 0.006nl/min", 1, line=1, col="black", cex=1, font=2, outer=TRUE)

###标注信息

dev.off()


dotstackGrob <- function(
    x = unit(0.5, "npc"),     # x pos of the dotstack's origin
    y = unit(0.5, "npc"),     # y pos of the dotstack's origin
    stackaxis = "y",
    dotdia = unit(1, "npc"),  # Dot diameter in the non-stack axis, should be in npc
    stackposition = 0,        # Position of each dot in the stack, relative to origin
    stackratio = 1,           # Stacking height of dots (.75 means 25% dot overlap)
    default.units = "npc", name = NULL, gp = gpar(), vp = NULL)
{
    if (!is.unit(x))
        x <- unit(x, default.units)
    if (!is.unit(y))
        y <- unit(y, default.units)
    if (!is.unit(dotdia))
        dotdia <- unit(dotdia, default.units)
    if (!is_npc(dotdia))
        warn("Unit type of dotdia should be 'npc'")

    grob(x = x, y = y, stackaxis = stackaxis, dotdia = dotdia,
         stackposition = stackposition, stackratio = stackratio,
         name = name, gp = gp, vp = vp, cl = "dotstackGrob")
}
# Only cross-version reliable way to check the unit of a unit object
is_npc <- function(x) isTRUE(grepl('^[^+^-^\\*]*[^s]npc$', as.character(x)))

#' @export
makeContext.dotstackGrob <- function(x, recording = TRUE) {
  # Need absolute coordinates because when using npc coords with circleGrob,
  # the radius is in the _smaller_ of the two axes. We need the radius
  # to instead be defined in terms of the non-stack axis.
  xmm <- convertX(x$x, "mm", valueOnly = TRUE)
  ymm <- convertY(x$y, "mm", valueOnly = TRUE)

  if (x$stackaxis == "x") {
    dotdiamm <- convertY(x$dotdia, "mm", valueOnly = TRUE)
    xpos <- xmm + dotdiamm * (x$stackposition * x$stackratio + (1 - x$stackratio) / 2)
    ypos <- ymm
  } else if (x$stackaxis == "y") {
    dotdiamm <- convertX(x$dotdia, "mm", valueOnly = TRUE)
    xpos <- xmm
    ypos <- ymm + dotdiamm * (x$stackposition * x$stackratio + (1 - x$stackratio) / 2)
  }

  circleGrob(
    x = xpos, y = ypos, r = dotdiamm / 2, default.units = "mm",
    name = x$name, gp = x$gp, vp = x$vp
  )
}


peergroups<-function(timeindex, analystindex, firmindex, interval=0.99, repetitions=1000) {

	######################################################################
	#The following rows check that the inputs for the function are correct
	######################################################################

	#Check that the parameter vectors are of equal length
	if(length(timeindex) != length(analystindex)) {
		stop("Parameter vectors have different length")
	}
	if(length(timeindex) != length(firmindex)) {
		stop("Parameter vectors have different length")
	}
	if(length(firmindex) != length(analystindex)) {
		stop("Parameter vectors have different length")
	}

	#Check that the optional confidence interval is between 0 and 1
	if(interval < 0) {
		stop("interval must be between 0 and 1")
	}
	if(interval > 1) {
		stop("interval must be between 0 and 1")
	}

	#Check that there are no NAs in parameter vectors
	if(sum(is.na(timeindex)> 0 )) {
		stop("timeindex contains NA values")
	}

	if(sum(is.na(analystindex)> 0 )) {
		stop("analystindex contains NA values")
	}

	if(sum(is.na(firmindex)> 0 )) {
		stop("firmindex contains NA values")
	}

	#######################################################################################################################################################
	#This part of the code consists of a nested function that is used to calculate the peer criterion of a specific firm (it will be used later in the code)
	#######################################################################################################################################################

	analystsimulation<-function(firmsfollowedbyanalyst_nested_input, totalfirms_nested_input, interval_nested_input, repetitions_nested_input) {
		#firmsfollowedbyanalyst_nested_input is a vector consisting of the number of firms followed by each of the analysts following firm i
		#totalfirms_nested_input is the total number of firms with analysts during a given time period
		#interval_nested_input is the confidence interval for the simulation
		#repetitions_nested_input is the number of simulation rounds

		possiblechoices = totalfirms_nested_input - 1 #The number of possible other firms that the analysts can choose. The number is set to total number of firms - 1 to exclude firm i itself
		criterion<-rep(0, repetitions_nested_input) #Vector containing the values of peer criterion in each simulation round (consists of zeros at this point)
		if(max(firmsfollowedbyanalyst_nested_input) > 1) { #Checks that there is at least one analyst that follows another firm
			for(round in 1:repetitions_nested_input) {
				otherchoices = firmsfollowedbyanalyst_nested_input[firmsfollowedbyanalyst_nested_input>1] #Vector of choices that the analysts make, analysts following only firm i are excluded
				simulatedchoices = sapply(otherchoices, function(x) sample(1:possiblechoices, x - 1, replace = FALSE)) #Analysts following firm i choose the other firms they follow at random (x-1 because they follow x-1 other firms in addition to firm i)
				simulatedchoices = unlist(simulatedchoices) #Gathers all choices in one vector
				simulatedcoveredfirms = unique(simulatedchoices) #Generates a list of unique randomly selected firms among the analysts' choices
				criterion[round] = max(sapply(simulatedcoveredfirms, function(x) length(which(simulatedchoices ==x)))) #Criterion[round] is the highest number of common analysts firm i has with another random firm
			}
		}

		#Determining the final value of the peer criterion by going through the simulated values and identifying the non-random value at the given confidence level

		threshold = repetitions_nested_input * (1 - interval_nested_input) #Identify the threshold number of simulation rounds for the peer criterion
		highestcriterion = max(criterion) #Identifies the highest value for the simulated peer criterion among different simulation rounds
		l = highestcriterion #The highest value is given as the starting value for a while loop
		while(l > 0) { #This loop starts with the highest number of common analysts with another random firm in the simulation and reduces it until the confidence level is reached
			if (length(which(criterion==l))>=threshold ) {
				l = l + 1 #Add 1 to get the value of the criterion that is above the threshold
				break
			}
			l = l - 1
		}
		return(l) #Return the value of the peer criterion
	}

	##################################
	#Preparing data for the simulation
	##################################

	#Print out text "Initializing..."
	Sys.sleep(0.1)
	progresstext = "Initializing..."
	print(progresstext)
	print(Sys.time())
	flush.console()

	#Create data frames of the input data
	alldata<-data.frame(timeindex, firmindex, analystindex, stringsAsFactors=F)
	alldata<-unique(alldata) #Removes possible duplicate observations

	#Count the number of time periods in the data
	years<-unique(alldata[,1])
	numberofyears<-length(years) #This variable gives the number of time periods in the data

	#Count the number of firm-year observations in the data
	firmyearobs<-data.frame(timeindex, firmindex, stringsAsFactors=F)
	firmyearobs<-unique(firmyearobs)
	firmyearobs<-firmyearobs[order(firmyearobs$timeindex),]
	totalrows = nrow(firmyearobs) #totalrows = number of firm-year observations in the data

	#Count the number of firms in the data during each separate time period
	firmsperyear<-rep(NA, length(years))
	for(y in 1:numberofyears) {
		year = years[y] #timeindex
		subdata = subset(firmyearobs, firmyearobs[,1]==year)
		firmsperyear[y]=nrow(subdata)
	}

	oldprogressnumber = 0 #For simulation progress reporting
	counter = 0 #For simulation progress reporting

	#Count the (time period-specific) number of firms followed by each analyst in the data
	analystyearobs<-data.frame(timeindex, analystindex, stringsAsFactors=F)
	analystyearobs<-unique(analystyearobs)
	analystyearobs<-analystyearobs[order(analystyearobs$timeindex),]
	firmsfollowedbyanalyst = rep(NA, length(analystyearobs))
	for(i in 1:nrow(analystyearobs)) {
		yearidentifier = analystyearobs[i, 1]
		analystidentifier = analystyearobs[i, 2]
		if(i == 1) {
			yearspecificanalystdata = subset(alldata, alldata[,1] == yearidentifier)
			oldyear=yearidentifier
		}
		if(yearidentifier != oldyear) {
			yearspecificanalystdata = subset(alldata, alldata[,1] == yearidentifier)
			oldyear=yearidentifier
		}
		analystspecificdata = subset(yearspecificanalystdata, yearspecificanalystdata[,3] == analystidentifier)
		firmsfollowedbyanalyst[i] = nrow(analystspecificdata) #Vector containing the number of firms followed by each analyst
	}
	analystyearobs=cbind(analystyearobs, firmsfollowedbyanalyst) #A matrix combining analyst-year observations with the corresponding number of firms followed by each analyst
	totaloutput<-vector('list') #This list will contain the final output of the function
	outputrow = 1 #Needed for printing the output

	#################################################################################
	#Run the simulation and identify peers for each firm-year observation in the data
	#################################################################################

	#Print out text "Starting simulation..."
	Sys.sleep(0.1)
	progresstext = "Starting simulation..."
	print(progresstext)
	print(Sys.time())
	flush.console()

	for(i in 1:totalrows) { #The loop goes through all the firm-year observations one at a time
		yearidentifier = firmyearobs[i, 1] #Time index of the observation
		firmidentifier = firmyearobs[i, 2] #Firm index of the observation
		totalfirms = firmsperyear[match(yearidentifier, years)] #Total number of firms during the time period
		if (i == 1) {
			yearspecificfirmanalystdata = subset(alldata, alldata[,1] == yearidentifier) #Contains all the firm-analyst observations of the time period
			oldyear=yearidentifier
		}
		if (yearidentifier != oldyear) {
			yearspecificfirmanalystdata = subset(alldata, alldata[,1] == yearidentifier) #Contains all the firm-analyst observations of the time period
			oldyear=yearidentifier
		}
		firmspecificanalystdata = subset(yearspecificfirmanalystdata, yearspecificfirmanalystdata[,2] == firmidentifier) #Contains the analyst-firm data for all analysts following the firm
		yearspecificanalystdata = subset(analystyearobs, analystyearobs[,1] == yearidentifier) #Contains the analyst data of the time period
		analystrows = sapply(firmspecificanalystdata[,3], function(x) match(x, yearspecificanalystdata[,2])) #Identify which row in "yearspecificanalystdata" corresponds to each analyst following firm i
		firmsfollowedbyanalyst = sapply(analystrows, function(x) yearspecificanalystdata[x,3]) #A vector containing the number of firms followed by each analyst following firm i

		#Calculate the peer criterion
		peercriterion = analystsimulation(firmsfollowedbyanalyst_nested_input=firmsfollowedbyanalyst, totalfirms_nested_input=totalfirms, interval_nested_input=interval, repetitions_nested_input=repetitions) #Uses the nested function to calculate the value of the peer criterion

		#Identify which firms have at least the peer criterion number of common analysts with firm i in the data
		if(peercriterion >= 2) { #Firms with peer criterion < 2 cannot have a peer group

			#The following for loop creates a data frame that contains data on all other firms followed by each of the analysts following firm i
			for(j in 1: nrow(firmspecificanalystdata)) {
				analystid = firmspecificanalystdata[j,3]
				if( j == 1) {
					otherfirmsfollowedbyanalyst_nested_input = subset(yearspecificfirmanalystdata, yearspecificfirmanalystdata[, 3] == analystid & yearspecificfirmanalystdata[, 2] != firmidentifier)
				} else {
					otherfirmsfollowedbyanalyst_nested_input = rbind(otherfirmsfollowedbyanalyst_nested_input, subset(yearspecificfirmanalystdata, yearspecificfirmanalystdata[, 3] == analystid & yearspecificfirmanalystdata[, 2] != firmidentifier))
				}
			}
			otherfirmids=unique(otherfirmsfollowedbyanalyst_nested_input[,2]) #A vector of different firms followed by the analysts
			commonanalystswithotherfirms = sapply(otherfirmids, function(x) length(which(otherfirmsfollowedbyanalyst_nested_input[,2]==x))) #A vector containing the number of common analysts with each of the unique firms
			potentialpeers=data.frame(otherfirmids, commonanalystswithotherfirms, stringsAsFactors=FALSE) #Created a data frame combining the two vectors
			peergroup=subset(potentialpeers, potentialpeers[,2]>=peercriterion) #Identify analyst-based peers: the other firms with at least the peer criterion number of common analysts with firm i

			#If the firm has peers, the peer group is stored in the list "totaloutput"
			if (nrow(peergroup) > 0) {
				firmspecificoutput=data.frame(yearidentifier, firmidentifier, peergroup, peercriterion, stringsAsFactors=FALSE)
				totaloutput[[outputrow]]=firmspecificoutput
				outputrow=outputrow + 1
			}
		}

		#This part of the code periodically prints progress information on the screen
		counter = counter + 1
		newprogressnumber = round(counter / totalrows, digits = 2) * 100
		if (newprogressnumber > oldprogressnumber) {
			oldprogressnumber = newprogressnumber
			progresstext = paste(c(newprogressnumber, "% Complete"), collapse = " ")
			Sys.sleep(0.1)
			print(progresstext)
			print(Sys.time())
			flush.console()
		}
	}

	#########################################
	#Prepare the final output of the function
	#########################################

	progresstext = "Preparing Output"
	Sys.sleep(0.1)
	print(progresstext)
	print(Sys.time())
	flush.console()

	#Create a single data frame out of all the rows in "totaloutput" and name the columns:
	combinedframe = do.call('rbind', totaloutput)
	outputframe = data.frame(combinedframe$yearidentifier, combinedframe$firmidentifier, combinedframe$otherfirmids, combinedframe$commonanalystswithotherfirms, combinedframe$peercriterion, stringsAsFactors=FALSE)
	names(outputframe)[1]<-"year"
	names(outputframe)[2]<-"firm"
	names(outputframe)[3]<-"peer_firm"
	names(outputframe)[4]<-"common_analysts"
	names(outputframe)[5]<-"peer_criterion"

	return(outputframe)
}


#' Albers equal-area conic convenience projection
#'
#' The following PROJ.4 string is used: \code{+proj=laea +lat_0=45 +lon_0=-100 +x_0=0 +y_0=0 +a=6370997 +b=6370997 +units=m +no_defs}
#'
#' In a ggplot2+ggalt context, you can just use variable name as the value for the \code{proj}
#' parameter to \code{ggalt::coord_proj()}. i.e. \code{coord_proj(us_laea_proj)}.
#'
#' @family convenience projections
#' @export
#' @examples
#' us <- usa_composite()
#' us <- sp::spTransform(us, sp::CRS(us_laea_proj))
#' us <- usa_composite(proj="laea")
#' counties <- counties_composite("laea")
us_laea_proj <- "+proj=laea +lat_0=45 +lon_0=-100 +x_0=0 +y_0=0 +a=6370997 +b=6370997 +units=m +no_defs"

#' Generic long/lat convenience projection
#'
#' The following PROJ.4 string is used: \code{+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0}
#'
#' In a ggplot2+ggalt context, you can just use variable name as the value for the \code{proj}
#' parameter to \code{ggalt::coord_proj()}. i.e. \code{coord_proj(us_longlat_proj)}.
#'
#' @export
#' @examples
#' us <- usa_composite() # it's the default
#' us <- sp::spTransform(us, sp::CRS(us_longlat_proj))
#' counties <- counties_composite()
us_longlat_proj <- "+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"

#' Lambert conformal conic convenience projection
#'
#' The following PROJ.4 string is used: \code{+proj=lcc +lat_1=27.11637320883929 +lat_2=53.050729042644335 +lon_0=-95.44921875}
#'
#' In a ggplot2+ggalt context, you can just use variable name as the value for the \code{proj}
#' parameter to \code{ggalt::coord_proj()}. i.e. \code{coord_proj(us_lcc_proj)}.
#'
#' @family convenience projections
#' @export
#' @examples
#' us <- usa_composite()
#' us <- sp::spTransform(us, sp::CRS(us_lcc_proj))
#' us <- usa_composite(proj="lcc")
#' counties <- counties_composite("lcc")
us_lcc_proj <- "+proj=lcc +lat_1=27.11637320883929 +lat_2=53.050729042644335 +lon_0=-95.44921875"

#' Equidistant conic convenience projection
#'
#' Distance correct along meridians
#'
#' The following PROJ.4 string is used: \code{+proj=eqdc +lat_1=27.11637320883929 +lat_2=53.050729042644335 +lon_0=-95.44921875}
#'
#' In a ggplot2+ggalt context, you can just use variable name as the value for the \code{proj}
#' parameter to \code{ggalt::coord_proj()}. i.e. \code{coord_proj(us_eqdc_proj)}.
#'
#' @family convenience projections
#' @export
#' @examples
#' us <- usa_composite()
#' us <- sp::spTransform(us, sp::CRS(us_eqdc_proj))
#' us <- usa_composite(proj="eqdc")
#' counties <- counties_composite("eqdc")
#'
us_eqdc_proj <- "+proj=eqdc +lat_1=27.11637320883929 +lat_2=53.050729042644335 +lon_0=-95.44921875"

#' Oblique azimuthal equidistant convenience projection
#'
#' Distance correct along any line passing through the center of the map (i.e., great circle)
#'
#' The following PROJ.4 string is used: \code{+proj=aeqd +lat_0=40.08355112574181 +lon_0=-95.44921875}
#'
#' In a ggplot2+ggalt context, you can just use variable name as the value for the \code{proj}
#' parameter to \code{ggalt::coord_proj()}. i.e. \code{coord_proj(us_aeqd_proj)}.
#'
#' @family convenience projections
#' @export
#' @examples
#' us <- usa_composite()
#' us <- sp::spTransform(us, sp::CRS(us_aeqd_proj))
#' us <- usa_composite(proj="aeqd")
#' counties <- counties_composite("aeqd")
us_aeqd_proj <- "+proj=aeqd +lat_0=40.08355112574181 +lon_0=-95.44921875"


library(ewaff)
options(mc.cores=4)

source("simulation-functions.r")

###################################
## construct a random dataset
set.seed(20180220)

n <- 100 ## n samples
s <- 1000  ## s features

## variable of interest and covariates
data <- data.frame(variable=c(rep("A",n/2), rep("B",n/2)), ## variable of interest (two groups)
                   continuous=rnorm(n),                ## continuous covariate
                   categorical=factor(sample(0:3,n,replace=T))) ## categorical covariate

manifest <- data.frame(chr=c(rep(1,s/2), rep(2,s/2)), pos=sample(1:(150*s), s))
manifest <- manifest[order(manifest$chr, manifest$pos),]

methylation <- generate.methylation(n, manifest$pos)
rownames(methylation) <- paste("cpg", 1:nrow(methylation), sep="")

########################################
## construct variable with associations
var <- generate.true.bump.var(methylation, manifest$chr, manifest$pos, cluster.sites=20,
                              bump.sites=10, cluster.position=0.5, r=0.5, maxgap=500)
data$bump <- var$var

############################
## add some missing values

methylation[sample(1:length(methylation), 5)] <- NA

data$bump[sample(1:nrow(data), 2)] <- NA
data$variable[sample(1:nrow(data), 3)] <- NA

###################################
## test associations at each CpG site
sites.ret <- ewaff.sites(methylation ~ .,
                   variable.of.interest="bump",
                   methylation=methylation,
                   data=data,
                   generate.confounders="sva",
                   random.subset=0.9,
                   method="glm")

##########################
## generate report
sum.ret <- ewaff.summary(sites.ret, manifest$chr, manifest$pos, methylation,
                         selected.cpg.sites=paste("cpg", var$bump.idx, sep=""))

ewaff.report(sum.ret, output.file="output/report.html",
             author="Robin Banks",
             study="Mining bitcoin")


############ Takes a saved decision tree from phase1 and estimates events

source("featureLibrary.r")
suppressMessages(library(jsonlite))
suppressMessages(library(party))
closeAllConnections()

## Input block
con <- file("test.csv")
t.full <- read.csv(con)
load("sample_tree.rda")

#phase2 <- function(panel) {
## Formatting block
filler <- rep(0,length(t.full[,1]))
t.full.formatted <- as.data.frame(cbind(filler,t.full$time,t.full$acceleration.x,t.full$acceleration.y,t.full$acceleration.z,filler,filler,filler,filler,filler,filler,filler,filler,filler,filler,filler,filler,t.full$rotationrate.x,t.full$rotationrate.y,t.full$rotationrate.z))
names(t.full.formatted) <- c("filler","time", "acceleration.x", "acceleration.y", "acceleration.z","filler","filler","filler","filler","filler","filler","filler","filler","filler","filler","filler","filler","rotationrate.x","rotationrate.y","rotationrate.z")

## Feature creation
t.features <- as.data.frame(listToMatrix(features(t.full.formatted)))

## Prediction
prediction <- predict(tree,newdata=t.features)

## Prediction formatting
expanded.prediction <- labelExpand(t.full,prediction)
predictionJSON.df <- createEventJSON(t.full.formatted,expanded.prediction)
eventJSON <- toJSON(predictionJSON.df)

#return(eventJSON)
#}


# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

#' Evaluation of the maximum likelihood using FaST-LMM method
#'
#' Last update: January 11, 2017
#'
#' @author Xiaolei Liu (modified)
#'
#' @param pheno a two-column phenotype matrix
#' @param snp.pool matrix for pseudo QTNs
#' @param X0 covariates matrix
#' @param ncpus number of threads used for parallel computation
#'
#' @return
#' Output: beta - beta effect
#' Output: delta - delta value
#' Output: LL - log-likelihood
#' Output: vg - genetic variance
#' Output: ve - residual variance
#'
`MVP.FaSTLMM.LL` <- function(pheno, snp.pool, X0=NULL, ncpus=2){
    y=pheno
    p=0
    deltaExpStart = -5
    deltaExpEnd = 5
    snp.pool=snp.pool[,]
    if(!is.null(snp.pool)&&var(snp.pool)==0){
        deltaExpStart = 100
        deltaExpEnd = deltaExpStart
    }
    if(is.null(X0)) {
        X0 = matrix(1, nrow(snp.pool), 1)
    }
    X=X0
    #########SVD of X
    K.X.svd <- svd(snp.pool)
    d=K.X.svd$d
    d=d[d>1e-08]
    d=d^2
    U1=K.X.svd$u
    U1=U1[,1:length(d)]
    #handler of single snp
    if(is.null(dim(U1))) U1=matrix(U1,ncol=1)
    n=nrow(U1)
    U1TX=crossprod(U1,X)
    U1TY=crossprod(U1,y)
    yU1TY <- y-U1%*%U1TY
    XU1TX<- X-U1%*%U1TX
    IU = -tcrossprod(U1)
    diag(IU) = rep(1,n) + diag(IU)
    IUX=crossprod(IU,X)
    IUY=crossprod(IU,y)
    #Iteration on the range of delta (-5 to 5 in glog scale)
    delta.range <- seq(deltaExpStart,deltaExpEnd,by=0.1)
    m <- length(delta.range)
    #for (m in seq(deltaExpStart,deltaExpEnd,by=0.1)){
    beta.optimize.parallel <- function(ii){
        #p=p+1
        delta <- exp(delta.range[ii])
        #----------------------------calculate beta-------------------------------------
        #######get beta1
        beta1=0
        for(i in 1:length(d)){
            one=matrix(U1TX[i,], nrow=1)
            beta=crossprod(one,(one/(d[i]+delta)))  #This is not real beta, confusing
            beta1= beta1+beta
        }

        #######get beta2
        beta2=0
        for(i in 1:nrow(U1)){
            one=matrix(IUX[i,], nrow=1)
            beta = crossprod(one)
            beta2= beta2+beta
        }
        beta2<-beta2/delta

        #######get beta3
        beta3=0
        for(i in 1:length(d)){
            one1=matrix(U1TX[i,], nrow=1)
            one2=matrix(U1TY[i,], nrow=1)
            beta=crossprod(one1,(one2/(d[i]+delta)))
            beta3= beta3+beta
        }

        ###########get beta4
        beta4=0
        for(i in 1:nrow(U1)){
            one1=matrix(IUX[i,], nrow=1)
            one2=matrix(IUY[i,], nrow=1)
            beta=crossprod(one1,one2)
            beta4= beta4+beta
        }
        beta4<-beta4/delta

        #######get final beta
        zw1 <- ginv(beta1+beta2)
        #zw1 <- try(solve(beta1+beta2))
        #if(inherits(zw1, "try-error")){
        #zw1 <- ginv(beta1+beta2)
        #}

        zw2=(beta3+beta4)
        beta=crossprod(zw1,zw2)

        #----------------------------calculate LL---------------------------------------
        ####part 1
        part11<-n*log(2*3.14)
        part12<-0
        for(i in 1:length(d)){
            part12_pre=log(d[i]+delta)
            part12= part12+part12_pre
        }
        part13<- (nrow(U1)-length(d))*log(delta)
        part1<- -1/2*(part11+part12+part13)

        ######  part2
        part21<-nrow(U1)
        ######part221

        part221=0
        for(i in 1:length(d)){
            one1=U1TX[i,]
            one2=U1TY[i,]
            part221_pre=(one2-one1%*%beta)^2/(d[i]+delta)
            part221 = part221+part221_pre
        }

        part222=0
        for(i in 1:n){
            one1=XU1TX[i,]
            one2=yU1TY[i,]
            part222_pre=((one2-one1%*%beta)^2)/delta
            part222= part222+part222_pre
        }
        part22<-n*log((1/n)*(part221+part222))
        part2<- -1/2*(part21+part22)

        ################# likihood
        LL<-part1+part2
        part1<-0
        part2<-0

        return(list(beta=beta,delta=delta,LL=LL))
    }
    #} # end of Iteration on the range of delta (-5 to 5 in glog scale)

    llresults <- lapply(1:m, beta.optimize.parallel)

    for(i in 1:m){
        if(i == 1){
            beta.save = llresults[[i]]$beta
            delta.save = llresults[[i]]$delta
            LL.save = llresults[[i]]$LL
        }else{
            if(llresults[[i]]$LL > LL.save){
                beta.save = llresults[[i]]$beta
                delta.save = llresults[[i]]$delta
                LL.save = llresults[[i]]$LL
            }
        }
    }
    #--------------------update with the optimum------------------------------------
    beta=beta.save
    delta=delta.save
    LL=LL.save

    #--------------------calculating Va and Vem-------------------------------------
    #sigma_a1
    sigma_a1=0
    for(i in 1:length(d)){
        one1=matrix(U1TX[i,], ncol=1)
        one2=matrix(U1TY[i,], nrow=1)
        #sigma_a1_pre=(one2-one1%*%beta)^2/(d[i]+delta)
        sigma_a1_pre=(one2-crossprod(one1,beta))^2/(d[i]+delta)
        sigma_a1= sigma_a1+sigma_a1_pre
    }

    ### sigma_a2
    sigma_a2=0

    for(i in 1:nrow(U1)){
        one1=matrix(IUX[i,], ncol=1)
        one2=matrix(IUY[i,], nrow=1)
        #sigma_a2_pre<-(one2-one1%*%beta)^2
        sigma_a2_pre<-(one2-crossprod(one1,beta))^2
        sigma_a2= sigma_a2+sigma_a2_pre
    }

    sigma_a2<-sigma_a2/delta
    sigma_a<- 1/n*(sigma_a1+sigma_a2)
    sigma_e<-delta*sigma_a

    return(list(beta=beta, delta=delta, LL=LL, vg=sigma_a, ve=sigma_e))
}


#' @export
#' @title create.histograms.yearly
#' @description couldn't accurately describe
#' @param \code{X}
#' @param \code{probs}
#' @return \code{nn}
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
  create.histograms.yearly = function( X, probs=c(0, 0.995) ) {
    xr=range(X)
    xl=quantile( X, probs=probs )
    br=c( xr[1], seq(xl[1], xl[2], length.out=100 ), xr[2] )
    ny = dim(X)[1]
    nn = matrix(0, ncol=ny, nrow=length(br)-1 )
    for (yy in 1:ny ) {
      nx = hist( X[yy,,], breaks=br, plot=FALSE )
      nn[,yy]=nx$counts
    }
    rownames(nn) = nx$mids
    return(nn)
  }


#!/usr/bin/env Rscript

################################################
################################################
## REQUIREMENTS                               ##
################################################
################################################

## PCA, HEATMAP AND SCATTERPLOTS FOR SAMPLES IN COUNTS FILE
## - SAMPLE NAMES HAVE TO END IN e.g. "_R1" REPRESENTING REPLICATE ID. LAST 3 CHARACTERS OF SAMPLE NAME WILL BE TRIMMED TO OBTAIN GROUP ID FOR DESEQ2 COMPARISONS.
## - PACKAGES BELOW NEED TO BE AVAILABLE TO LOAD WHEN RUNNING R

################################################
################################################
## LOAD LIBRARIES                             ##
################################################
################################################

library(optparse)
library(DESeq2)
library(ggplot2)
library(RColorBrewer)
library(pheatmap)

################################################
################################################
## PARSE COMMAND-LINE PARAMETERS              ##
################################################
################################################

option_list <- list(
    make_option(c("-i", "--count_file"    ), type="character", default=NULL    , metavar="path"   , help="Count file matrix where rows are genes and columns are samples."                        ),
    make_option(c("-f", "--count_col"     ), type="integer"  , default=2       , metavar="integer", help="First column containing sample count data."                                             ),
    make_option(c("-d", "--id_col"        ), type="integer"  , default=1       , metavar="integer", help="Column containing identifiers to be used."                                              ),
    make_option(c("-r", "--sample_suffix" ), type="character", default=''      , metavar="string" , help="Suffix to remove after sample name in columns e.g. '.rmDup.bam' if 'DRUG_R1.rmDup.bam'."),
    make_option(c("-o", "--outdir"        ), type="character", default='./'    , metavar="path"   , help="Output directory."                                                                      ),
    make_option(c("-p", "--outprefix"     ), type="character", default='deseq2', metavar="string" , help="Output prefix."                                                                         ),
    make_option(c("-v", "--vst"           ), type="logical"  , default=FALSE   , metavar="boolean", help="Run vst transform instead of rlog."                                                     ),
    make_option(c("-c", "--cores"         ), type="integer"  , default=1       , metavar="integer", help="Number of cores."                                                                       )
)

opt_parser <- OptionParser(option_list=option_list)
opt        <- parse_args(opt_parser)

if (is.null(opt$count_file)){
    print_help(opt_parser)
    stop("Please provide a counts file.", call.=FALSE)
}

################################################
################################################
## READ IN COUNTS FILE                        ##
################################################
################################################

count.table           <- read.delim(file=opt$count_file,header=TRUE, row.names=NULL)
rownames(count.table) <- count.table[,opt$id_col]
count.table           <- count.table[,opt$count_col:ncol(count.table),drop=FALSE]
colnames(count.table) <- gsub(opt$sample_suffix,"",colnames(count.table))
colnames(count.table) <- gsub(pattern='\\.$', replacement='', colnames(count.table))

################################################
################################################
## RUN DESEQ2                                 ##
################################################
################################################

if (file.exists(opt$outdir) == FALSE) {
    dir.create(opt$outdir, recursive=TRUE)
}
setwd(opt$outdir)

samples.vec     <- colnames(count.table)
name_components <- strsplit(samples.vec, "_")
n_components    <- length(name_components[[1]])
decompose       <- n_components!=1 && all(sapply(name_components, length)==n_components)
coldata         <- data.frame(samples.vec, sample=samples.vec, row.names=1)
if (decompose) {
    groupings        <- as.data.frame(lapply(1:n_components, function(i) sapply(name_components, "[[", i)))
    names(groupings) <- paste0("Group", 1:n_components)
    n_distinct       <- sapply(groupings, function(grp) length(unique(grp)))
    groupings        <- groupings[n_distinct!=1 & n_distinct!=length(samples.vec)]
    if (ncol(groupings)!=0) {
        coldata <- cbind(coldata, groupings)
    } else {
        decompose <- FALSE
    }
}

DDSFile <- paste(opt$outprefix,".dds.RData",sep="")

counts  <- count.table[,samples.vec,drop=FALSE]
dds     <- DESeqDataSetFromMatrix(countData=round(counts), colData=coldata, design=~ 1)
dds     <- estimateSizeFactors(dds)
if (min(dim(count.table))<=1)  { # No point if only one sample, or one gene
    save(dds,file=DDSFile)
    saveRDS(dds, file=sub("\\.dds\\.RData$", ".rds", DDSFile))
    warning("Not enough samples or genes in counts file for PCA.", call.=FALSE)
    quit(save = "no", status = 0, runLast = FALSE)
}
if (!opt$vst) {
    vst_name <- "rlog"
    rld      <- rlog(dds)
} else {
    vst_name <- "vst"
    rld      <- varianceStabilizingTransformation(dds)
}

assay(dds, vst_name) <- assay(rld)
save(dds,file=DDSFile)
saveRDS(dds, file=sub("\\.dds\\.RData$", ".rds", DDSFile))

################################################
################################################
## PLOT QC                                    ##
################################################
################################################

##' PCA pre-processeor
##'
##' Generate all the necessary information to plot PCA from a DESeq2 object
##' in which an assay containing a variance-stabilised matrix of counts is
##' stored. Copied from DESeq2::plotPCA, but with additional ability to
##' say which assay to run the PCA on.
##'
##' @param object The DESeq2DataSet object.
##' @param ntop number of top genes to use for principla components, selected by highest row variance.
##' @param assay the name or index of the assay that stores the variance-stabilised data.
##' @return A data.frame containing the projected data alongside the grouping columns.
##' A 'percentVar' attribute is set which includes the percentage of variation each PC explains,
##' and additionally how much the variation within that PC is explained by the grouping variable.
##' @author Gavin Kelly
plotPCA_vst <- function (object,  ntop = 500, assay=length(assays(object))) {
    rv         <- rowVars(assay(object, assay))
    select     <- order(rv, decreasing = TRUE)[seq_len(min(ntop, length(rv)))]
    pca        <- prcomp(t(assay(object, assay)[select, ]), center=TRUE, scale=FALSE)
    percentVar <- pca$sdev^2/sum(pca$sdev^2)
    df         <- cbind( as.data.frame(colData(object)), pca$x)
    #Order points so extreme samples are more likely to get label
    ord        <- order(abs(rank(df$PC1)-median(df$PC1)), abs(rank(df$PC2)-median(df$PC2)))
    df         <- df[ord,]
    attr(df, "percentVar") <- data.frame(PC=seq(along=percentVar), percentVar=100*percentVar)
    return(df)
}

PlotFile <- paste(opt$outprefix,".plots.pdf",sep="")

pdf(file=PlotFile, onefile=TRUE, width=7, height=7)
## PCA
ntop <- c(500, Inf)
for (n_top_var in ntop) {
    pca.data      <- plotPCA_vst(dds, assay=vst_name, ntop=n_top_var)
    percentVar    <- round(attr(pca.data, "percentVar")$percentVar)
    plot_subtitle <- ifelse(n_top_var==Inf, "All genes", paste("Top", n_top_var, "genes"))
    pl <- ggplot(pca.data, aes(PC1, PC2, label=paste0(" ", sample, " "))) +
        geom_point() +
        geom_text(check_overlap=TRUE, vjust=0.5, hjust="inward") +
        xlab(paste0("PC1: ",percentVar[1],"% variance")) +
        ylab(paste0("PC2: ",percentVar[2],"% variance")) +
        labs(title = paste0("First PCs on ", vst_name, "-transformed data"), subtitle = plot_subtitle) +
        theme(legend.position="top",
            panel.grid.major = element_blank(),
            panel.grid.minor = element_blank(),
            panel.background = element_blank(),
            panel.border = element_rect(colour = "black", fill=NA, size=1))
    print(pl)

    if (decompose) {
        pc_names <- paste0("PC", attr(pca.data, "percentVar")$PC)
        long_pc <- reshape(pca.data, varying=pc_names, direction="long", sep="", timevar="component", idvar="pcrow")
        long_pc <- subset(long_pc, component<=5)
        long_pc_grp <- reshape(long_pc, varying=names(groupings), direction="long", sep="", timevar="grouper")
        long_pc_grp <- subset(long_pc_grp, grouper<=5)
        long_pc_grp$component <- paste("PC", long_pc_grp$component)
        long_pc_grp$grouper <- paste0(long_pc_grp$grouper, c("st","nd","rd","th","th")[long_pc_grp$grouper], " prefix")
        pl <- ggplot(long_pc_grp, aes(x=Group, y=PC)) +
            geom_point() +
            stat_summary(fun=mean, geom="line", aes(group = 1)) +
            labs(x=NULL, y=NULL, subtitle = plot_subtitle, title="PCs split by sample-name prefixes") +
            facet_grid(component~grouper, scales="free_x") +
            scale_x_discrete(guide = guide_axis(n.dodge = 3))
        print(pl)
    }
} # at end of loop, we'll be using the user-defined ntop if any, else all genes

## WRITE PC1 vs PC2 VALUES TO FILE
pca.vals           <- pca.data[,c("PC1","PC2")]
colnames(pca.vals) <- paste0(colnames(pca.vals), ": ", percentVar[1:2], '% variance')
pca.vals           <- cbind(sample = rownames(pca.vals), pca.vals)
write.table(pca.vals, file = paste(opt$outprefix, ".pca.vals.txt", sep=""),
            row.names = FALSE, col.names = TRUE, sep = "\t", quote = TRUE)

## SAMPLE CORRELATION HEATMAP
sampleDists      <- dist(t(assay(dds, vst_name)))
sampleDistMatrix <- as.matrix(sampleDists)
colors           <- colorRampPalette( rev(brewer.pal(9, "Blues")) )(255)
pheatmap(
    sampleDistMatrix,
    clustering_distance_rows=sampleDists,
    clustering_distance_cols=sampleDists,
    col=colors,
    main=paste("Euclidean distance between", vst_name, "of samples")
)

## WRITE SAMPLE DISTANCES TO FILE
write.table(cbind(sample = rownames(sampleDistMatrix), sampleDistMatrix),file=paste(opt$outprefix, ".sample.dists.txt", sep=""),
            row.names=FALSE, col.names=TRUE, sep="\t", quote=FALSE)
dev.off()

################################################
################################################
## SAVE SIZE FACTORS                          ##
################################################
################################################

SizeFactorsDir <- "size_factors/"
if (file.exists(SizeFactorsDir) == FALSE) {
    dir.create(SizeFactorsDir, recursive=TRUE)
}

NormFactorsFile <- paste(SizeFactorsDir,opt$outprefix, ".size_factors.RData", sep="")

normFactors <- sizeFactors(dds)
save(normFactors, file=NormFactorsFile)

for (name in names(sizeFactors(dds))) {
    sizeFactorFile <- paste(SizeFactorsDir,name, ".txt", sep="")
    write(as.numeric(sizeFactors(dds)[name]), file=sizeFactorFile)
}

################################################
################################################
## R SESSION INFO                             ##
################################################
################################################

RLogFile <- "R_sessionInfo.log"

sink(RLogFile)
a <- sessionInfo()
print(a)
sink()

################################################
################################################
################################################
################################################


#' Computes edges
#' @noRd
grob_edge <- function(netenv, e) {

  # Obtaining positions of ego and alter
  i       <- netenv$edgelist[e, 1]
  j       <- netenv$edgelist[e, 2]
  nbreaks <- netenv$edge.line.breaks[e]

  if (nbreaks >= 0L) {

    # Computing coordinates
    coords <- arc(
      p0    = netenv$layout[i,],
      p1    = netenv$layout[j,],
      radii = netenv$vertex.size[c(i,j)] + c(0, netenv$arrow.size.adj[e]),
      alpha = netenv$edge.curvature[e],
      n     = nbreaks
    )

    # Generating grob
    if (!netenv$skip.edges) {

      ans <- grid::polylineGrob(
        x          = coords[,1],
        y          = coords[,2],
        id.lengths = rep(2, nbreaks),
        default.units = "native",
        gp         = do.call(
          grid::gpar,
          list(
            lwd     = netenv$edge.width[e],
            lineend = "butt",
            lty     = netenv$edge.line.lty[e]
            )
        ),
        name = "line"
      )

    } else
      ans <- NULL

    # Arrow
    # Computing arrow
    if (!netenv$skip.arrows) {

      alpha1 <- attr(coords, "alpha1")
      arrow  <- arrow_fancy(
        x     = coords[nbreaks*2, 1:2] +
          netenv$arrow.size.adj[e]*c(cos(alpha1), sin(alpha1)),
        alpha = alpha1,
        l     = netenv$edge.arrow.size[e]
      )

      ans <- grid::grobTree(
        ans,
        grid::polygonGrob(
          arrow[,1],
          arrow[,2],
          default.units = "native",
          name = "arrow",
          gp   = grid::gpar(
            lwd  = netenv$edge.width[e]
          )
        ),
        name = netplot_name$make(c(i, j))
      )

    } else
      ans <- grid::grobTree(ans, name = netplot_name$make(c(i, j)))

  } else {

    stop("Line breaks should be positive.", call. = FALSE)

    # The lines that follow should be implemented in the future!
    # Right now these are not working

    # Generating grob
    ans <- grid::curveGrob(
      x1          = netenv$layout[i,1],
      y1          = netenv$layout[i,2],
      x2          = netenv$layout[j,1],
      y2          = netenv$layout[j,2],
      ncp         = 6L,
      curvature   = .5,
      default.units = "native",
      gp         = do.call(
        grid::gpar,
        list(
          lwd     = netenv$edge.width[e],
          lineend = "butt",
          lty     = netenv$edge.line.lty[e]
        )
      ), arrow = grid::arrow(),
      name = "line"
    )

    ans <- grid::grobTree(
      ans,
      name = netplot_name$make(c(i, j))
    )

  }

  ans

}