suppressMessages(library(edgeR))
options(scipen=999)

x <- read.delim('/btl/foundry/users/alex/20190228_novel_chassis/run_DGE/edgeR_matfile.csv', sep=',', stringsAsFactors=TRUE)

x$strain <- factor(x$strain)

x$Arabinose <- factor(x$Arabinose)

x$IPTG <- factor(x$IPTG)

x$Temp <- factor(x$Temp)

x$Timepoint <- factor(x$Timepoint)

drops <- c('strain', 'Arabinose', 'IPTG', 'Temp', 'Timepoint')
counts <- x[, !(names(x) %in% drops)]
t_cts <- t(counts)
t_cts[is.na(t_cts)] <- 0

#colnames(t_cts) <- x$filename

group <- factor(c(1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8, 9, 9, 9, 9, 10, 10, 10, 10, 11, 11, 11, 11, 12, 12, 12, 12, 13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 17, 17, 17, 17, 18, 18, 18, 18, 19, 19, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 23, 23, 23, 23, 24, 24, 24, 24, 25, 25, 25, 25, 26, 26, 26, 26, 27, 27, 27, 27, 28, 28, 28, 28, 29, 29, 29, 29, 30, 30, 30, 30, 31, 31, 31, 31, 32, 32, 32, 32, 33, 33, 33, 33, 34, 34, 34, 34, 35, 35, 35, 35, 36, 36, 36, 36, 37, 37, 37, 37, 38, 38, 38, 38, 39, 39, 39, 39, 40, 40, 40, 40, 41, 41, 41, 41, 42, 42, 42, 42, 43, 43, 43, 43, 44, 44, 44, 44, 45, 45, 45, 45, 46, 46, 46, 46, 47, 47, 47, 47, 48, 48, 48, 48, 49, 49, 49, 49, 50, 50, 50, 50, 51, 51, 51, 51, 52, 52, 52, 52, 53, 53, 53, 53, 54, 54, 54, 54, 55, 55, 55, 55, 56, 56, 56, 56, 57, 57, 57, 57, 58, 58, 58, 58, 59, 59, 59, 59, 60, 60, 60, 60, 61, 61, 61, 61, 62, 62, 62, 62, 63, 63, 63, 63, 64, 64, 64, 64, 65, 65, 65, 65, 66, 66, 66, 66, 67, 67, 67, 67, 68, 68, 68, 68, 69, 69, 69, 69, 70, 70, 70, 70, 71, 71, 71, 71, 72, 72, 72, 72, 73, 73, 73, 73, 74, 74, 74, 74, 75, 75, 75, 75, 76, 76, 76, 76, 77, 77, 77, 77, 78, 78, 78, 78, 79, 79, 79, 79, 80, 80, 80, 80, 81, 81, 81, 81, 82, 82, 82, 82, 83, 83, 83, 83, 84, 84, 84, 84, 85, 85, 85, 85, 86, 86, 86, 86, 87, 87, 87, 87, 88, 88, 88, 88))

y <- DGEList(counts=t_cts, group=group)
y <- calcNormFactors(y)
design <- model.matrix(~0 + group)
keep <- rowSums(cpm(y[, c(225, 226, 227, 228, 245, 246, 247, 248)]) >1) >= 8
y <- y[keep, ,]
y <- estimateDisp(y, design)
fit <- glmQLFit(y, design)
qlf <- glmQLFTest(fit, contrast=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,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,-1,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))
tab <- topTags(qlf, n=Inf)
write.table(tab, file="Strain4MG1655GenomicNANDCircuit_False_True_30_18-vs-Strain3MG1655GenomicIcaRGate_False_True_30_18.txt")


#' Produce a DEM with basins filled in
#'
#' @param dem A [raster::raster]; a digital elevation model.
#' @param file The file name of the raster to be returned, see `details`.
#' @details This is a wrapper for [r.fill.dir](https://grass.osgeo.org/grass76/manuals/r.fill.dir.html)
#'
#' It is recommended to specify the `file` parameter (including the extension to specify
#' file format; e.g., .tif, .grd). If not specified, a temp file will be created and will be
#' lost at the end of the R session.
#' @return A filled DEM raster
#' @examples
#' \donttest{
#'     data(kamp_dem)
#'     kamp_fill = fill_dem(kamp_dem)
#' }
#' @export
fill_dem = function(dem, file = NA) {
	inp_name = "dem"
	out_name = "dem_filled"
	dir_name = "flow_direction"
	problem_name= "problems"

	## launch grass and copy data
	.start_grass(dem, inp_name)

	## perform computation
	rgrass7::execGRASS("r.fill.dir", flags=c("overwrite", "quiet"), input=inp_name,
				output = out_name, direction = dir_name, areas = problem_name)
	# make sure to add the names of created rasters to the list of layers
	ws_env$rasters = c(ws_env$rasters, out_name, dir_name, problem_name)

	## gather data
	res = .read_rasters(out_name, file)

	## clean up files
	.clean_grass()

	res
}


library(ggplot2)
library(cowplot)
library(randomForest)

## NOTE: The data used in this demo comes from the UCI machine learning
## repository.
## http://archive.ics.uci.edu/ml/index.php
## Specifically, this is the heart disease data set.
## http://archive.ics.uci.edu/ml/datasets/Heart+Disease
##
## SOURCE: https://statquest.org/2018/02/26/statquest-random-forests-in-r/
url <- "http://archive.ics.uci.edu/ml/machine-learning-databases/heart-disease/processed.cleveland.data"

data <- read.csv(url, header=FALSE)

#####################################
##
## Reformat the data so that it is
## 1) Easy to use (add nice column names)
## 2) Interpreted correctly by randomForest..
##
#####################################
head(data) # you see data, but no column names

colnames(data) <- c(
  "age",
  "sex",# 0 = female, 1 = male
  "cp", # chest pain
          # 1 = typical angina,
          # 2 = atypical angina,
          # 3 = non-anginal pain,
          # 4 = asymptomatic
  "trestbps", # resting blood pressure (in mm Hg)
  "chol", # serum cholestoral in mg/dl
  "fbs",  # fasting blood sugar greater than 120 mg/dl, 1 = TRUE, 0 = FALSE
  "restecg", # resting electrocardiographic results
          # 1 = normal
          # 2 = having ST-T wave abnormality
          # 3 = showing probable or definite left ventricular hypertrophy
  "thalach", # maximum heart rate achieved
  "exang",   # exercise induced angina, 1 = yes, 0 = no
  "oldpeak", # ST depression induced by exercise relative to rest
  "slope", # the slope of the peak exercise ST segment
          # 1 = upsloping
          # 2 = flat
          # 3 = downsloping
  "ca", # number of major vessels (0-3) colored by fluoroscopy
  "thal", # this is short of thalium heart scan
          # 3 = normal (no cold spots)
          # 6 = fixed defect (cold spots during rest and exercise)
          # 7 = reversible defect (when cold spots only appear during exercise)
  "hd" # (the predicted attribute) - diagnosis of heart disease
          # 0 if less than or equal to 50% diameter narrowing
          # 1 if greater than 50% diameter narrowing
  )

head(data) # now we have data and column names

str(data) # this shows that we need to tell R which columns contain factors
          # it also shows us that there are some missing values. There are "?"s
          # in the dataset.

## First, replace "?"s with NAs.
data[data == "?"] <- NA

## Now add factors for variables that are factors and clean up the factors
## that had missing data...
data[data$sex == 0,]$sex <- "F"
data[data$sex == 1,]$sex <- "M"
data$sex <- as.factor(data$sex)

data$cp <- as.factor(data$cp)
data$fbs <- as.factor(data$fbs)
data$restecg <- as.factor(data$restecg)
data$exang <- as.factor(data$exang)
data$slope <- as.factor(data$slope)

data$ca <- as.integer(data$ca) # since this column had "?"s in it (which
                               # we have since converted to NAs) R thinks that
                               # the levels for the factor are strings, but
                               # we know they are integers, so we'll first
                               # convert the strings to integiers...
data$ca <- as.factor(data$ca)  # ...then convert the integers to factor levels

data$thal <- as.integer(data$thal) # "thal" also had "?"s in it.
data$thal <- as.factor(data$thal)

## This next line replaces 0 and 1 with "Healthy" and "Unhealthy"
data$hd <- ifelse(test=data$hd == 0, yes="Healthy", no="Unhealthy")
data$hd <- as.factor(data$hd) # Now convert to a factor

str(data) ## this shows that the correct columns are factors and we've replaced
  ## "?"s with NAs because "?" no longer appears in the list of factors
  ## for "ca" and "thal"

#####################################
##
## Now we are ready to build a random forest.
##
#####################################
set.seed(42)

## NOTE: For most machine learning methods, you need to divide the data
## manually into a "training" set and a "test" set. This allows you to train
## the method using the training data, and then test it on data it was not
## originally trained on.
##
## In contrast, Random Forests split the data into "training" and "test" sets
## for you. This is because Random Forests use bootstrapped
## data, and thus, not every sample is used to build every tree. The
## "training" dataset is the bootstrapped data and the "test" dataset is
## the remaining samples. The remaining samples are called
## the "Out-Of-Bag" (OOB) data.

## impute any missing values in the training set using proximities
data.imputed <- rfImpute(hd ~ ., data = data, iter=6)
## NOTE: iter = the number of iterations to run. Breiman says 4 to 6 iterations
## is usually good enough. With this dataset, when we set iter=6, OOB-error
## bounces around between 17% and 18%. When we set iter=20,
# set.seed(42)
# data.imputed <- rfImpute(hd ~ ., data = data, iter=20)
## we get values a little better and a little worse, so doing more
## iterations doesn't improve the situation.
##
## NOTE: If you really want to micromanage how rfImpute(),
## you can change the number of trees it makes (the default is 300) and the
## number of variables that it will consider at each step.

## Now we are ready to build a random forest.

## NOTE: If the thing we're trying to predict (in this case it is
## whether or not someone has heart disease) is a continuous number
## (i.e. "weight" or "height"), then by default, randomForest() will set
## "mtry", the number of variables to consider at each step,
## to the total number of variables divided by 3 (rounded down), or to 1
## (if the division results in a value less than 1).
## If the thing we're trying to predict is a "factor" (i.e. either "yes/no"
## or "ranked"), then randomForest() will set mtry to
## the square root of the number of variables (rounded down to the next
## integer value).

## In this example, "hd", the thing we are trying to predict, is a factor and
## there are 13 variables. So by default, randomForest() will set
## mtry = sqrt(13) = 3.6 rounded down = 3
## Also, by default random forest generates 500 trees (NOTE: rfImpute() only
## generates 300 tress by default)
model <- randomForest(hd ~ ., data=data.imputed, proximity=TRUE)

## RandomForest returns all kinds of things
model # gives us an overview of the call, along with...
      # 1) The OOB error rate for the forest with ntree trees.
      #    In this case ntree=500 by default
      # 2) The confusion matrix for the forest with ntree trees.
      #    The confusion matrix is laid out like this:
#
#                Healthy                      Unhealthy
#          --------------------------------------------------------------
# Healthy  | Number of healthy people   | Number of healthy people      |
#          | correctly called "healthy" | incorectly called "unhealthy" |
#          | by the forest.             | by the forest                 |
#          --------------------------------------------------------------
# Unhealthy| Number of unhealthy people | Number of unhealthy peole     |
#          | incorrectly called         | correctly called "unhealthy"  |
#          | "healthy" by the forest    | by the forest                 |
#          --------------------------------------------------------------

## Now check to see if the random forest is actually big enough...
## Up to a point, the more trees in the forest, the better. You can tell when
## you've made enough when the OOB no longer improves.
oob.error.data <- data.frame(
  Trees=rep(1:nrow(model$err.rate), times=3),
  Type=rep(c("OOB", "Healthy", "Unhealthy"), each=nrow(model$err.rate)),
  Error=c(model$err.rate[,"OOB"],
    model$err.rate[,"Healthy"],
    model$err.rate[,"Unhealthy"]))

ggplot(data=oob.error.data, aes(x=Trees, y=Error)) +
  geom_line(aes(color=Type))
# ggsave("oob_error_rate_500_trees.pdf")

## Blue line = The error rate specifically for calling "Unheathly" patients that
## are OOB.
##
## Green line = The overall OOB error rate.
##
## Red line = The error rate specifically for calling "Healthy" patients
## that are OOB.

## NOTE: After building a random forest with 500 tress, the graph does not make
## it clear that the OOB-error has settled on a value or, if we added more
## trees, it would continue to decrease.
## So we do the whole thing again, but this time add more trees.

model <- randomForest(hd ~ ., data=data.imputed, ntree=1000, proximity=TRUE)
model

oob.error.data <- data.frame(
  Trees=rep(1:nrow(model$err.rate), times=3),
  Type=rep(c("OOB", "Healthy", "Unhealthy"), each=nrow(model$err.rate)),
  Error=c(model$err.rate[,"OOB"],
    model$err.rate[,"Healthy"],
    model$err.rate[,"Unhealthy"]))

ggplot(data=oob.error.data, aes(x=Trees, y=Error)) +
  geom_line(aes(color=Type))
# ggsave("oob_error_rate_1000_trees.pdf")

## After building a random forest with 1,000 trees, we get the same OOB-error
## 16.5% and we can see convergence in the graph. So we could have gotten
## away with only 500 trees, but we wouldn't have been sure that number
## was enough.

## If we want to compare this random forest to others with different values for
## mtry (to control how many variables are considered at each step)...
oob.values <- vector(length=10)
for(i in 1:10) {
  temp.model <- randomForest(hd ~ ., data=data.imputed, mtry=i, ntree=1000)
  oob.values[i] <- temp.model$err.rate[nrow(temp.model$err.rate),1]
}
oob.values
## [1] 0.1716172 0.1716172 0.1617162 0.1848185 0.1749175 0.1947195 0.1815182
## [8] 0.2013201 0.1881188 0.1947195
## The lowest value is when mtry=3, so the default setting was the best.

## Now let's create an MDS-plot to show how the samples are related to each
## other.
##
## Start by converting the proximity matrix into a distance matrix.
distance.matrix <- dist(1-model$proximity)

mds.stuff <- cmdscale(distance.matrix, eig=TRUE, x.ret=TRUE)

## calculate the percentage of variation that each MDS axis accounts for...
mds.var.per <- round(mds.stuff$eig/sum(mds.stuff$eig)*100, 1)

## now make a fancy looking plot that shows the MDS axes and the variation:
mds.values <- mds.stuff$points
mds.data <- data.frame(Sample=rownames(mds.values),
  X=mds.values[,1],
  Y=mds.values[,2],
  Status=data.imputed$hd)

ggplot(data=mds.data, aes(x=X, y=Y, label=Sample)) +
  geom_text(aes(color=Status)) +
  theme_bw() +
  xlab(paste("MDS1 - ", mds.var.per[1], "%", sep="")) +
  ylab(paste("MDS2 - ", mds.var.per[2], "%", sep="")) +
  ggtitle("MDS plot using (1 - Random Forest Proximities)")


#' Match a specific date
#'
#' Create an indicator variables for a specific date (year, month, day) for a weekly time series as defined in \code{tis}.
#'
#' @param x Numeric tis object.
#' @param date_string Character string; Year, month and day of the date (Example - January 1, 1990 is '19900101').
#' @return An indicator variable where the week contains the date entered = 1, 0 otherwise.
#' @examples
#' pandemic_start <- match_date(ic_week, '20200317')
#' @import stats
#' @export
match_date <- function(x, date_string) {
    # Author: Brian C. Monsell (OEUS), Version 1.4, 3/23/2021

    # generate a vector of strings of dates associated with weekly observations.
    ymd_string <- as.character(tis::ymd(tis::ti(x)))

    # initialize indicator variable with 0
    dummy <- array(0, dim = length(x))

    # set observation matching the date to 1
    dummy[ymd_string == date_string] <- 1

    # return indicator variable
    return(dummy)
}


#' FLOPs Benchmark Plotter
#'
#' @param groupby
#' Should operations be grouped by "color" or by "shape"?  The
#' latter is useful when black/white plots are needed.
#'
#' @examples
#' \dontrun{
#' library(pbdPAPI)
#' data <- list(rnorm(1e4), rnorm(2e4), rnorm(3e4))
#' x <- flopsbench(exp, sqrt, sum, data=data)
#'
#' library(hpcvis)
#' papiplot(x)
#' papiplot(x, groupby="shape")
#' }
#'
#' @rdname papiplot
#' @method papiplot flopsbench
#' @export
papiplot.flopsbench <- function(x, ..., title, opnames, groupby="color")
{
  groupby <- match.arg(tolower(groupby), c("color", "shape"))

  if (!missing(opnames))
  {
    if (length(opnames) != length(x))
      stop("argument 'opnames' is of incorrect length")

    names(x) <- opnames
  }

  df <- lapply(x, as.data.frame)
  nm <- names(df)
  df <- lapply(1:length(df), function(i) cbind(df[[i]], nm[i]))
  df <- do.call(rbind, df)
  names(df)[length(df)] <- "Operation"
  df$operation <- factor(df$Operation)

  g <- ggplot(df, aes_string("n", "mflops", group="Operation")) +
    theme_bw() +
    ylab("Megaflops")

  if (groupby == "color")
    g <- g + geom_line(aes(color=Operation)) + geom_point(aes(color=Operation))
  else if (groupby == "shape")
    g <- g + geom_point(aes(shape=Operation))

  if (missing(title))
    g <- g + ggtitle("Floating Point Operations Benchmark")
  else if (!is.null(title))
    g <- g + ggtitle(title)

  g
}


#' @export
TestResult <- function(test_name, H0_description, test_statistic, distribution, ...){
    crit_values <- critical_values(distribution=distribution, ...)

    test_result <- structure(list("test" = test_name,
                                  "H0"= H0_description,
                                  "test_statistic" = test_statistic,
                                  "critical_values" = crit_values),
                            class="TestResult")
    return(test_result)
}

#' @export
print.TestResult <- function(test_result){
    cat(paste0("\033[1m", test_result$test, "\033[0m\n")) # Bold font for test name
    cat("Null Hypothesis (H0): ", test_result$H0, "\n\n")
    cat("Test Statistic = ", test_result$test_statistic, "\n\n")
    cat(capture.output(test_result$critical_values), sep="\n")
}


#install.packages('rJava', type='mac.binary')
#install.packages('xlsx', type='mac.binary')
{
  library("xlsx")

  #Устанавливаем директорию
  setwd("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/analytics")

  #Цикл по каждому товару. Надеемся на то, что во всех магазах одинаковые товары
  goods.table <- read.table(file = 'store1_price.txt', head = TRUE)
  goods <- goods.table[, 1]

  ############ Работаем только с таблицей .csv и .xlsx #########################

  for (prod in goods) {
    #Индекс продукта
    element_index <- which(goods.table == prod)
    #Цена продажи
    product_price <- goods.table[element_index, 3]
    #Цена поставки
    supply_price <- goods.table[element_index, 2]
    #Цена утилизации
    util_price <- goods.table[element_index, 4]

    #Названия магазинов
    shop_names <- c()
    #Выручка
    shop_revenues <- c()
    #Прибыль
    shop_profits <- c()
    #Реализация
    shop_sales <- c()
    #Списание
    shop_writeoffs <- c()
    #Равномерность продаж
    shop_sr <- c()
    #Продажи макс
    shop_sales_max <- c()
    #День продажи макс
    shop_sales_maxdays <- c()
    #Продажи мин
    shop_sales_min <- c()
    #День продажи мин
    shop_sales_mindays <- c()
    #Списание макс
    shop_writeoff_max <- c()
    #День списания макс
    shop_writeoff_maxdays <- c()

    #Цикл по каждому магазину
    for (i in 1:10) {
      in1 <-
        read.table(file = paste0('store', as.character(i), '_in.txt'),
                   head = TRUE)

      out1 <-
        read.table(file = paste0('store', as.character(i), '_out.txt'),
                   head = TRUE)

      # Название магазина
      shop_names <-
        append(shop_names, paste0('shop', as.character(i)))

      # Списание
      buf_writeoff <- sum(in1[, prod]) - sum(out1[, prod])
      shop_writeoffs <- append(shop_writeoffs, buf_writeoff)

      # Выручка
      buf_shoprevenue <- product_price * sum(out1[, prod])
      shop_revenues <- append(shop_revenues, buf_shoprevenue)

      # Затраты
      buf_cost <-
        (sum(in1[, prod]) * supply_price) + (buf_writeoff * util_price)

      # Прибыль
      shop_profits <-
        append(shop_profits, buf_shoprevenue - buf_cost)

      # Реализация
      shop_sales <- append(shop_sales, sum(out1[, prod]))

      # Равномерность продаж
      shop_sr <- append(shop_sr, sd(out1[, prod]))

      # Продажи макс
      shop_sales_max <- append(shop_sales_max, max(out1[, prod]))

      # День продажи макс
      shop_sales_maxdays <-
        append(shop_sales_maxdays, out1[which.max(out1[, prod]), 1])

      # Продажи мин
      shop_sales_min <- append(shop_sales_min, min(out1[, prod]))

      # День продажи мин
      shop_sales_mindays <-
        append(shop_sales_mindays, out1[which.min(out1[, prod]), 1])

      # Списание макс
      shop_writeoff_max <-
        append(shop_writeoff_max, max(c(in1[, prod] - out1[, prod])))

      # День списания макс
      shop_writeoff_maxdays <-
        append(shop_writeoff_maxdays, in1[which.max(c(in1[, prod] - out1[, prod])), 1])
    }

    #Высчитываем итог и среднее для выручки, прибыли, реализации, списании, равномерности
    shop_names <- c(shop_names, c("Итог", "Среднее"))
    shop_revenues <-
      c(shop_revenues, c(sum(shop_revenues), mean(shop_revenues)))
    shop_profits <-
      c(shop_profits, c(sum(shop_profits), mean(shop_profits)))
    shop_sales <-
      c(shop_sales, c(sum(shop_sales), mean(shop_sales)))
    shop_writeoffs <-
      c(shop_writeoffs, c(sum(shop_writeoffs), mean(shop_writeoffs)))
    shop_sr <- c(shop_sr, c(sum(shop_sr), mean(shop_sr)))
    shop_sales_max <- c(shop_sales_max, c("", ""))
    shop_sales_maxdays <- c(shop_sales_maxdays, c("", ""))
    shop_sales_min <- c(shop_sales_min, c("", ""))
    shop_sales_mindays <- c(shop_sales_mindays, c("", ""))
    shop_writeoff_max <- c(shop_writeoff_max, c("", ""))
    shop_writeoff_maxdays <- c(shop_writeoff_maxdays, c("", ""))

    #Формируем датафрейм
    table <-
      data.frame(
        shop_names,
        shop_revenues,
        shop_profits,
        shop_sales ,
        shop_writeoffs,
        shop_sr,
        shop_sales_max,
        shop_sales_maxdays,
        shop_sales_min,
        shop_sales_mindays,
        shop_writeoff_max,
        shop_writeoff_maxdays
      )

    #Проставляем заголовки
    col_headings <-
      c(
        "Магазин" ,
        "Выручка, руб" ,
        "Прибыль",
        "Реализация" ,
        "Списание, конт.",
        "Равномерность продаж" ,
        "Продажи макс",
        "День продажи макс",
        "Продажи мин",
        "День продажи мин" ,
        "Списание макс",
        "День макс списания"
      )
    names(table) <- col_headings

    # Запись в .csv
    write.table(
      table,
      file = paste0(
        "/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/таблица_",
        prod,
        ".csv"
      ),
      col.names = TRUE,
      row.names = FALSE,
      sep = ';',
      dec = ',',
      fileEncoding = 'UTF-8'
    )

    # Запись в .xlsx (это чтоб на маке отображалось корректно)
    write.xlsx(
      table,
      file = paste0(
        "/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/таблица_",
        prod,
        ".xlsx"
      ),
      sheetName = "DATA",
      col.names = TRUE,
      row.names = FALSE,
      append = FALSE
    )
  }

  ######################## Формируем графики ###################################

  # Вектор всех возможных цветов для построения товаров
  plot_colors <- c("red3","forestgreen", "steelblue", "darkgreen","darkolivegreen3", "darkorange1","firebrick1","gold1", "lightcoral","mediumvioletred","navyblue", "tan1","turquoise1","chocolate1","blue","black","brown", "darkseagreen" )
  # Вектор всех возможных значков для товаров
  plot_pchs <- seq(15,25)

  #Общая выручка со всех магазинов и со всех продуктов
  super_summ_shoprevenue  <- rep(0,7)
  #Общая прибыль со всех магазинов и со всех продуктов
  super_summ_shopprofits <- rep(0,7)
  #Общее списание со всех магазинов и со всех продуктов
  super_summ_writeoffs <- rep(0,7)

  #Датафрейм с прибылью
  super_df_shopprofits <- data.frame(buf=rep(0,7))
  #Датафрейм с рентабельностью
  super_df_profitability <- data.frame(buf=rep(0,7))

  #Список датафреймов всего товара по магазинам. Нужен для динамики продаж всех товаров по всем магазина
  goods_list <- list()
  #Цикл по каждому магазу
  for (i in 1:10) {
    in1 <- read.table(file = paste0('store',as.character(i),'_in.txt'), head = TRUE)
    out1 <- read.table(file = paste0('store',as.character(i),'_out.txt'), head = TRUE)
    price1 <- read.table(file = paste0('store',as.character(i),'_price.txt'), head = TRUE)

    #Общая выручка со всех продуктов
    summ_shopprofits <- rep(0,7)
    summ_shoprevenue <- rep(0,7)
    summ_writeoffs <- rep(0,7)

    #Датафреймы по каждому продукту для вывода единых графиков с несколькими продуктами
    #объем продаж
    df_salesvolume <- data.frame(buf=rep(0,7))
    #выручка
    df_shoprevenue <- data.frame(buf=rep(0,7))
    #прибыль
    df_shopprofits <- data.frame(buf=rep(0,7))
    #Списание
    df_writeoffs <- data.frame(buf=rep(0,7))
    #Рентабельность
    df_profitability <- data.frame(buf=rep(0,7))

    #Цикл по каждому продукту в каждом магазине
    for (prod in goods){

      element_index <- which(goods.table == prod)
      #Цена продажи
      product_price <- goods.table[element_index, 3]
      #Цена поставки
      supply_price <- goods.table[element_index, 2]
      #Цена утилизации
      util_price <- goods.table[element_index, 4]

      # Выручка
      buf_shoprevenue <- product_price * out1[, prod]
      png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Выручка магазин ",as.character(i)," (",prod,").png"),width=600, height=450)
      plot(buf_shoprevenue, main=paste0('Выручка по дням в магазине ',as.character(i),' (',prod,')'), xlab='День', ylab=paste0("Выручка по товару '",prod,"', руб."),type='o')
      dev.off()

      # Списание
      buf_writeoff <- in1[, prod] - out1[, prod]
      xrange <- range(seq(1,7))
      yrange <- range(buf_writeoff)
      png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Списание магазин ",as.character(i)," (",prod,").png"),width=600, height=450)
      plot(xrange,
           yrange,
           main=paste0('Списание ',prod,' в ',as.character(i),' магазине'),
           xlab="День",
           ylab="Списание, шт.",
           type = "n"
           )
      points(seq(1,7), buf_writeoff, pch=19, col="red")
      lines(seq(1,7), buf_writeoff, pch=19, col="black")
      dev.off()

      # Затраты
      buf_cost <- (in1[, prod] * supply_price) + (buf_writeoff * util_price)
      # Прибыль
      shop_profits <- buf_shoprevenue - buf_cost

      png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Прибыль магазин ",as.character(i)," (",prod,").png"),width=600, height=450)
      plot(shop_profits, main=paste0('Прибыль по дням в ',as.character(i),' магазине (',prod,')'), xlab='День', ylab='Прибыль, .руб.',type='S')
      dev.off()

      #Добавляем данные во фреймы для построения графиков ниже
      #Объём продаж
      df_salesvolume <- data.frame(df_salesvolume, out1[, prod])
      #выручка
      df_shoprevenue <- data.frame(df_shoprevenue, buf_shoprevenue)
      #прибыль
      df_shopprofits <- data.frame(df_shopprofits, shop_profits)
      #Списание
      df_writeoffs <- data.frame(df_writeoffs, buf_writeoff)
      #Рентабельность
      df_profitability <- data.frame(df_profitability, floor((shop_profits/buf_shoprevenue) * 100))

      #Прибавляем к сумме выручки
      summ_shoprevenue <- summ_shoprevenue + buf_shoprevenue
      #Прибавляем к сумме прибыли
      summ_shopprofits <- summ_shopprofits + shop_profits
      #Прибавляем к сумме списаний
      summ_writeoffs <- summ_writeoffs + buf_writeoff

    }

    ############################################Графики с несколькими товарами на одном графике##########################

    #График объёма продаж товарав в магазине по дням
    df_salesvolume <- subset(df_salesvolume, select = -c(buf))
    names(df_salesvolume) <- goods
    #Закидываем в list
    goods_list[[paste0("shop",as.character(i))]] <- df_salesvolume
    xrange <- range(seq(1,7))
    yrange <- range(df_salesvolume)
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Объём продаж магазин ",as.character(i),".png"),width=600, height=450)
    graph <- plot(xrange,
                  yrange,
                  main=paste0('Объём продаж в магазине ',as.character(i)," по товарам"),
                  xlab="День недели",
                  ylab="Количество проданного товара, шт",
                  type = "n",
    )
    for (j in 1:length(goods)){
      points(seq(1,7),df_salesvolume[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
      lines(seq(1,7), df_salesvolume[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
    }
    legend("topright", legend=goods,col=plot_colors, pch=plot_pchs)
    dev.off()

    #График выручки от товарав по дням
    df_shoprevenue <- subset(df_shoprevenue, select = -c(buf))
    names(df_shoprevenue) <- goods
    xrange <- range(seq(1,7))
    yrange <- range(df_shoprevenue)
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Выручка магазин ",as.character(i),".png"),width=600, height=450)
    graph <- plot(xrange,
                  yrange,
                  main=paste0('Выручка в магазине ',as.character(i)," по товарам"),
                  xlab="День недели",
                  ylab="Выручка, руб",
                  type = "n",
    )
    for (j in 1:length(goods)){
      points(seq(1,7),df_shoprevenue[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
      lines(seq(1,7), df_shoprevenue[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
    }
    legend("topright", legend=goods,col=plot_colors, pch=plot_pchs)
    dev.off()

    # График прибыли от товарав по дням
    df_shopprofits <- subset(df_shopprofits, select = -c(buf))
    names(df_shopprofits) <- goods
    xrange <- range(seq(1,7))
    yrange <- range(df_shopprofits)
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Прибыль магазин ",as.character(i),".png"),width=600, height=450)
    graph <- plot(xrange,
                  yrange,
                  main=paste0('Прибыль в магазине ',as.character(i)," по товарам"),
                  xlab="День недели",
                  ylab="Прибыль, руб",
                  type = "n",
    )
    for (j in 1:length(goods)){
      points(seq(1,7),df_shopprofits[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
      lines(seq(1,7), df_shopprofits[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
    }
    legend("topright", legend=goods,col=plot_colors, pch=plot_pchs)
    dev.off()

    # График списания товарав по дням
    df_writeoffs <- subset(df_writeoffs, select = -c(buf))
    names(df_writeoffs) <- goods
    xrange <- range(seq(1,7))
    yrange <- range(df_writeoffs)
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Списания магазин ",as.character(i),".png"),width=600, height=450)
    graph <- plot(xrange,
                  yrange,
                  main=paste0('Списания в магазине ',as.character(i)," по товарам"),
                  xlab="День недели",
                  ylab="Количество списанного товара, шт",
                  type = "n",
    )
    for (j in 1:length(goods)){
      points(seq(1,7),df_writeoffs[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
      lines(seq(1,7), df_writeoffs[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
    }
    legend("topright", legend=goods,col=plot_colors, pch=plot_pchs)
    dev.off()

    # График рентабельности товарав по дням
    df_profitability <- subset(df_profitability, select = -c(buf))
    names(df_profitability) <- goods
    xrange <- range(seq(1,7))
    yrange <- range(df_profitability)
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Рентабельность магазин ",as.character(i),".png"),width=600, height=450)
    graph <- plot(xrange,
                  yrange,
                  main=paste0('Рентабельность в магазине ',as.character(i)," по товарам"),
                  xlab="День",
                  ylab="Рентабельность, %",
                  type = "n"
    )
    for (j in 1:length(goods)){
      points(seq(1,7),df_profitability[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
      lines(seq(1,7), df_profitability[, goods[j]], pch=plot_pchs[j], col=plot_colors[j])
    }
    legend("topright", legend=goods,col=plot_colors, pch=plot_pchs)
    dev.off()

    #Строим общий график выручки по дням
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Общая выручка магазин ",as.character(i),".png"),width=600, height=450)
    plot(summ_shoprevenue, main=paste0('Выручка по дням в магазине ',as.character(i)), xlab='День', ylab=paste0("Общая выручка, руб."),type='o')
    dev.off()

    #Строим общий график прибыли по дням
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Общая прибыль магазин ",as.character(i),".png"),width=600, height=450)
    plot(summ_shopprofits, main=paste0('Прибыль по дням в магазине ',as.character(i)), xlab='День', ylab='Общая прибыль, руб.',type='S')
    dev.off()

    #Строим общий график списаний по дням
    xrange <- range(seq(1,7))
    yrange <- range(summ_writeoffs)
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Общее списание магазин ",as.character(i),".png"),width=600, height=450)
    plot(xrange,yrange,main=paste0('Списания по дням в ',as.character(i),' магазине'), xlab="День", ylab="Списание, шт.", type = "n")
    points(seq(1,7), summ_writeoffs, pch=19, col="red")
    lines(seq(1,7), summ_writeoffs, pch=19, col="black")
    dev.off()

    #Строим график рентабельности для магазина
    summ_profitability <- floor((summ_shopprofits/summ_shoprevenue) * 100)
    xrange <- range(seq(1,7))
    yrange <- range(summ_profitability)
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/shop",as.character(i),"/Общая рентабельность магазин ",as.character(i),".png"),width=600, height=450)
    plot(xrange,
         yrange,
         main=paste("Рентабельность по дням в",as.character(i),"магазине"),
         xlab="День",
         ylab="Рентабельность, %",
         type = "n"
    )
    lines(seq(1,7), summ_profitability, pch=20, col="red3",lwd = 3, lty = 2)
    dev.off()

    #Прибавляем выручку к общей выручке
    super_summ_shoprevenue <- super_summ_shoprevenue + summ_shoprevenue
    #Прибавляем прибыль к общей прибыли
    super_summ_shopprofits <- super_summ_shopprofits + summ_shopprofits
    #Прибавляем списания к общим списаниям
    super_summ_writeoffs <- super_summ_writeoffs + summ_writeoffs

    #Прибавляем к датафрейму рентабельности
    super_df_profitability <- data.frame(super_df_profitability, summ_profitability)
    #Прибавляем к датафрейму прибыли
    super_df_shopprofits <- data.frame(super_df_shopprofits, summ_shopprofits)

  }

  #Строим график общей выручки
  super_summ_shoprevenue1 <- super_summ_shoprevenue / 1000
  png(file="/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/Общая выручка.png", width=600, height=450)
  plot(super_summ_shoprevenue1, main='Выручка во всех магазинах по дням', xlab='День', ylab="Общая выручка, тыс руб.",type='o')
  dev.off()

  #Строим график общей прибыли
  super_summ_shopprofits1 <- super_summ_shopprofits / 1000
  png(file="/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/Общая прибыль.png", width=600, height=450)
  plot(super_summ_shopprofits1, main='Прибыль во всех магазинах по дням', xlab='День', ylab='Общая прибыль, тыс руб.',type='S')
  dev.off()

  #Строим график общих списаний
  xrange <- range(seq(1,7))
  yrange <- range(super_summ_writeoffs)
  png(file="/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/Общее списание.png",width=600, height=450)
  plot(xrange,yrange,main='Списание во всех магазинах по дням', xlab="День", ylab="Списание, шт.", type = "n")
  points(seq(1,7), super_summ_writeoffs, pch=19, col="red")
  lines(seq(1,7), super_summ_writeoffs, pch=19, col="black")
  dev.off()

  #Строим график рентабельности
  super_summ_profitability <- floor((super_summ_shopprofits/super_summ_shoprevenue) * 100)
  xrange <- range(seq(1,7))
  yrange <- range(super_summ_profitability)
  png(file="/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/Общая рентабельность.png",width=600, height=450)
  plot(xrange,
       yrange,
       main="Рентабельность по дням общая",
       xlab="День",
       ylab="Рентабельность, %",
       type = "n"
  )
  lines(seq(1,7), super_summ_profitability, pch=20, col="red3",lwd = 3, lty = 2)
  dev.off()

  ########################Строим сложный график рентабельности##########################
  #Выкидываем нулевой столбец
  super_df_profitability <- subset(super_df_profitability, select = -c(buf))
  #Присваиваем имена столбцам для обращения по ним
  names(super_df_profitability) <- paste0("shop",as.character(seq(1,10)))
  xrange <- range(seq(1,7))
  yrange <- range(super_df_profitability)
  png(file="/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/Общая рентабельность подробно.png",width=716, height=630)
  plot(xrange,
       yrange,
       main='Рентабельность по дням в магазинах',
       xlab="День",
       ylab="Рентабельность, %",
       type = "n"
    )
  for (i in 1:length(super_df_profitability)){
    points(seq(1,7), super_df_profitability[,paste0("shop",as.character(i))], pch=19, col=plot_colors[i])
  }
  legend("bottomleft", legend=paste("Магазин", seq(1,10)),col=plot_colors,pch=c(19))
  dev.off()

  ########################Строим сложный график прибыли##########################
  #Выкидываем нулевой столбец
  super_df_shopprofits <- subset(super_df_shopprofits, select = -c(buf))
  #Присваиваем имена столбцам для обращения по ним
  names(super_df_shopprofits) <- paste0("shop",as.character(seq(1,10)))
  super_df_shopprofits <- super_df_shopprofits / 1000
  xrange <- range(seq(1,7))
  yrange <- range(super_df_shopprofits)
  png(file="/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/Общая прибыль подробно.png",width=716, height=630)
  plot(xrange,
       yrange,
       main='Прибыль по дням в магазинах',
       xlab="День",
       ylab="Прибыль, тыс руб",
       type = "n"
  )
  for (i in 1:length(super_df_shopprofits)){
    points(seq(1,7), super_df_shopprofits[,paste0("shop",as.character(i))], pch=18, col=plot_colors[i], cex=2.0)
  }
  legend("bottomleft", legend=paste("Магазин", seq(1,10)),col=plot_colors,pch=c(18))
  dev.off()

  ############################График динамики продаж товаров по всем магазинам#####################
  #Каждый магазин выделять своим цветом
  #Каждый товар выделять своим значком.

  xrange <- range(seq(1,7))
  yrange <- range(goods_list)
  png(file="/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/Динамика продаж товаров.png",width=800, height=1000)
  plot(xrange,
       yrange,
       main='Динамика продаж товаров по всем магазинам',
       xlab="День",
       ylab="Продажа, шт.",
       type = "n"
  )
  for (i in 1:length(goods_list)){
    for (j in 1:length(goods_list[[paste0("shop",as.character(i))]])){
      points(seq(1,7), goods_list[[paste0("shop",as.character(i))]][j][, 1], pch=plot_pchs[j], col=plot_colors[i])
    }
  }
  legend("bottomright", legend=paste("Магазин", seq(1,10)),col=plot_colors,pch=19)
  legend("topright", legend=goods,col="black",pch=plot_pchs)
  dev.off()

  #Подготовить диаграмму, на которой будет представлены объемы
  #продаж одного товара сразу по всем магазинам. Каждый магазин
  #выделять своим цветом.

  for (good in goods){

    #Значения
    good_values <- c()
    for (i in 1:length(goods_list)){

      value <- goods_list[[paste0("shop",as.character(i))]][, good]
      #Записываем сумму товара за неделю
      good_values <- append(good_values, sum(value))

    }
    png(file=paste0("/Users/georgiydemo/Projects/FA/Course II/R/Diksi/result/graph/Объём продаж ",good,".png"),width=650, height=500)
    barplot(height = good_values, names=seq(1,10),main=paste0('Объём продаж товара ', good, " по магазинам"), col="#69b3a2",xlab="№ магазина", ylab="Объём продаж, шт")
    dev.off()
  }

  print("Завершение работы скрипта")

}


ggplot(aes(x=condition, y=diff), data=d) + stat_summary(fun.data="mean_cl_boot", aes(color=type)) + stat_summary(fun.y=mean, geom="line", aes(color=type, group=type)) + ylab('Annotated time - aligned time (s)') + scale_color_hue(name = 'Timepoint', labels = c('Onset of vowel', 'Vowel-consonant boundary', 'Consonant end')) + xlab('Alignment style')
ggsave('overall.pdf',width = 6, height = 4, units = 'in', dpi =300)

ggplot(aes(x=prec_consonant, y=diff), data=subset(d, type == 'vowel_begin')) + stat_summary(fun.data="mean_cl_boot", aes(color=condition)) + stat_summary(fun.y=mean, geom="line", aes(color=condition, group=condition)) + ylab('Annotated time - aligned time (s)') +ggtitle('Vowel onset data only') + xlab('Previous consonant') + scale_color_hue(name = 'Alignment style')
ggsave('vowelonset.pdf',width = 6, height = 4, units = 'in', dpi =300)

ggplot(aes(x=foll_consonant, y=diff), data=subset(d, type != 'vowel_begin')) + stat_summary(fun.data="mean_cl_boot", aes(color=condition, shape = condition, group = interaction(condition,type))) + stat_summary(fun.y=mean, geom="line", aes(color=condition, group=interaction(condition,type), linetype = type)) + ylab('Annotated time - aligned time (s)') + facet_wrap(~type) +ggtitle('Consonant boundary data only')+ scale_linetype_discrete(name = 'Timepoint', labels = c('Vowel-consonant boundary', 'Consonant end')) + scale_color_discrete(name = 'Alignment style') + scale_shape_discrete(name = 'Alignment style') + xlab('Following consonant')
ggsave('consonantboundary.pdf',width = 6, height = 4, units = 'in', dpi =300)

ggplot(aes(x=vowel, y=diff), data=subset(d, type != 'cons_end')) + stat_summary(fun.data="mean_cl_boot", aes(color=condition, shape = condition, group = interaction(condition,type))) + stat_summary(fun.y=mean, geom="line", aes(color=condition, group=interaction(condition,type), linetype = type)) + ylab('Annotated time - aligned time (s)') + facet_wrap(~type)+ scale_linetype_discrete(name = 'Timepoint', labels = c('Vowel-consonant boundary', 'Consonant end')) + scale_color_discrete(name = 'Alignment style') + scale_shape_discrete(name = 'Alignment style') + xlab('Vowel')

#MAGNITUDE

ggplot(aes(x=condition, y=diff_mag), data=d) + stat_summary(fun.data="mean_cl_boot", aes(color=type)) + stat_summary(fun.y=mean, geom="line", aes(color=type, group=type)) + ylab('Annotated time - aligned time (s)') + scale_color_hue(name = 'Timepoint', labels = c('Onset of vowel', 'Vowel-consonant boundary', 'Consonant end')) + xlab('Alignment style')

ggplot(aes(x=prec_consonant, y=diff_mag), data=subset(d, type == 'vowel_begin')) + stat_summary(fun.data="mean_cl_boot", aes(color=condition)) + stat_summary(fun.y=mean, geom="line", aes(color=condition, group=condition)) + ylab('Annotated time - aligned time (s)') +ggtitle('Vowel onset data only') + xlab('Previous consonant') + scale_color_hue(name = 'Alignment style') + facet_wrap(~condition, scales='free')

ggplot(aes(x=foll_consonant, y=diff_mag), data=subset(d, type != 'vowel_begin')) + stat_summary(fun.data="mean_cl_boot", aes(color=condition, shape = condition, group = interaction(condition,type))) + stat_summary(fun.y=mean, geom="line", aes(color=condition, group=interaction(condition,type), linetype = type)) + ylab('Annotated time - aligned time (s)') + facet_wrap(~type) +ggtitle('Consonant boundary data only')+ scale_linetype_discrete(name = 'Timepoint', labels = c('Vowel-consonant boundary', 'Consonant end')) + scale_color_discrete(name = 'Alignment style') + scale_shape_discrete(name = 'Alignment style') + xlab('Following consonant')

ggplot(aes(x=vowel, y=diff_mag), data=subset(d, type != 'cons_end')) + stat_summary(fun.data="mean_cl_boot", aes(color=condition, shape = condition, group = interaction(condition,type))) + stat_summary(fun.y=mean, geom="line", aes(color=condition, group=interaction(condition,type), linetype = type)) + ylab('Annotated time - aligned time (s)') + facet_wrap(~type) +ggtitle('Consonant boundary data only')+ scale_linetype_discrete(name = 'Timepoint', labels = c('Vowel-consonant boundary', 'Consonant end')) + scale_color_discrete(name = 'Alignment style') + scale_shape_discrete(name = 'Alignment style') + xlab('Vowel')


# identify clusters of linked loci from ngsLD
# run after nsdLD_bypop.sh
# currently only set up for GATK no dam loci

#parameters
minr2 <- 0.5 # consider pairs of loci with r2 > minr2 to be linked

# functions
require(data.table)

# read in list of loci
gatk <- fread('data_2020.05.07/GATK_filtered_SNP_no_dam2.tab')
setnames(gatk, c('CHROM', 'POS', 'REF', 'ALT'))

# read in inversion coords
inv <- fread('data/inversions.csv')

# read in LD data (can do this for gatk loci only at this time). files from ngsLD_bypop.sh
ldCan40 <- fread('analysis/ld.Can_40.gatk.nodam.gz')
ldCan14 <- fread('analysis/ld.Can_14.gatk.nodam.gz')
ld07 <- fread('analysis/ld.Lof_07.gatk.nodam.gz')
ld11 <- fread('analysis/ld.Lof_11.gatk.nodam.gz')
ld14 <- fread('analysis/ld.Lof_14.gatk.nodam.gz')

# add column names
nms <- c('pos1nm', 'pos2nm', 'dist', 'r2', 'D', 'Dprime', 'r2em')
setnames(ldCan14, nms)
setnames(ldCan40, nms)
setnames(ld14, nms)
setnames(ld11, nms)
setnames(ld07, nms)

# make a chromosome column
ldCan40[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]
ldCan14[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]
ld07[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]
ld11[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]
ld14[, chr := vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 1)]

# remove unplaced
ldCan40 <- ldCan40[!(chr == 'Unplaced'), ]
ldCan14 <- ldCan14[!(chr == 'Unplaced'), ]
ld07 <- ld07[!(chr == 'Unplaced'), ]
ld11 <- ld11[!(chr == 'Unplaced'), ]
ld14 <- ld14[!(chr == 'Unplaced'), ]

# make position columns
ldCan40[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
ldCan40[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]
ldCan14[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
ldCan14[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]
ld07[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
ld07[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]
ld11[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
ld11[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]
ld14[, pos1 := as.numeric(vapply(strsplit(pos1nm, ":", fixed = TRUE), "[", "", 2))]
ld14[, pos2 := as.numeric(vapply(strsplit(pos2nm, ":", fixed = TRUE), "[", "", 2))]

# cluster loci into linkage blocks
# average r2 within a population
ldCan <- merge(ldCan40[ ,.(chr, pos1, pos2, r21 = r2)], ldCan14[ ,.(chr, pos1, pos2, r22 = r2)], all = TRUE)
ldCan[, r2 := rowMeans(cbind(r21, r22), na.rm = TRUE)]

ldLof <- merge(ld07[ ,.(chr, pos1, pos2, r21 = r2)], ld11[ ,.(chr, pos1, pos2, r22 = r2)], all = TRUE)
ldLof <- merge(ldLof, ld14[ ,.(chr, pos1, pos2, r23 = r2)], all = TRUE)
ldLof[, r2 := rowMeans(cbind(r21, r22, r23), na.rm = TRUE)]

rm(ldCan40, ldCan14, ld07, ld11, ld14)

# trim to locus pairs that are linked to cluster these
ldCan <- ldCan[r2 > minr2,]
ldLof <- ldLof[r2 > minr2,]

# order by r2
setorder(ldCan, chr, pos1, pos2)
setorder(ldLof, chr, pos1, pos2)

# find the most linked loci
ldcanpos1 <- ldCan[, .(numr21 = .N), by = .(chr, pos = pos1)] # number of linked loci for each locus (when listed in pos1)
ldcanpos2 <- ldCan[, .(numr22 = .N), by = .(chr, pos = pos2)] # for pos2
ldcanpos <- merge(ldcanpos1, ldcanpos2, all = TRUE) # merge
ldcanpos[, num := rowSums(cbind(numr21, numr22), na.rm = TRUE)] # total number of linked loci
setorder(ldcanpos, -num, chr, pos) # order decreasing by # linked loci

ldlofpos1 <- ldLof[, .(numr21 = .N), by = .(chr, pos = pos1)] # number of linked loci for each locus (when listed in pos1)
ldlofpos2 <- ldLof[, .(numr22 = .N), by = .(chr, pos = pos2)] # for pos2
ldlofpos <- merge(ldlofpos1, ldlofpos2, all = TRUE) # merge
ldlofpos[, num := rowSums(cbind(numr21, numr22), na.rm = TRUE)] # total number of linked loci
setorder(ldlofpos, -num, chr, pos) # decreasing by # linked loci

# label clusters in pairwise LD matrix
clustID <- 1 # for Can
ldCan[, cluster := NA_real_] # column for the cluster IDs in the pairwise LD dataset
nrow(ldcanpos)
for(i in 1:nrow(ldcanpos)){ # for each locus that is linked, working from most to least
  if(i %% 1000 == 0) cat(paste0(i, ' '))
  inds <- ldCan[, which(chr == ldcanpos$chr[i] & (pos1 == ldcanpos$pos[i] | pos2 == ldcanpos$pos[i]))] # get indices to pairwise ld that include this locus

  if(ldCan[inds, all(is.na(cluster))]){ # if no cluster IDs used yet for this locus
    ldCan[inds, cluster := clustID] # label with the next cluster ID
    clustID <- clustID + 1 # increment the cluster ID
  } else { # if a cluster ID (or more) has already been used
    thisclustIDs <- ldCan[inds, ][!is.na(cluster), unique(cluster)] # get the ID(s) already used
    if(length(thisclustIDs) == 1) ldCan[inds, cluster := thisclustIDs] # if only one, use it
    if(length(thisclustIDs) > 1){ # if the locus links two or more clusters
      thisclustID <- min(thisclustIDs) # pick the lowest cluster ID
      ldCan[cluster %in% thisclustIDs, cluster := thisclustID] # label all clusters with one ID
      ldCan[inds, cluster := thisclustID] # label this locus
    }
  }
}

clustID <- 1 # for Lof
ldLof[, cluster := NA_real_] # column for the cluster IDs in the pairwise LD dataset
nrow(ldlofpos)
for(i in 1:nrow(ldlofpos)){ # for each locus that is linked, working from most to least
  if(i %% 1000 == 0) cat(paste0(i, ' '))
  inds <- ldLof[, which(chr == ldlofpos$chr[i] & (pos1 == ldlofpos$pos[i] | pos2 == ldlofpos$pos[i]))] # get indices to pairwise ld that include this locus

  if(ldLof[inds, all(is.na(cluster))]){ # if no cluster IDs used yet for this locus
    ldLof[inds, cluster := clustID] # label with the next cluster ID
    clustID <- clustID + 1 # increment the cluster ID
  } else { # if a cluster ID (or more) has already been used
    thisclustIDs <- ldLof[inds, ][!is.na(cluster), unique(cluster)] # get the ID(s) already used
    if(length(thisclustIDs) == 1) ldLof[inds, cluster := thisclustIDs] # if only one cluster ID, use it
    if(length(thisclustIDs) > 1){ # if the locus links two or more clusters
      thisclustID <- min(thisclustIDs) # pick the lowest cluster ID
      ldLof[cluster %in% thisclustIDs, cluster := thisclustID] # label all clusters with one ID
      ldLof[inds, cluster := thisclustID] # label this locus
    }
  }
}

# label clusters in locus list
gatk[, cluster_can := NA_real_] # column for the CAN cluster IDs
clusts <- ldCan[, sort(unique(cluster), decreasing = TRUE)] # start from least linked locus cluster
for(i in 1:length(clusts)){
  inds <- gatk[, which(CHROM == ldCan[cluster == clusts[i], unique(chr)] & POS %in% ldCan[cluster == clusts[i], c(pos1, pos2)])]
  inds <- min(inds):max(inds) # make sure all loci from min to max position get labeled as part of this cluster
  gatk[inds, cluster_can := clusts[i]]
}

gatk[, cluster_lof := NA_real_] # column for the CAN cluster IDs
clusts <- ldLof[, sort(unique(cluster), decreasing = TRUE)] # start from least linked locus cluster
for(i in 1:length(clusts)){
  inds <- gatk[, which(CHROM == ldLof[cluster == clusts[i], unique(chr)] & POS %in% ldLof[cluster == clusts[i], c(pos1, pos2)])]
  inds <- min(inds):max(inds) # make sure all loci from min to max position get labeled as part of this cluster
  gatk[inds, cluster_lof := clusts[i]]
}

# mark the inversions
for(i in 1:nrow(inv)){
  gatk[CHROM == inv$CHROM[i] & POS >= inv$POSstart[i] & POS <= inv$POSend[i], cluster_can := -i] # mark as cluster -i in CAN
  gatk[CHROM == inv$CHROM[i] & POS >= inv$POSstart[i] & POS <= inv$POSend[i], cluster_lof := -i] # in LOF
}

# write out
write.csv(gatk, gzfile('analysis/ld.blocks.gatk.nodam.csv.gz'))


getBatch <- function(test, vClass, vPerc, testSize){

  dts <- NULL

  vsizes <- trunc(testSize*vPerc)
  resto  <- testSize - sum(vsizes)
  vsizes[length(vsizes)] <- vsizes[length(vsizes)]+resto
  indices <- NULL

  for(i in 1:length(vClass)){
    aux <- which(test$class==vClass[i])

    ind <- sample(aux, min(vsizes[i],length(aux)) )
    dts <- rbind(dts, test[ind,])
    indices <- c(indices, ind)

  }
  return(list(dts, indices))
}


##' Plot figure 4
##'
##' @return plot
##' @importFrom dplyr %>% filter mutate
##' @importFrom lubridate year
##' @importFrom ggplot2 ggplot aes geom_abline geom_point scale_color_manual scale_x_continuous scale_y_continuous expand_limits geom_hline theme
##' @importFrom ggrepel geom_label_repel
##' @importFrom cowplot theme_cowplot
##' @author Sebastian Funk
##' @export
##' @param m a prediction model of class \code{glm}, such as returned by \code{\link{prediction_model}}
figure5 <- function(m)
{
    df <- gather_2015_data() %>%
        mutate(incidence=cases/population) %>%
        filter(!is.na(mean_coverage))

    df$hat <- predict(m, type="response")

    df <- df %>%
        mutate(size=if_else(hat > 2000, "real_big", "small"),
               size=if_else(cases > 2000, "model_big", size),
               size=factor(size, levels=c("model_big", "real_big", "small")),
               label_zs=if_else(size == "small", "", health_zone))

    p <- ggplot(df, aes(x=hat, cases, label=label_zs))+
        geom_abline(slope=1, intercept=0) +
        geom_label_repel(label.padding = 0.25, label.size=NA, segment.color="darkgrey") +
        geom_point(aes(color=size)) +
        scale_color_manual(values=c("black", "red", "darkgrey")) +
        scale_x_continuous("Predicted number of cases in 2015") +
        scale_y_continuous("Number of cases in 2015") +
        expand_limits(y=-1000) +
        geom_hline(yintercept=0, linetype="dashed")+
        theme_cowplot() +
        theme(legend.position="none")

    return(p)
}


#' @title
#'  Prepare for plotting the bootstrapped network level metric results of one or
#'  multiple networks.
#'
#' @description
#'  Takes a list of network interactions (each interaction being repeated as
#'  many times as it was observed), and bootstraps the network level metric
#'  (`index`) for each network. Runs `boot_networklevel_n()` for a list of
#'  network interactions and prepares the data for plotting with `ggplot`. The
#'  output list can be passed to \code{\link[bootstrapnet]{gg_networklevel}}.
#'  See examples below.
#'
#' @param lst
#'  A list of one or multiple data frames of interactions from which to build
#'  and sample web matrices. Each interaction (row in the data frame) must be
#'  repeated as many times as it was observed. E.g. if the interaction species_1
#'  x species_2 was observed 5 times, then repeat that row 5 times within the
#'  data frame.
#'
#' @param col_lower
#'  Quoted column name in `data` for lower trophic level species (plants).
#'
#' @param col_higher
#'  Quoted column name in `data` for higher trophic level species (insects).
#'
#' @param index
#'  The name of the network level metric. Passed to
#'  \code{\link[bipartite]{networklevel}}. See `?bipartite::networklevel` for
#'  details.
#'
#' @param level
#'  For which level should the level-specific indices be computed: 'both'
#'  (default), 'lower' or 'higher'? Passed to
#'  \code{\link[bipartite]{networklevel}}. See `?bipartite::networklevel` for
#'  details.
#'
#' @param start
#'  Integer. The sample size (number of interactions) to start the bootstrap
#'  with. If the start sample size is small (e.g. 5 or 10), then first
#'  iterations might results in NaN-s and warning messages are displayed.
#'  Consider to set `start` to maybe 10\\% of your total unique interactions.
#'
#' @param step
#'  Integer. Sample size (number of interactions) used to increase gradually the
#'  sampled network until all interactions are sampled. If `step` is too small
#'  (e.g. 1) then the computation time is very long depending on your total
#'  number of interactions from which samples are taken. Consider to set `step`
#'  to maybe 5-10\\% of your total unique interactions.
#'
#' @param n_boot
#'  Number of desired bootstraps (50 or 100 can be enough).
#'
#' @param n_cpu
#'  Number of CPU-s to use for parallel processing.
#'
#' @param probs
#'  A numeric vector of two probabilities in `[0, 1]`. Passed to
#'  \code{\link[matrixStats]{rowQuantiles}} and used for building the lower and
#'  upper bounds of the confidence intervals. Defaults to `c(0.025, 0.975)`,
#'  which corresponds to a 95\\% confidence interval.
#'
#' @param ...
#'  Other arguments passed to \code{\link[bipartite]{networklevel}} like
#'  `logbase`, etc.
#'
#' @return
#'  A list of one (when `level = 'lower'` or `level = 'higher'`) or two
#'  sub-lists (when `level = 'both'`). The list can be passed to
#'  \code{\link[bootstrapnet]{gg_networklevel}}. Each sub-list, contains two
#'  data frames: `stats_df` and `lines_df`, which can be used by the
#'  `ggplot2::geom_line()` function. See the return section of
#'  \code{\link[bootstrapnet]{get_stats_single}} for more details about
#'  `stats_df` and `lines_df` data frames.
#'
#' @examples
#'
#' library(bootstrapnet)
#' library(bipartite)
#' library(magrittr)
#' data(Safariland)
#'
#' set.seed(321)
#' Safariland_1 <- Safariland[, sort(sample.int(ncol(Safariland), 10))]
#' set.seed(123)
#' Safariland_2 <- Safariland[, sort(sample.int(ncol(Safariland), 10))]
#'
#' lst <- list(s1 = Safariland_1, s2 = Safariland_2) %>%
#'   lapply(web_matrix_to_df) %>%
#'   boot_networklevel(col_lower = "lower", # column name for plants
#'                     col_higher = "higher", # column name for insects
#'                     index = "nestedness",
#'                     level = "both",
#'                     start = 10,
#'                     step = 10,
#'                     n_boot = 10,
#'                     n_cpu = 2)
#' gg_networklevel(lst)
#'
#' @export
#'
#' @md
boot_networklevel <- function(lst,
                              col_lower,
                              col_higher,
                              index,
                              level,
                              start,
                              step,
                              n_boot,
                              n_cpu,
                              probs = c(0.025, 0.975),
                              ...) {

  webs_stats <- vector(mode = "list", length = length(lst))
  names(webs_stats) <- names(lst)

  for (i in 1:length(webs_stats)){
    webs_stats[[i]] <- lst[[i]] %>%
      boot_networklevel_n(col_lower = col_lower,
                          col_higher = col_higher,
                          index = index,
                          level = level,
                          start = start,
                          step = step,
                          n_boot = n_boot,
                          n_cpu = n_cpu,
                          ...) %>%
      lapply(FUN = get_stats_single, probs = probs)
  }

  webs_stats %>%
    get_stats_multi() %>%
    return()
}

#' @title
#'  Bootstrap network level metric multiple times.
#'
#' @description
#'  Bootstrap a single network of interactions n times in parallel and collects
#'  the network level metrics. Starts with a small sample size of interactions
#'  (e.g. `start = 30`), builds the corresponding web matrix/network, computes
#'  its metric (e.g. `index = "nestedness"`) using
#'  \code{\link[bipartite]{networklevel}}, then adds new interactions (e.g.
#'  `step = 20`) until all interactions are sampled. The last sample is actually
#'  the entire network. Repeats n times (as given in `n_boot`) these steps in
#'  parallel on multiple CPUs.
#'
#' @param data
#'  Data frame of interactions from which to build and sample web matrices. Each
#'  interaction (row in the data frame) must be repeated as many times as it was
#'  observed. E.g. if the interaction species_1 x species_2 was observed 5
#'  times, then repeat that row 5 times within the data frame. See examples
#'  below.
#'
#' @param col_lower
#'  Quoted column name in `data` for lower trophic level species (plants).
#'
#' @param col_higher
#'  Quoted column name in `data` for higher trophic level species (insects).
#'
#' @param index
#'  Passed to \code{\link[bipartite]{networklevel}}. See
#'  `?bipartite::networklevel` for details.
#'
#' @param level
#'  Passed to \code{\link[bipartite]{networklevel}}. See
#'  `?bipartite::networklevel` for details. For which level should the
#'  level-specific indices be computed: 'both' (default), 'lower' or 'higher'?
#'
#' @param start
#'  Integer. The sample size (number of interactions) to start the bootstrap
#'  with. If the start sample size is small (e.g. 5 or 10), then first
#'  iterations might results in NaN-s and warning messages are displayed.
#'  Consider to set `start` to maybe 10\\% of your total unique interactions.
#'
#' @param step
#'  Integer. Sample size (number of interactions) used to increase gradually the
#'  sampled network until all interactions are sampled. If `step` is too small
#'  (e.g. 1) then the computation time is very long depending on your total
#'  number of interactions from which samples are taken. Consider to set `step`
#'  to maybe 5-10\\% of your total unique interactions.
#'
#' @param n_boot
#'  Number of desired bootstraps (50 or 100 can be enough).
#'
#' @param n_cpu
#'  Number of CPU-s to use for parallel processing.
#'
#' @param ...
#'  Other arguments passed to \code{\link[bipartite]{networklevel}} like
#'  `logbase`, etc.
#'
#' @return
#'  Returns a list of a single matrix or a list of two matrices depending on the
#'  provided `index` metric and `level` value. For example if
#'  `index='nestedness'` and `level='both'`, then it returns a list of a single
#'  matrix. But in the case of `index='niche overlap'`, it returns a list of two
#'  matrices, first matrix (`niche.overlap.HL`) corresponding to the higher level
#'  (e.g. insects), and the second (`niche.overlap.LL`) for the lower level (e.g.
#'  plants). The number of rows of a matrix indicates how many iterations took
#'  place. This is decided internally based on the given values to `start`,
#'  `step` and the total number of rows (interactions) in `data`.The row names
#'  give the sample size at each iteration. The last iteration (last row name) is
#'  always the entire network (total number of interactions in `data`). The
#'  number of columns corresponds to `n_boot` (number of bootstraps).
#'
#' @examples
#'
#' library(bootstrapnet)
#' library(magrittr)
#' library(bipartite)
#' data(Safariland)
#'
#' Safariland %>%
#'   web_matrix_to_df() %>%
#'   boot_networklevel_n(col_lower = "lower", # column name for plants
#'                       col_higher = "higher", # column name for insects
#'                       index = "niche overlap",
#'                       level = "both",
#'                       start = 100,
#'                       step = 100,
#'                       n_boot = 10,
#'                       n_cpu = 2)
#'
#' @import data.table
#'
#' @importFrom foreach foreach %dopar% registerDoSEQ
#' @importFrom parallel splitIndices makeCluster stopCluster
#' @importFrom doParallel registerDoParallel
#' @importFrom iterators iter
#'
#' @export
#'
#' @md
boot_networklevel_n <- function(data,
                                col_lower,
                                col_higher,
                                index,
                                level,
                                start,
                                step,
                                n_boot,
                                n_cpu,
                                ...){
  test_data(data, col_lower, col_higher)
  cls_data <- class(data)
  if (! "data.table" %in% cls_data) data.table::setDT(data)

  test_index_networklevel(index)

  test_level_value(level)

  test_data_species_names(data, col_lower, col_higher)

  # Get sample sizes. Row names of the resulting bootstrap matrices will carry
  # information about the sample size at each iteration/bootstrap step. This is
  # run also before the parallel processing initiation because it can throw
  # error messages if the start and step values are not adequate. No need to
  # initiate parallel processing for something that will fail.
  iter_spl_size <- sample_indices(data = data, start = start, step = step, seed = 42) %>%
    sapply(length)

  { # Start parallel processing
    chunks <- parallel::splitIndices(n_boot, n_cpu)
    cl <- parallel::makeCluster(n_cpu)
    doParallel::registerDoParallel(cl)
    i <- NULL # to avoid 'Undefined global functions or variables: i' in R CMD check

    boot_lst <-
      foreach::foreach(i = iterators::iter(chunks),
                       .errorhandling = 'pass',
                       .packages = c("magrittr",
                                     "data.table",
                                     "bipartite"),
                       .export = c("boot_networklevel_once",
                                   "split_in_chunks",
                                   "sample_indices")) %dopar% {
                                     lapply(i, FUN = function(x) # note the lapply!
                                       boot_networklevel_once(data = data,
                                                              col_lower = col_lower,
                                                              col_higher = col_higher,
                                                              index = index,
                                                              level = level,
                                                              start = start,
                                                              step = step,
                                                              seed = x,
                                                              ...)
                                     )
                                   }
    parallel::stopCluster(cl)
    remove(cl)
    foreach::registerDoSEQ()
    } # End of parallel processing

  boot_lst <- unlist(boot_lst, recursive = FALSE)

  metric_names <- names(boot_lst[[1]])
  n <- length(metric_names)

  if (n == 1) {
    results <- get_list_of_matrices(boot_lst, metric_names, n, iter_spl_size)
    # Convert data back to data frame if applicable
    if (! "data.table" %in% cls_data) data.table::setDF(data)
    return(results)

  } else if (n == 2) {
    results <- get_list_of_matrices(boot_lst, metric_names, n, iter_spl_size)
    if (! "data.table" %in% cls_data) data.table::setDF(data)
    return(results)
  }
}

#' @title
#'  Bootstrap network level metric once.
#'
#' @description
#'  You will rarely use this function alone. It was designed to be executed in
#'  parallel by \code{\link[bootstrapnet]{boot_networklevel_n}}. See more
#'  details there.
#'
#' @param data
#'  See \code{\link[bootstrapnet]{boot_networklevel_n}}.
#'
#' @param col_lower
#'  See \code{\link[bootstrapnet]{boot_networklevel_n}}.
#'
#' @param col_higher
#'  See \code{\link[bootstrapnet]{boot_networklevel_n}}.
#'
#' @param index
#'  See \code{\link[bootstrapnet]{boot_networklevel_n}}.
#'
#' @param level
#'  See \code{\link[bootstrapnet]{boot_networklevel_n}}.
#'
#' @param start
#'  See \code{\link[bootstrapnet]{boot_networklevel_n}}.
#'
#' @param step
#'  See \code{\link[bootstrapnet]{boot_networklevel_n}}.
#'
#' @param seed
#'  Set seed to get reproducible random results. Passed to `set.seed()`.
#'
#' @param ...
#'  See \code{\link[bootstrapnet]{boot_networklevel_n}}.
#'
#' @return
#'  Returns a data frame of one or two columns depending on the provided `index`
#'  metric and `level` value. For example if `index='nestedness'` and
#'  `level='both'`, then it returns a one column data frame. But in case of
#'  `index='niche overlap'`, it returns a two columns data frame, first column
#'  ('niche.overlap.HL') corresponding to the higher level (e.g. insects), and
#'  the second column ('niche.overlap.LL') for the lower level (e.g. plants).
#'  The number of rows in the returned data frame corresponds to the number of
#'  splits given by `bootstrapnet:::sample_indices` (is the length/number of
#'  elements of the list returned by this function). The last value(s) in the
#'  data frame correspond to the results of
#'  \code{\link[bipartite]{networklevel}} on the entire network - see in
#'  examples.
#'
#' @references
#'  This function is a wrapper of \code{\link[bipartite]{networklevel}}.
#'
#' @import data.table
#'
#' @importFrom magrittr %>%
#' @importFrom bipartite networklevel
#'
#' @examples
#'
#' library(bootstrapnet)
#' library(bipartite)
#' library(data.table)
#'
#' data(Safariland)
#'
#' df <- web_matrix_to_df(Safariland)
#' setDT(df) # df must be a data.table and not data.frame
#'
#' # Example with "nestedness":
#'
#' boot_networklevel_once(data = df,
#'                        col_lower = "lower", # column name for plants
#'                        col_higher = "higher", # column name for insects
#'                        index = "nestedness",
#'                        level = "both",
#'                        start = 100,
#'                        step = 100,
#'                        seed = 2020-11-5)
#' # Returns a one column data frame. The last value must equal the result of:
#' set.seed(42) # this is the same seed used in the boot_networklevel_once() function
#' bipartite::networklevel(table(df$lower, df$higher),
#'                        index = "nestedness")
#' # which is also the equivalent of:
#' Safariland_sorted <- Safariland[order(rownames(Safariland)), order(colnames(Safariland))]
#' set.seed(42)
#' bipartite::networklevel(Safariland_sorted, index = "nestedness")
#'
#'
#' # Example with "niche overlap":
#'
#' boot_networklevel_once(data = df,
#'                        col_lower = "lower", # column name for plants
#'                        col_higher = "higher", # column name for insects
#'                        index = "niche overlap",
#'                        level = "both",
#'                        start = 100,
#'                        step = 100,
#'                        seed = 2020-11-5)
#' # Returns a two column data frame
#'
#' @export
#'
#' @md
boot_networklevel_once <- function(data,
                                   col_lower,
                                   col_higher,
                                   index,
                                   level,
                                   start,
                                   step,
                                   seed,
                                   ...){

  # List of sampled row indices from data to be used for bootstrapping. Each row
  # represents a plant-pollinator interaction. Each vector of sampled indices is
  # used to build a web matrix/network from data.
  ids_lst <- sample_indices(data = data, start = start, step = step, seed = seed)

  # Allocate memory for the objects that will grow during iterations/bootstrapping.
  metric_lst <- vector(mode = "list", length = length(ids_lst))

  # Sample interactions with the indices build above and compute the network
  # level metric until all interactions are sampled. In case of errors (most
  # probably related to small sample size of a network at first iterations),
  # then `try()` doesn't break the bootstrapping process.
  for (i in 1:length(ids_lst)){
    metric_lst[[i]] <- try({
      # Some metrics, like nestedness have random processes in their
      # computation, so set seed here also for reproducibility. That is, if one
      # wants to run the same random processes again, should get identical
      # results.
      web <- data[ids_lst[[i]], table(get(col_lower), get(col_higher))]
      set.seed(42)
      bipartite::networklevel(web = web, index = index, level = level, ...)
    })
  }

  # Prepare results as data frame.
  df <- metric_lst %>%
    lapply(rbind) %>%
    lapply(as.data.frame) %>%
    data.table::rbindlist()
  setDF(df)

  return(df)
}


# armar plot ranking anual

#levantar_datos
library("tidyverse")
base::load(here::here("data","temporal_acumulado_data.Rdata"))

get_tabla_valores_metrica_seleccionada <- function(data_df,cant_n,metrica_s,fundadores_df){
    # fundadores_df=fundadores
    # data_df=temporal_acumulado_nodos_grafos
    # cant_n=5;
    # metrica_s='degree';
    metrica_sym <-rlang::sym(metrica_s)
    # armar para cada periodo segun parametros en top N
    resu_final <- data_df %>% select(-es_fundador) %>%
        nest(data = c(autor, fuerza_colaboracion, degree, betweeness, eigen_centrality,
                      closeness, page_rank, count_triangles)) %>%
        mutate(top_n_periodo=purrr::map(data,
                                        cant=cant_n,
                                        metrica=metrica_s,
                                        .f=function(d,metrica,cant){
                                            metrica_sym <-rlang::sym(metrica_s)
                                            ranking <- seq(from=1,to = cant,by = 1)

                                            ret <-  d %>% arrange(desc(!!metrica_sym)) %>%
                                                nest(-!!metrica_sym) %>% # fix empates
                                                arrange(desc(!!metrica_sym)) %>% head(cant) %>%
                                                mutate(posicion=ranking) %>%
                                                mutate(valor_seleccion= !!metrica_sym) %>%
                                                unnest()%>%
                                                select(autor,valor_seleccion,posicion)

                                            ret
                                        })) %>%
        unnest(top_n_periodo) %>%
        select(-data) %>%
        left_join(fundadores_df,by="autor") %>%
        group_by(periodo,valor_seleccion,posicion,es_fundador) %>%
        summarise(autores_posicion=paste(autor,collapse = ";"),cant_autores=n()) %>%
        nest(data = c(periodo, valor_seleccion, es_fundador, autores_posicion, cant_autores) ) %>%  #nest(-posicion)
        mutate(mantiene_data=purrr::map(data,.f=function(dat){
            resu = dat %>%
                mutate(mantiene = purrr::map2(.x=autores_posicion,.y=lag(autores_posicion,1),.f=function(auts,anterior){
                    # que pasa si vienen varios, o si van varios. es un muchos v muchos.
                    autores_originales  <- str_split(auts,";",simplify = TRUE)
                    autores_lag <-  str_split(anterior,";",simplify = TRUE) # ojo si es el 1ro viene vacio.

                    #si alguno de los originales estaba en lag, entonces true.
                    resultado <- any(autores_originales %in% autores_lag )
                    resultado
                })) %>% unnest(mantiene)
            resu

        })) %>%
        select(-data) %>%
        unnest(mantiene_data) %>% select(-cant_autores,-autores_posicion) %>%
        rename(valor=valor_seleccion) %>%
        mutate(metrica=metrica_s) %>%
        mutate(es_fundador=if_else(is.na(es_fundador),FALSE,es_fundador)) %>%
        pivot_longer(cols = c("mantiene","es_fundador","valor"),names_to="variable",values_to="valores") %>%
        #ungroup() %>%
        select(periodo,metrica,posicion,variable,valores) %>%
        pivot_wider(names_from = periodo,values_from=valores) %>%
        arrange(posicion)
    resu_final
}

temporal_acumulado_nodos_grafos <- temporal_acumulado_nodos_grafos %>%
    mutate(es_fundador=(periodo==1996)) %>%  as_tibble()

fundadores <- temporal_acumulado_nodos_grafos %>%  filter(es_fundador) %>% distinct(autor,es_fundador)

# definicion parametros

#metrica_s='betweeness';
#metrica_s='betweeness';

# tomar caracter dinamico
cant_n=5;

metrica_s='betweeness';
resumen_btw <- get_tabla_valores_metrica_seleccionada(temporal_acumulado_nodos_grafos,cant_n=5,metrica_s=metrica_s,fundadores_df=fundadores)
readr::write_tsv(x = resumen_btw,here::here("tmp","resumen_betweeness.csv"))

# aca hay algo que se repiten filas, sin embargo los valores repetidos son iguales. es probable que haya mas de 1 autor y por eso repite.
# toca validar para que quede limpito de una.
metrica_s='degree';
resumen_degree <- get_tabla_valores_metrica_seleccionada(temporal_acumulado_nodos_grafos,cant_n=5,metrica_s=metrica_s,fundadores_df=fundadores) %>%
    unnest(cols = c(`1996`, `1999`, `2001`, `2002`, `2003`, `2004`, `2005`, `2006`,
                    `2007`, `2008`, `2009`, `2010`, `2011`, `2012`, `2013`, `2014`,
                    `2015`, `2016`))
readr::write_tsv(x = resumen_degree,here::here("tmp","resumen_degree.csv"))

metrica_s='fuerza_colaboracion';
resumen_fuerza_colab <- get_tabla_valores_metrica_seleccionada(temporal_acumulado_nodos_grafos,cant_n=5,metrica_s=metrica_s,fundadores_df=fundadores)
readr::write_tsv(x = resumen_fuerza_colab,here::here("tmp","resumen_fuerza_colaboracion.csv"))


#!/usr/bin/env Rscript
args <- commandArgs(TRUE)
intable = paste("", args[1], sep="")
outpdf = paste("", args[2], sep="")

if(intable == 'NA' || outpdf == 'NA') {
    message("Usage: plot_trans_reads_counts.r [input table] [output pdf]")

} else {

    dat = read.delim(intable, header=T)
    dat[is.na(dat[,4]),4]=0

    x.reads = cumsum(dat[,2])
    x.reads = x.reads/max(x.reads)
    x.genes = cumsum(dat[,3])
    x.genes = x.genes/max(x.genes)
    x.unmap = cumsum(dat[,4])
    x.unmap = x.unmap/max(x.unmap)
    x.tot = cumsum(dat[,2] + dat[,4])
    x.tot = x.tot/max(x.tot)

    pdf(outpdf)
    plot(1:length(x.reads), x.reads, type='l', col="blue", xlab="cell barcodes", ylab="cumulative fraction", ylim=c(0,1))
    lines(1:length(x.genes), x.genes, type='l', col="green")
    lines(1:length(x.unmap), x.unmap, type='l', col="gray")
    lines(1:length(x.tot), x.tot, type='l', col="black")
    legend("bottomright", inset=0.01, lty=1, cex=0.8, col=c("blue","green","gray","black"), legend=c("genic_reads","genes","intergenic_reads","total_reads"))

    plot(1:length(x.reads), x.reads, type='l', col="blue", xlab="cell barcodes", ylab="cumulative fraction", xlim=c(1,50000), ylim=c(0,1))
    lines(1:length(x.genes), x.genes, type='l', col="green")
    lines(1:length(x.unmap), x.unmap, type='l', col="gray")
    lines(1:length(x.tot), x.tot, type='l', col="black")
    legend("topleft", inset=0.01, lty=1, cex=0.8, col=c("blue","green","gray","black"), legend=c("genic_reads","genes","intergenic_reads","total_reads"))

    plot(1:length(x.reads), x.reads, type='l', col="blue", xlab="cell barcodes", ylab="cumulative fraction", xlim=c(1,5000), ylim=c(0,1))
    lines(1:length(x.genes), x.genes, type='l', col="green")
    lines(1:length(x.unmap), x.unmap, type='l', col="gray")
    lines(1:length(x.tot), x.tot, type='l', col="black")
    legend("topleft", inset=0.01, lty=1, cex=0.8, col=c("blue","green","gray","black"), legend=c("genic_reads","genes","intergenic_reads","total_reads"))

    plot(1:length(x.reads), x.reads, type='l', col="blue", xlab="cell barcodes", ylab="cumulative fraction", xlim=c(1,500), ylim=c(0,1))
    lines(1:length(x.genes), x.genes, type='l', col="green")
    lines(1:length(x.unmap), x.unmap, type='l', col="gray")
    lines(1:length(x.tot), x.tot, type='l', col="black")
    legend("topleft", inset=0.01, lty=1, cex=0.8, col=c("blue","green","gray","black"), legend=c("genic_reads","genes","intergenic_reads","total_reads"))
    dev.off()
}


#xdata <- peakShape_XCMS3(my_data,cor.val=0.9, useNoise = setNoise)

#and then proceed with retention time correction and correspondence/grouping
# Decreasing cor.val will allow more non-gaussian peaks through the filter

#original file version from the Google Groups for xcms from Tony Larson
#KL corrected this version 8/23/2011 for XCMS < 3
#KL updating to using XCMS3, 11/5/2018

#original peakShape function to remove non-gaussian peaks from an xcmsSet
#code originally had cor.val = 0.9; 0.5 is too low (not doing enough pruning)
#object is updated to be an XCMSnExp class

peakShape_XCMS3 <- function(object, cor.val=0.9, useNoise = setNoise)
{
require(xcms)

#files <- object@filepaths #old code
files <- fileNames(object)

#peakmat <- object@peaks #old code
peakmat <- chromPeaks(object) #extract everything

peakmat.new <- matrix(-1,1,ncol(peakmat))
colnames(peakmat.new) <- colnames(peakmat)

for(f in 1:length(files))
        {
        #xraw <- xcmsRaw(files[f], profstep=0) #old code
        raw_data <- readMSData(files[f],msLevel = 1, mode = "onDisk") #use 'onDisk' to make the next step faster
        sub.peakmat <- peakmat[which(peakmat[,"sample"]==f),,drop=F]
        corr <- numeric()
        for (p in 1:nrow(sub.peakmat))
                {
                #old code
                #tempEIC <-
                    #as.integer(rawEIC(xraw,mzrange=c(sub.peakmat[p,"mzmin"]-0.001,sub.peakmat[p,"mzmax"]+0.001))$intensity)
                #minrt.scan <- which.min(abs(xraw@scantime-sub.peakmat[p,"rtmin"]))[1]
                #maxrt.scan <- which.min(abs(xraw@scantime-sub.peakmat[p,"rtmax"]))[1]
                #eics <- tempEIC[minrt.scan:maxrt.scan]

                mzRange = c(sub.peakmat[p,"mzmin"]-0.001,sub.peakmat[p,"mzmax"]+0.001)
                subsetOnMZ <- filterMz(raw_data, mz = mzRange)

                #now set the Rt range...use sub.peakmat min and max RT
                rtRange = c(sub.peakmat[p,"rtmin"],sub.peakmat[p,"rtmax"])
                subsetOnMZandRT <- filterRt(subsetOnMZ, rt = rtRange)

                eics <- intensity(subsetOnMZandRT) #get the intensity values
                eics[sapply(eics, function(x) length(x)==0)] <- 0 #if empty in a scan, convert to 0
                eics <- as.integer(unlist(eics)) #use as.double for Lumos

                #filter out features that are less than the noise level I have already set...
                setThreshold <- which(eics < useNoise)
                eics <- eics[-setThreshold]
                rm(setThreshold)

                #remove any NA (easier bc downstream leaving it in causes issues)
                eics <- eics[!is.na(eics)]

                getIdx <- which(eics == min(eics))[1] #if multiple values, just need the first match
                #set min to 0 and normalise
                eics <- eics-eics[getIdx]

                if(max(eics,na.rm=TRUE)>0)
                        {
                        eics <- eics/max(eics, na.rm=TRUE)
                        }
                #fit gauss and let failures to fit through as corr=1
                fit <- try(nls(y ~ SSgauss(x, mu, sigma, h),
                               data.frame(x = 1:length(eics), y = eics)),silent=T)

                if(class(fit) == "try-error")
                        {
                        corr[p] <- 1
                        } else {
                        #calculate correlation of eics against gaussian fit
                        if (length(which(!is.na(eics - fitted(fit)))) > 4 &&
                            length(!is.na(unique(eics)))>4 &&
                            length(!is.na(unique(fitted(fit))))>4)
                                {
                                cor <- NULL
                                options(show.error.messages = FALSE)
                                cor <- try(cor.test(eics,fitted(fit),method="pearson",use="complete"))
                                options(show.error.messages = TRUE)
                                if (!is.null(cor))
                                        {
                                        if(cor$p.value <= 0.05) {
                                          corr[p] <- cor$estimate
                                        } else {
                                          corr[p] <- 0 }
                                        }
                                  else corr[p] <- 0
                                } else corr[p] <- 0
                        }
                } #this ends to the 'p' loop (going through one mzRT feature at a time)

        filt.peakmat <- sub.peakmat[which(corr >= cor.val),]
        peakmat.new <- rbind(peakmat.new, filt.peakmat)
        n.rmpeaks <- nrow(sub.peakmat)-nrow(filt.peakmat)
        cat("Peakshape evaluation: sample ",
            basename(files[f]),"
            ",n.rmpeaks,"/",nrow(sub.peakmat)," peaks removed","\n")

        if (.Platform$OS.type == "windows") flush.console()

        } #this ends the 'f' loop (going through one file at a time())

peakmat.new <- peakmat.new[-1,] #all but the first row that is all -1
object.new <- object #copy to a new object

#object.new@peaks <- peakmat.new #old code
chromPeaks(object.new) <- peakmat.new #this will return an answer, but losing information

#add this line to retain the history information
object.new@.processHistory <- object@.processHistory

return(object.new)
} #this ends the function itself


\name{to_igraph}
\alias{to_igraph}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
 Convert a PAFit_net object to an igraph object
}
\description{
  This function converts a \code{PAFit_net} object to an \code{igraph} object (of package \pkg{igraph}).
}
\usage{
to_igraph(net_object)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{net_object}{
An object of class \code{PAFit_net}.
}
}

\value{
The function returns an \code{igraph} object.
}

\author{
Thong Pham \email{thongpham@thongpham.net}
}

\examples{
library("PAFit")
# a network from Bianconi-Barabasi model
net          <- generate_BB(N = 50 , m = 10 , s = 10)
igraph_graph <- to_igraph(net)
}


add <- 0
st <- proc.time()

for(index in 0:100000001)
{
    add <- add + index;
}

ed <- proc.time() - st

message("==========================")
message("R 테스트")
message(add)
print(ed)


#!/usr/bin/env bash Rscript --vanilla

## --------------------------------------------------------------------------------------------------------------------
## Script:
## Author: Mike Freund (mfreundc@gmail.com)
## Input:
##  - ...
## Output:
##  - ...
## Notes:
##  - TODO: should probably add handling of vertices with no bold
## --------------------------------------------------------------------------------------------------------------------

## setup ----

## packages and sourced variables

suppressMessages(library(here))
suppressMessages(library(dplyr))
library(tidyr)
suppressMessages(library(data.table))
suppressMessages(library(gifti))
library(abind)
library(rhdf5)
library(foreach)
suppressMessages(library(doParallel))
suppressMessages(library(CovTools))
library(pracma)
source(here("src", "stroop-rsa-pc.R"))
library(profvis)

## set variables

task <- "Stroop"

if (interactive()) {
    glmname <- "lsall_1rpm"
    roiset <- "Schaefer2018Network"
    prewh <- "obspc50"  ## obsresamp, obsall, obsresampbias, obsresamppc50, obsbias, obspc50
    subjlist <- "mcmi"
    subjects <- fread(here(paste0("out/subjlist_", subjlist, ".txt")))[[1]]
    waves <- "wave1"
    sessions <- "proactive"
    n_cores <- 10
    ii <- 2#321  ## Vis: 331, SomMot: 341
    overwrite <- FALSE
    n_resamples <- 1E2
} else {
    source(here("src", "parse_args.r"))
    print(args)
}

stopifnot(prewh %in% expected$prewh)

atlas <- read_atlas(roiset)
rois <- names(atlas$roi)

if (prewh %in% c("obsresamp", "obsall")) {
    ttype_subset <- "all"
} else if (prewh %in% c("obsresampbias", "obsbias")) {
    ttype_subset <- "bias"
} else if (prewh %in% c("obsresamppc50", "obspc50")) {
    ttype_subset <- "pc50"
} else {
    stop("unexpected input for prewh argument")
}

## execute ----

input <- construct_filenames_h5(
    prefix = "coefs", subjects = subjects, waves = waves, sessions = sessions, rois = rois, runs = runs,
    glmname = glmname, prewh = "none"
)

## option to skip if dset already exists (not overwrite):
if (!overwrite) {
    dset_name_new <- gsub("prewh-none", paste0("prewh-", prewh), input$dset_name)
    file_ls <- mclapply(input$file_name, h5ls, mc.cores = 20)
    dset_exists <- mapply(function(x, y) x %in% y$name, x = dset_name_new, y = file_ls)
    input <- input[!dset_exists, ]
}

cl <- makeCluster(n_cores, type = "FORK", outfile = "")
registerDoParallel(cl)
res <- foreach(ii = seq_along(input$file_name), .inorder = FALSE) %dopar% {

    input_val <- input[ii, ]
    subject <- input_val[, subj]
    session <- input_val[, session]
    wave <- input_val[, wave]
    run <- input_val[, run]
    roi <- input_val[, roi]

    B <- read_dset(input_val$file_name, input_val$dset_name)

    ## remove trial-wise variance due to conditions from each voxel
    X <- indicator_matrix(colnames(B))  ## colnames of B gives the condition
    resids <- resid(.lm.fit(X, t(B)))

    ## estimate covariance matrix of residuals and invert
    resids <- resids[rownames(resids) %in% ttypes[[ttype_subset]], ]  ## extract specified trialtypes
    if (grepl("resamp", prewh)) {
        S <- resample_apply_combine(
            x = t(resids),
            resample_idx = get_resampled_idx(
                conditions = rownames(resids),
                n_resamples,
                expected_min = expected_min[[paste0(session, "_", ttype_subset)]]
                ),
            apply_fun = function(.x) CovEst.2010OAS(t(.x))$S,
            combine_fun = "iterative_add",
            outdim = c(ncol(resids), ncol(resids))
            )
    } else {
        S <- CovEst.2010OAS(resids)
    }

    W <- crossprod(sqrtm(S$S)$Binv, B)  ## apply sqrt of inverse

    out <- write_dset(
        mat = W,
        dset_prefix = "coefs",
        subject = subject,
        session = session,
        wave = wave,
        run = run,
        roiset = roiset,
        roi = roi,
        glmname = glmname,
        prewh = prewh,
        write_colnames = TRUE
        )

    c(out, rho = S$rho)  ## returns metadata

}
stopCluster(cl)

data_info <- as.data.table(do.call(rbind, res))
fn <- construct_filename_datainfo(
        prefix = "coefs", subjlist = subjlist, glmname = glmname, roiset = roiset, prewh = prewh
        )
fwrite(data_info, fn)