segSpect <- function(wav, seg, step=10) {
  j <- which(wav$seg$segnam == seg)
  t1 <- wav$seg$beg[j] / 1000.0
  t2 <- wav$seg$end[j] / 1000.0
  srms <- wav$wav@samp.rate / 1000.0
  wl <- round(srms * 32)
  s <- rep(0, 1 + wl/2)
  nfr <- 0
  for (tx in seq(t1, t2, step)) {
    s <- s + mstft(getFrame(wav, tx, absolute=T, winlen=32))
    nfr <- nfr + 1
  }
  s <- s/nfr
  s
}


a %*% b


df <- read.delim ("sample/chip1/chip1_divided_input1_around_peak1_halfwid1000winsize25step10.txt")
df_r <- read.delim ("sample/chip1/chip1_divided_input1_around_peak1_halfwid1000winsize25step10_random1000.txt")

png("sample/chip1/chip1_divided_input1_around_peak1_halfwid1000winsize25step10_random1000.png")
plot (df$relative_pos, df$smt_mean, col="blue", ylim=c(0.8,13), main="Enrichment of chip1 around peak1", ylab="Enrichment of chip1", xlab="Distance from peak1 (bp)", type="l", lwd=2)
lines (df$relative_pos, df$CI95.00percent_U, col="blue", lty=2)
lines (df$relative_pos, df$CI95.00percent_L, col="blue", lty=2)
lines (df_r$relative_pos, df_r$smt_mean, col="black", lwd=2, lty=2)
legend ("topright", c("chip1","random"), lwd=2, lty=c(1,2), col=c("blue","black"))
dev.off()


# Prepare environment
install.packages("tidyverse")
install.packages("DataExplorer")
install.packages("keras")
install.packages("h2o")

# Load packages
library(tidyverse)
library(DataExplorer)
library(keras)
library(h2o)

# List files (extract from samples.zip)
list.files(path = "../input")

# Initiate H2O
h2o.init()

# Importing files
train <- h2o.importFile("..//input/train.csv", destination_frame = "train.hex")

h2o.getId(train)

# May be described in two ways as follows
### h2o.describe(h2o.getFrame("train.hex"))
h2o.describe(train)

# Do the same for test.csv
test <- h2o.importFile("..//input/test.csv", destination_frame = "test.hex")
h2o.describe(test)

# Treating the Training Base, remove label
names(train)
setdiff(names(train), "label")
y <- "label"
x <- setdiff(names(train), y)
train[,y] <- h2o.asfactor(train[,y])
h2o.describe(train)

# Load database and train
mnist <- dataset_mnist()

# mnist is a 28x28 image base, here we transform each image into a vector sized 784, each element a pixel
x_train <- mnist$train$x %>% apply(1, as.numeric) %>% t()
x_test <- mnist$test$x %>% apply(1, as.numeric) %>% t()

# Transform images for 0-1 interval so the lose function works properly
x_train <- x_train/255
x_test <- x_test/255

# Try with autoencode
encoding_dim <- 32
input <- layer_input(shape = 784)
encoded <- layer_dense(input, encoding_dim, activation = "relu",
                       activity_regularizer = regularizer_l1(l = 10e-5))
decoded <- layer_dense(encoded, 784, activation = "sigmoid")
input <- layer_input(shape = 784)
encoded <- layer_dense(input, 128, activation = "relu") %>%
  layer_dense(64, activation = "relu") %>%
  layer_dense(32, activation = "relu")
decoded <- layer_dense(encoded, 64, activation = "relu") %>%
  layer_dense(128, activation = "relu") %>%
  layer_dense(784, activation = "sigmoid")
autoencoder <- keras_model(input, decoded)
autoencoder %>% compile(optimizer='adadelta', loss='binary_crossentropy')

# Estimate parameters in keras
autoencoder %>% fit(
  x_train, x_train,
  epochs = 50,
  batch_size = 256,
  shuffle = TRUE,
  validation_data = list(x_test, x_test)
)

# Autoencoders in H2O
splits_ae <- h2o.splitFrame(train, 0.5, seed = 1)

# first part of the data, without labels for unsupervised learning
train_unsupervised <- splits_ae[[1]]
dim(train_unsupervised)

# second part of the data, with labels for supervised learning
train_supervised <- splits_ae[[2]]
dim(train_supervised)

hidden <- c(256, 128, 64, 128)

# Train the deep learning autoencoder model.
ae_model <- h2o.deeplearning(x = x,
                             training_frame = train_unsupervised,
                             model_id = "mnist_autoencoder",
                             ignore_const_cols = FALSE,
                             activation = "Tanh",  # Tanh is good for autoencoding
                             hidden = hidden,
                             autoencoder = TRUE)
ae_model

# Next, we can use this pre-trained autoencoder model as a starting point for a supervised deep neural network (DNN).
fit_ae <- h2o.deeplearning(x = x, y = y,
                         training_frame = train_supervised,
                         ignore_const_cols = FALSE,
                         hidden = hidden,
                         pretrained_autoencoder = "mnist_autoencoder")

pred_ae <- h2o.predict(object = fit_ae, newdata = test)
pred_ae
pred <- as.data.frame(pred_ae$predict)
pred
sample <- read.csv("..//input/sample_submission.csv")
df <- data.frame(sample)
df[,2] <- pred
df
write.csv(df,"..//working/My_autoencoder_h2o.csv", row.names=FALSE)
read.csv("..//working/My_autoencoder_h2o.csv")
fit_ae


# Function to apply errors to summaries

applyerror<-function(gsum,nI,J,e){
  esum=array(rep(0,nI*J*11),c(nI,J,11))
  x<-runif(nI*J*11,-e,e)
  dim(x)<-c(nI,J,11)
  esum<-(1+x)*gsum
  esum
}


# Define UI for application that draws the plot

shiny::shinyUI(shiny::fluidPage(

  # Application title
  shiny::titlePanel("Response to selection with several locations"),

  # Input values
  shiny::sidebarLayout(
    shiny::sidebarPanel(
      shiny::numericInput("N",
                         "Plot capacity:",
                         min = 100,
                         max = 10000,
                         step = 100,
                         value = 1000),
      shiny::numericInput("k",
                          "Number of locations:",
                          min = 1,
                          max = 100,
                          step = 1,
                          value = 3),
      shiny::numericInput("sg1",
                         "Number of selected genotypes:",
                         min = 0,
                         max = 10000,
                         step = 10,
                         value = 10),
      shiny::numericInput("sigmaG2",
                         "Genotypic variance:",
                         min = 0,
                         max = 1000,
                         step = 0.1,
                         value = 1),
      shiny::numericInput("sigmaGL2",
                          "Genotypic x location variance:",
                          min = 0,
                          max = 1000,
                          step = 0.1,
                          value = 1),
      shiny::numericInput("sigmaE2",
                          "Error variance:",
                          min = 0,
                          max = 1000,
                          step = 0.1,
                          value = 1)
    ),

    # Show the plot

    shiny::mainPanel(
      shiny::plotOutput("rtsplot2")
    )
  )
))


# Predict land cover fractions using a logistical regression.

library(nnet)
library(hydroGOF)
library(future)
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("pixel-based/utils/crossvalidation.r")
source("pixel-based/utils/subpixel-confusion-matrix.r") # Replace with package eventually
source("utils/accuracy-statistics.r")

Data.df = LoadTrainingAndCovariates()
Data.df = st_set_geometry(Data.df, NULL)
# Manually rescale
#Data.df = RescaleBasedOn(Data.df, Data.df, GetAllPixelCovars())
#Data.df = NAToMean(Data.df, GetAllPixelCovars())
#Data.df[is.na(Data.df)] = -9999
Data.df[is.na(Data.df)] = 0
Data.df = TidyData(Data.df, drop.cols=NULL)

# Validation data
Data.val = LoadValidationAndCovariates()
Data.val = st_set_geometry(Data.val, NULL)
#Data.val = RescaleBasedOn(Data.val, Data.df, GetAllPixelCovars())
#Data.val = NAToMean(Data.val, GetAllPixelCovars())
#Data.val[is.na(Data.val)] = -9999
Data.val[is.na(Data.val)] = 0
Data.val = TidyData(Data.val, drop.cols=NULL) # Drops around 1050

AllCovars = GetAllPixelCovars()
Classes = GetCommonClassNames()
Truth = Data.val[,Classes]

# Feature selection
#FullModelFormula = formula(paste("dominant_lc~", paste0("scale(", AllCovars, ")", collapse="+")))
FullModelFormula = formula(paste("dominant_lc~", paste(AllCovars, collapse="+")))
set.seed(0xfedbeef)
FullModel = multinom(FullModelFormula, Data.df, MaxNWts=2000)

Predictions = predict(FullModel, Data.val[,GetAllPixelCovars()], type="probs")
AccuracyStatisticsPlots(Predictions[,Classes], Truth[,Classes]/100) # RMSE 25.3, MAE 15.6, relatively poor # 21.7 12.2 formula-scaled -9999 # 21.9 12.4 unscaled 0
SCM(Predictions[,Classes], Truth[,Classes]/100, plot=TRUE, totals=TRUE)
NSE(unlist(as.data.frame(Predictions[,Classes])), unlist(Truth[,Classes]/100))
PlotHex(as.data.frame(Predictions[,Classes]*100), Truth[,Classes], "Logistic regression, all covariates")
PlotBox(as.data.frame(Predictions[,Classes]*100), Truth[,Classes], main="Logistic regression, all covariates", binpredicted=TRUE) # Very fuzzy, the top does not predict well at all

# Train longer
set.seed(0xfedbeef)
FullModel = multinom(FullModelFormula, Data.df, MaxNWts=2000, maxit=200)

Predictions = predict(FullModel, Data.val[,GetAllPixelCovars()], type="probs")
AccuracyStatisticsPlots(Predictions[,Classes], Truth[,Classes]/100) # RMSE 21.6, MAE 12.1, very slightly better
SCM(Predictions[,Classes], Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 58%±4, kappa 0.46±0.06
NSE(unlist(as.data.frame(Predictions[,Classes])), unlist(Truth[,Classes]/100)) # 0.48
PlotHex(as.data.frame(Predictions[,Classes]*100), Truth[,Classes], "Logistic regression, all covariates, 200 iterations")
PlotBox(as.data.frame(Predictions[,Classes]*100), Truth[,Classes], main="Logistic regression, all covariates, 200 iterations", binpredicted=TRUE)
write.csv(Predictions[,Classes]*100, "../data/pixel-based/predictions/logistic-na0.csv", row.names=FALSE)

ReducedModel = step(FullModel) # This takes forever as it rebuilds the model for each covariate

# Very little difference between all and uncorrelated covars
#logmodel = multinom(paste("dominant_lc ~", paste0("scale(", AllCovars, ")", collapse="+")), Data.df, MaxNWts = 2500)
#lm_uncor = multinom(paste("dominant_lc ~", paste0("scale(", UncorrelatedCovars, ")", collapse="+")), Data.df)
#AIC(logmodel, lm_uncor) # the uncor model is better
#DropCovars = UncorrelatedCovars[!UncorrelatedCovars %in% "aspect"]
#lm_drop = multinom(paste("dominant_lc ~", paste0("scale(", DropCovars, ")", collapse="+")), Data.df, MaxNWts = 2000)
#AIC(lm_uncor, lm_drop) # Smaller model is better
#DropCovars = DropCovars[!DropCovars %in% "intercept"]
#lm_drop2 = multinom(paste("dominant_lc ~", paste0("scale(", DropCovars, ")", collapse="+")), Data.df, MaxNWts = 2000)
#AIC(lm_drop, lm_drop2) # Even dropping the colinear variables doesn't help, so the full model is the best
# Try growing the model
SmallerModelTask = future({step(multinom(dominant_lc~1, Data.df), paste("dominant_lc ~", paste0(AllCovars, collapse="+")), direction="forward")}) # takes long but may be useful to run
resolved(SmallerModelTask)
SmallerModel = value(SmallerModelTask)
# Result: multinom(formula = dominant_lc ~ scale(mean.ndvi) + scale(BDTICM.M.BDTICM_M) +
#     scale(min.srad) + scale(bio12) + scale(max.vapr) + scale(bio10) +
#     scale(ndvi.iqr) + scale(wc2.0_30s_prec_03) + scale(wc2.0_30s_prec_08) +
#     scale(bio17) + scale(bio8) + scale(bio2) + scale(wc2.0_30s_vapr_08) +
#     scale(wc2.0_30s_wind_10) + scale(x), data = Data.df)
SmallerModelBIC = step(multinom(dominant_lc~1, Data.df), paste("dominant_lc ~", paste0("scale(", UncorrelatedCovars, ")", collapse="+")), direction="forward", k=log(nrow(Data.df)))

Predictions = predict(SmallerModel, Data.val[,GetAllPixelCovars()], type="probs")
Predictions = as.data.frame(Predictions)

#CVPrediction = CrossValidate(paste("dominant_lc ~", paste0("scale(", AllCovars, ")", collapse="+")), Data.df, multinom, predict, type="probs")

AccuracyStatisticsPlots(Predictions, Data.val[, colnames(Predictions)]/100) # RMSE of 19.7%, MAE of 10.7%
SCM(Predictions, as.matrix(Data.val[, colnames(Predictions)]/100), plot=TRUE, totals=TRUE, scale=TRUE) # 63%±5 accuracy, kappa 0.53
ggplot(data.frame(Prediction=unlist(Predictions), Truth=unlist(Data.val[, colnames(Predictions)]/100)), aes(Truth, Prediction)) + # Scatterplot: just as non-linear as RF
    geom_hex() +
    scale_fill_distiller(palette=7, trans="log") #log scale
cor(unlist(Predictions), unlist(Data.val[, colnames(Predictions)]/100))^2 # 0.59
NSE(unlist(Predictions), unlist(Data.val[, colnames(Predictions)]/100)) # 0.54

# How much does it overfit: when without CV
AccuracyStatisticsPlots(Predictions, Data.df[, colnames(Predictions)]/100) # RMSE of 17% still
SCM(Predictions, Data.df[, colnames(Predictions)]/100, plot=TRUE, totals=TRUE, scale=TRUE) #61% accuracy, kappa 0.51
# So CV has little effect

# What if we oversample to balance the dataset
CVPrediction = CrossValidate(paste("dominant_lc ~", paste0("scale(", AllCovars, ")", collapse="+")), Data.df, multinom, predict, type="probs", oversample=TRUE)
AccuracyStatisticsPlots(CVPrediction, Data.df[, colnames(CVPrediction)]/100) # RMSE of 17%
SCM(CVPrediction, as.matrix(Data.df[, colnames(CVPrediction)]/100), plot=TRUE, totals=TRUE, scale=TRUE) # 60% accuracy, kappa 0.51
# So there is no difference

# Modelling zeroes separately doesn't make sense in this case: the model sees labels, which are not zero. So only class balance is an issue.


# Run MTM and estimate G and E variance-covariance matrices for 17 traits
# 09-04-2018, G. Slavov
# http://quantgen.github.io/MTM/vignette.html
# Some minor changes for GitHub upload by Chris Davey 14/9/18

library(MTM)
library(rrBLUP)

#Load G matrix
load("G_v2.RData")

#Load random number seed.
load("current_seeds.RData")

traits<-1:17
reps <-1
blank_cols = 7 # blank columns in pheno file

#Phenos
pheno_data<-read.csv("pheno_data_v2.csv")
print(str(pheno_data))

# Genos
G<-t(G) # Transpose for A.mat!
print(dim(G))

# Kinship/GRM matrix
K <- A.mat(G)
rownames(K)<-pheno_data$geno

P<-data.frame(pheno_data[,(blank_cols+1):(blank_cols+length(traits))])

										# Get estimates of genetic variances and covariances using MTM
										fm_all <- MTM(
										  Y = P,
										  K = list(
											list(
											  K = K,
											  COV = list(
												type = 'UN',
												df0 = 17,
												S0 = diag(17)
											  )
											)
										  ),
										  resCov = list(
											type = 'UN',
											S0 = diag(17),
											df0 = 17
										  ),
										  nIter = 11000,
										  burnIn = 1000,
										  thin = 5,
										 )
Emat<-fm_all$resCov$R # residual covariance matrix
Gmat<-fm_all$K[[1]]$G # genetic covariance matrix
rownames(Gmat)=colnames(Gmat)=rownames(Emat)

# Print/save files
rm(G)
save.image("out_varcovar_miscanthus_2TT_138_MTM_blues.RData")


#name: RNaiveBayesTrain
#meta.mlname: RNaiveBayes
#meta.mlrole: train
#description: Custom R Train func for Naive Bayes
#language: r
#input: dataframe df
#input: string predict_column
#input: string laplace {category: Parameters}
#output: blob model

#>>> Initialize local environment and install/require necessary packages
library(caret)
library(e1071)

#if (!require(naiveBayes)) install.packages('naiveBayes')  #install package if not already there
#library(naiveBayes)
#install.packages('fastDummies')
#renv::install("fastDummies")
#install.packages("scales")
#require(fastDummies)

#>>> Extract/Prepare train features and target variable
trainY <- df[[predict_column]]
trainX <- df[, -grep(predict_column, colnames(df))]

#>>> Convert categorical features into dummy variables
dummies <- dummyVars(" ~ .", data = trainX)
trainX = data.frame(predict(dummies, newdata = trainX))

#>>> Train model
trained_model <- naiveBayes(x=trainX, y=trainY, laplace = laplace)

#>>> Save trained model
saveRDS(trained_model, file=model)


#' Extract AUC from keras evaluation
#'
#' @importFrom magrittr %>%
#'
#' @param keras_evaluation A table containing the keras evaluation.
#'
#' @return A numeric value indicating the AUC of the tested keras model.
#' @examples
#' \dontrun{
#' # download benchmarking data
#' benchmarking_data <- get_benchmarking_data("Lynx lynx",
#'                                            limit = 1500)
#'
#' # transform benchmarking data into a format suitable for deep learning
#' # if you have previously used a partitioning method you should specify it here
#' benchmarking_data_dl <- prepare_dl_data(input_data = benchmarking_data$df_data,
#'                                        partitioning_type = "default")
#'
#' # perform sanity check on the transformed dataset
#' # for the training set
#' head(benchmarking_data_dl$train_tbl)
#' table(benchmarking_data_dl$y_train_vec)
#'
#' # for the test set
#' head(benchmarking_data_dl$test_tbl)
#' table(benchmarking_data_dl$y_test_vec)
#'
#' # train neural network
#' keras_results <- train_dl(benchmarking_data_dl)
#'
#' # inspect training results
#' keras_results$history
#'
#' # you can also plot them
#' plot(keras_results$history)
#'
#' # create evaluation tibble containing training results
#' keras_evaluation <- evaluate_dl(keras_results$model, benchmarking_data_dl)
#'
#' # compute AUC
#' keras_auc <- get_dl_auc(keras_evaluation)
#'
#' # print AUC
#' keras_auc
#' }
#' @export
get_dl_auc <- function(keras_evaluation) {
    keras_auc_df <- keras_evaluation %>%
        yardstick::pr_auc(truth, class_prob)

    return(round(keras_auc_df$.estimate, 3))
}


library(tidyverse)
library(dplyr)
library(ggplot2)

DF1 <- readr::read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/vaccinations/vaccinations.csv")

DFManufacturer <- readr::read_csv("./O21/country_vaccinations_by_manufacturer.csv") %>%
  rename(region = location)

totalVaccCountry <- DF1 %>%
  group_by(location) %>%
  summarise(total_vaccinations = sum(total_vaccinations[!is.na(total_vaccinations)]))

print(totalVaccCountry)

VaccManufacturer  <- DFManufacturer %>%
  group_by(region,vaccine) %>%
  summarise(total_vaccinations = sum(total_vaccinations[!is.na(total_vaccinations)]))

VaccManufacturerCount  <- DFManufacturer %>%
  group_by(vaccine) %>%
  summarise(total_vaccinations = sum(total_vaccinations[!is.na(total_vaccinations)]))

print(VaccManufacturerCount)

barplot(height=VaccManufacturerCount$total_vaccinations, names=VaccManufacturerCount$vaccine,
        main = "Gráfica de vacunas por marca", xlab = "Marca de vacuna", ylab = "Cantidad")

print(VaccManufacturer)

VaccManufacturerSplited <- VaccManufacturer %>%
  pivot_wider(names_from = vaccine, values_from = total_vaccinations, values_fill = 0)

VaccManufacturer %>%
  group_by(region) %>%
  slice_max(n = 1, order_by = total_vaccinations)

#VaccTemp = subset(VaccManufacturerSplited, select = -c(region))

VaccManufacturerFinal <- VaccManufacturerSplited %>%
  #tidying
  #mutate(id = row_number()) %>%
  pivot_longer(-region, values_to = "amount") %>%
  group_by(region) %>%
  arrange(region, desc(amount)) %>%
  #workhorse
  mutate(popularVaccine = head(name, 1) ) %>%
  #Pivot
  pivot_wider(names_from = name, values_from = amount) %>%
  rename(J_J         = `Johnson&Johnson`, # renombré algunas columnas
         AstraZeneca = `Oxford/AstraZeneca`,
         Pfizer      = `Pfizer/BioNTech`,
         Sinopharm    = `Sinopharm/Beijing`,
         Sputnik     = `Sputnik V`) %>%
  mutate(Total = sum(across(Pfizer:Sputnik))) %>% # agregué una columna con el total de vacunas por país
  # mutate(across(Pfizer:Sputnik, ~ ./Total * 100)) # agregué columnas con el % de cada vacuna por país
  mutate(across(Pfizer:Sputnik, .fns = list(pct = ~ ./Total * 100)))
#clean_names() # intento de quitar los puntos de los nombres de las columnas

#creating map

mapData <- map_data("world")
view(mapData)
mapData <- left_join(mapData, VaccManufacturerFinal, by="region")
view(mapData)
#mapData1 <- mapData %>% filter(!is.na(mapData$popularVaccine))
#view(mapData1)

mapData %>%
  glimpse()
 # select(Pct.Moderna)

mapa <- ggplot(mapData, aes(x=long, y=lat, group=group)) +
  geom_polygon(
    aes(
      label = region,
      fill = popularVaccine,
      label1 = `Moderna_pct`,
      label2 = `CanSino_pct`,
      label3 = `J_J_pct`,
      label4 = `AstraZeneca_pct`,
      label5 = `Pfizer_pct`,
      label6 = `Sinopharm_pct`,
      label7 = `Sinovac_pct`,
      label8 = `Sputnik_pct`
      #label1 = text
        ),
    color = "black") +
  theme_void()
mapa

plotly::ggplotly(mapa)


#' Compute ratio with confidence interval.
.get_ratio_with_ci <- function (data, key, orig, base_name, metric_name) {

    # Get the baseline from the original data.
    base_data <- orig %>% filter (benchmark == key $ benchmark, vm == base_name)
    if (nrow (base_data) == 0) return (tibble (avg = NA, lo = NA, hi = NA))

    # We work on run means for speed.
    data_runs <- get_run_means (data, metric_name)
    base_runs <- get_run_means (base_data, metric_name)

    # Do not even try with one run.
    if ((length (data_runs) > 1) && (length (base_runs) > 1)) {

        # Helper function for stratified bootstrap.
        meanify <- function (data, index) {
            data_top <- data $ value [index [data $ strata]]
            data_bot <- data $ value [index [!data $ strata]]
            return (mean (data_top) / mean (data_bot))
        }

        # Stratified bootstrap computation.
        means_tibble <- bind_rows (tibble (value = data_runs, strata = FALSE), tibble (value = base_runs, strata = TRUE))
        ratio_boot <- boot (means_tibble, meanify, R = REPLICATES, strata = means_tibble $ strata)

        # The computations can fail so fall back to something if they do.
        ratio_ci <- tryCatch (boot.ci (ratio_boot, type = 'bca', conf = CONFIDENCE), error = function (e) NA)
        if (!is.null (ratio_ci) && !any (is.na (ratio_ci))) return (tibble (avg = ratio_boot $ t0, lo = ratio_ci $ bca [1,4], hi = ratio_ci $ bca [1,5]))
        ratio_ci <- tryCatch (boot.ci (ratio_boot, type = 'basic', conf = CONFIDENCE), error = function (e) NA)
        if (!is.null (ratio_ci) && !any (is.na (ratio_ci))) return (tibble (avg = ratio_boot $ t0, lo = ratio_ci $ basic [1,4], hi = ratio_ci $ basic [1,5]))
    }

    return (tibble (avg = mean (base_runs) / mean (data_runs), lo = NA, hi = NA))
}

#' Compute ratio with confidence intervals per given group and base name.
comp_ratio_with_ci <- function (data, base_name, metric_name) {
    return (data %>% group_modify (.get_ratio_with_ci, data, base_name, metric_name))
}


## Packages and options ----------------------------------------------------
library(bayesplot)
library(brms)
library(loo)
library(ggplot2)
library(dplyr)
library(here)
library(parallel)

options(mc.cores = detectCores())

compare_models <- function(file, type, models = NULL) {
  ## Load fits ---------------------------------------------------------------
  fits <- readRDS(file)
  if (!is.null(models)) {
    fits$models[[type]] <- fits$models[[type]][models]
  }

  filetype <- sub("sgene_fits_", "", basename(file))
  filetype <- paste0(sub("\\.rds", "", filetype), "_", type)

  fit_data <- fits$data[[type]] %>%
    filter(!is.na(prop))

  ## Add custom family functions ---------------------------------------------
  expose_functions(fits$models[[type]][[1]], vectorize = TRUE)

  log_lik_add_var_student <<- function(i, prep) {
    mu <- prep$dpars$mu[, i]
    sigma <- prep$dpars$sigma
    nu <- prep$dpars$nu
    alpha <- prep$dpars$alpha
    frac <- prep$data$vreal1[i]
    y <- prep$data$Y[i]
    add_var_student_lpdf(y, mu, sigma, nu, alpha, frac)
  }

  posterior_predict_add_var_student <<- function(i, prep, ...) {
    mu <- prep$dpars$mu[, i]
    sigma <- prep$dpars$sigma
    nu <- prep$dpars$nu
    alpha <- prep$dpars$alpha
    frac <- prep$data$vreal1[i]
    add_var_student_rng(mu, sigma, nu, alpha, frac)
  }

  ## Score fits --------------------------------------------------------------
  loos <- fits$models[[type]] %>%
    lapply(add_criterion, "loo") %>%
    lapply(loo, save_psis = TRUE)

  lc <- loo_compare(loos)

  ## Model diagnostics -------------------------------------------------------
  y <- fit_data$rt_mean
  yrep <- lapply(fits$models[[type]], posterior_predict)

  psis <- lapply(fits$models[[type]], function(x) psis(-log_lik(x)))
  lw <- lapply(psis, weights)

  post <- lapply(fits$models[[type]],  function(x) {
    samples <- posterior_samples(x, "alpha")
    q <- quantile(samples[, "alpha"] - 1, c(0.025, 0.5, 0.975))
    q <- round(q, 2)
    return(q)
  })

  return(list(post = post,
              loos = loos,
              lc = lc,
              y = y,
              yrep = yrep,
              psis = psis))
}

gt <- c("short", "long")
res <- lapply(gt, function(x) {
  compare_models(here("output", paste0("sgene_fits_", x, "_gt.rds")),
                 "dynamic")
})
names(res) <- gt

saveRDS(res, here("output", "sgene_model_comparison.rds"))


library("caret")
library("klaR")
library("e1071")
library("ROCR")

library(data.table)

setwd("C:\\Users\\Lenovo\\Desktop\\IIIT-Delhi\\semester 7\\IP_LOGS")
accel <- read.csv("data-training3.csv", stringsAsFactors=F)

xTrain <- accel[1:2]
nb_model <- naiveBayes(as.factor(target) ~ ., data = accel, laplace = 3)

Sample30<- read.csv("data-train.csv", stringsAsFactors=F)
xTest<-Sample30[2:2]

nb_predict <- predict(nb_model, xTest)
nb_predict_raw <- predict(nb_model, xTest,type="raw")
nb_predict_prob <- nb_predict_raw[,2]

pred <- prediction(nb_predict_prob,Sample30$target)
perf <- performance(pred,"tpr","fpr")
plot(perf)
nb_confusionMatrix<-confusionMatrix(data = nb_predict, reference =Sample30$target )


library(minpack.lm)
library(lattice)

winRatios <- get.WinRatios(data)

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

exponents <- apply(data, 1, getExponents, correctDrawn = 3)
data.analysis <- data.frame(winRatios$ratio.win3, t(exponents))
data.analysis <- data.analysis[complete.cases(data.analysis), ]

colnames(data.analysis) <- c(
    "ratio",
    "r1", "r2", "r3", "r4", "r5", "r6", "r7", "r8", "r9", "r10",
    "r11", "r12", "r13", "r14", "r15", "r16", "r17", "r18", "r19", "r20",
    "r21", "r22", "r23", "r24", "r25", "r26", "r27", "r28", "r29", "r30",
    "r31", "r32", "r33", "r34", "r35", "r36", "r37", "r38", "r39", "r40",
    "r41", "r42", "r43", "r44", "r45", "r46", "r47", "r48", "r49"
)

model <- nlsLM(ratio ~ x1^r1 * x2^r2 * x3^r3 * x4^r4 * x5^r5 * x6^r6 * x7^r7 * x8^r8 * x9^r9 *
    x10^r10 * x11^r11 * x12^r12 * x13^r13 * x14^r14 * x15^r15 * x16^r16 * x17^r17 * x18^r18 * x19^r19 *
    x20^r20 * x21^r21 * x22^r22 * x23^r23 * x24^r24 * x25^r25 * x26^r26 * x27^r27 * x28^r28 * x29^r29 *
    x30^r30 * x31^r31 * x32^r32 * x33^r33 * x34^r34 * x35^r35 * x36^r36 * x37^r37 * x38^r38 * x39^r39 *
    x40^r40 * x41^r41 * x42^r42 * x43^r43 * x44^r44 * x45^r45 * x46^r46 * x47^r47 * x48^r48 * x49^r49,
data = data.analysis,
start = c(
    x1 = 1, x2 = 1, x3 = 1, x4 = 1, x5 = 1, x6 = 1, x7 = 1, x8 = 1, x9 = 1,
    x10 = 1, x11 = 1, x12 = 1, x13 = 1, x14 = 1, x15 = 1, x16 = 1, x17 = 1, x18 = 1, x19 = 1,
    x20 = 1, x21 = 1, x22 = 1, x23 = 1, x24 = 1, x25 = 1, x26 = 1, x27 = 1, x28 = 1, x29 = 1,
    x30 = 1, x31 = 1, x32 = 1, x33 = 1, x34 = 1, x35 = 1, x36 = 1, x37 = 1, x38 = 1, x39 = 1,
    x40 = 1, x41 = 1, x42 = 1, x43 = 1, x44 = 1, x45 = 1, x46 = 1, x47 = 1, x48 = 1, x49 = 1
)
)

model.sum <- summary(model)
x <- 1:49
avg <- model.sum$coefficients[, 1]
sdev <- model.sum$coefficients[, 2]

file <- file.path(outdir, "win3-general.png")
png(file, bg = "white", width = 2000, height = 400)
plot(x, avg,
    xlim = c(-0.2, 49.5),
    ylim = c(0.7, 1.5),
    # ylim=range(c(avg-sdev, avg+sdev)),
    pch = 19,
    xlab = "Lotto number", ylab = "Pick frequency",
    main = "Pick frequency of lotto numbers"
)
axis(1, at = x, labels = x)
text(x + 0.5, avg, labels = round(avg, 2), cex = 0.7)
arrows(x, avg - sdev, x, avg + sdev, length = 0.05, angle = 90, code = 3)
dev.off()

# index least played numbers
best <- match(head(sort(avg), 6), avg)
best <- sort(best)

best.zz <- match(head(sort(avg.3zz),1), avg.3zz)

file <- file.path(outdir, "win3-numbers.png")
png(file, bg = "black", width = 600, height = 100)
par(mar=c(1,1,1,1))
plot.new()
plot.window(0:1, 0:1)
text(.5,.5, paste(c(best, " ", best.zz - 1), collapse=" "), cex=5, col=rgb(.9,.9,.9,.7))
dev.off()

# calculate expected return for best numbers
ret <- round(0.5 / mean(avg[best], avg.3zz[best.zz]), 2)

file <- file.path(outdir, "win3-expected-return.png")
png(file, bg = "black", width = 300, height = 100)
par(mar=c(1,1,1,1))
plot.new()
plot.window(0:1, 0:1)
text(.5,.5, paste(c("€", ret), collapse=" "), cex=5, col=rgb(.9,.9,.9,.7))
dev.off()

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

heatmap <- data.frame(expand.grid(x = seq(1, 7), y = seq(7, 1)),
    value = avg,
    labels = seq(1, 49)
)

file <- file.path(outdir, "win3-general-heat.png")
png(file, bg = "white", width = 800, height = 800)
print(levelplot(value ~ x + y, heatmap,
    col.regions = hcl.colors(100, "Temps"),
    title = "Lottery ticket heatmap",
    xlab = "", ylab = "",
    panel = function(...) {
        arg <- list(...)
        panel.levelplot(...)
        panel.text(arg$x, arg$y, arg$subscripts)
    }
))
dev.off()

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

exponents <- apply(data, 1, getExponents, correctDrawn = 4)
data.analysis <- data.frame(winRatios$ratio.win4, t(exponents))
data.analysis <- data.analysis[complete.cases(data.analysis), ]

colnames(data.analysis) <- c(
    "ratio",
    "r1", "r2", "r3", "r4", "r5", "r6", "r7", "r8", "r9", "r10",
    "r11", "r12", "r13", "r14", "r15", "r16", "r17", "r18", "r19", "r20",
    "r21", "r22", "r23", "r24", "r25", "r26", "r27", "r28", "r29", "r30",
    "r31", "r32", "r33", "r34", "r35", "r36", "r37", "r38", "r39", "r40",
    "r41", "r42", "r43", "r44", "r45", "r46", "r47", "r48", "r49"
)

model <- nlsLM(ratio ~ x1^r1 * x2^r2 * x3^r3 * x4^r4 * x5^r5 * x6^r6 * x7^r7 * x8^r8 * x9^r9 *
    x10^r10 * x11^r11 * x12^r12 * x13^r13 * x14^r14 * x15^r15 * x16^r16 * x17^r17 * x18^r18 * x19^r19 *
    x20^r20 * x21^r21 * x22^r22 * x23^r23 * x24^r24 * x25^r25 * x26^r26 * x27^r27 * x28^r28 * x29^r29 *
    x30^r30 * x31^r31 * x32^r32 * x33^r33 * x34^r34 * x35^r35 * x36^r36 * x37^r37 * x38^r38 * x39^r39 *
    x40^r40 * x41^r41 * x42^r42 * x43^r43 * x44^r44 * x45^r45 * x46^r46 * x47^r47 * x48^r48 * x49^r49,
data = data.analysis,
start = c(
    x1 = 1, x2 = 1, x3 = 1, x4 = 1, x5 = 1, x6 = 1, x7 = 1, x8 = 1, x9 = 1,
    x10 = 1, x11 = 1, x12 = 1, x13 = 1, x14 = 1, x15 = 1, x16 = 1, x17 = 1, x18 = 1, x19 = 1,
    x20 = 1, x21 = 1, x22 = 1, x23 = 1, x24 = 1, x25 = 1, x26 = 1, x27 = 1, x28 = 1, x29 = 1,
    x30 = 1, x31 = 1, x32 = 1, x33 = 1, x34 = 1, x35 = 1, x36 = 1, x37 = 1, x38 = 1, x39 = 1,
    x40 = 1, x41 = 1, x42 = 1, x43 = 1, x44 = 1, x45 = 1, x46 = 1, x47 = 1, x48 = 1, x49 = 1
)
)

model.sum <- summary(model)
x <- 1:49
avg <- model.sum$coefficients[, 1]
sdev <- model.sum$coefficients[, 2]

file <- file.path(outdir, "win4-general.png")
png(file, bg = "white", width = 2000, height = 400)
plot(x, avg,
    xlim = c(-0.2, 49.5),
    ylim = c(0.7, 1.5),
    # ylim=range(c(avg-sdev, avg+sdev)),
    pch = 19,
    xlab = "Lotto number", ylab = "Pick frequency",
    main = "Pick frequency of lotto numbers"
)
axis(1, at = x, labels = x)
text(x + 0.5, avg, labels = round(avg, 2), cex = 0.7)
arrows(x, avg - sdev, x, avg + sdev, length = 0.05, angle = 90, code = 3)
dev.off()

# index least played numbers
best <- match(head(sort(avg), 6), avg)
best <- sort(best)

best.zz <- match(head(sort(avg.4zz),1), avg.4zz)

file <- file.path(outdir, "win4-numbers.png")
png(file, bg = "black", width = 600, height = 100)
par(mar=c(1,1,1,1))
plot.new()
plot.window(0:1, 0:1)
text(.5,.5, paste(c(best, " ", best.zz - 1), collapse=" "), cex=5, col=rgb(.9,.9,.9,.7))
dev.off()

# calculate expected return for best numbers
ret <- round(0.5 / mean(avg[best], avg.4zz[best.zz]), 2)

file <- file.path(outdir, "win4-expected-return.png")
png(file, bg = "black", width = 300, height = 100)
par(mar=c(1,1,1,1))
plot.new()
plot.window(0:1, 0:1)
text(.5,.5, paste(c("€", ret), collapse=" "), cex=5, col=rgb(.9,.9,.9,.7))
dev.off()

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

heatmap <- data.frame(expand.grid(x = seq(1, 7), y = seq(7, 1)),
    value = avg,
    labels = seq(1, 49)
)

file <- file.path(outdir, "win4-general-heat.png")
png(file, bg = "white", width = 800, height = 800)
print(levelplot(value ~ x + y, heatmap,
    col.regions = hcl.colors(100, "Temps"),
    title = "Lottery ticket heatmap",
    xlab = "", ylab = "",
    panel = function(...) {
        arg <- list(...)
        panel.levelplot(...)
        panel.text(arg$x, arg$y, arg$subscripts)
    }
))
dev.off()


# Using binsegRcpp to compute binary segmentation models up to 5 segments
# Plot segement means on top of data

if(!require(binsegRcpp)) {
    install.packages("binsegRcpp")
}

if(!require(neuroblastoma)) {
    install.packages("neuroblastoma")
}

# import and load neuroblastoma dataset
library('neuroblastoma')
data('neuroblastoma')

# using np as neuro.profiles for profile data
np = neuroblastoma$profiles
xy = np[np$profile.id == 4 & np$chromosome == 2, ]
x = xy$position
y = xy$logratio
M = matrix(c(x,y), ncol=2)
# computing binary segmentation models upto 5 segments using binsegRcpp
model <- binsegRcpp::binseg_normal(y,6)

# get changepoints and segment mean
cm = coef(model,6:6)

# create segment mean lines
change.lines = x[as.vector(matrix(c(cm$start, cm$end), ncol=length(cm$start), nrow=2, byrow=TRUE))]
segment.mean = as.vector(matrix(cm$mean, ncol=length(cm$mean), nrow=2, byrow=TRUE))

# detected changepoints
print(cm$end)

# segment means
print(cm$mean)

# plot changepoint and segment mean over data
svg('Easy/task1b.svg')
plot(x,y,type='l', xaxt='n', xlab="Segments", ylab="logpoint ratios of the probe", main="Neuroblastoma changepoint detection using 'binsegRcpp'")
axis(1, at=x[seq(1, 234, 50)], labels=seq(0, 200, 50))
grid()
legend(x=x[5], y=-0.5, legend=c("position vs logpoint data", "segment mean", "changepoint"), col=c("black","red","blue"), lty=c(1,1,NA), pch=c(NA,NA,'X'), cex=0.8, bg='lightblue')

# add segment mean
alter <- seq(1, 12, 2)
segments(x0=change.lines[alter], y0=segment.mean[alter], x1=change.lines[alter+1], y1=segment.mean[alter+1], col='red')

# add changepoints
points(as.numeric(change.lines[alter+1])[1:5], as.numeric(segment.mean[alter])[1:5], col='blue', pch='X')

dev.off()


library(greta)

source('01_helpers.r')

##*************************************
## ---- fidget a soft-max function ----
## https://github.com/greta-dev/greta/issues/120#comment-362489577
##*************************************

# library(tensorflow)
# op <- greta::.internals$nodes$constructors$op
# softmax <- function (logits) {
#   op("softmax", logits, tf_operation = tf$nn$softmax)
# }

##*************************************
## ---- testing multinomial models ----
##*************************************

# obs <- matrix(
#   c(10,30,50,
#     23,14,67),
#   nrow = 2,
#   byrow = T
# )
# y <- as_data(obs)
# pred <- dirichlet(t(c(1,1,1)), n_realisations = 2)
# distribution(y) <- multinomial(size = rowSums(obs), prob = pred)
# m <- model(pred)
# samples <- greta::mcmc(m, n_samples =1000)
# bayesplot::mcmc_dens(samples)

##***************************************
## ---- test soft-max implementation ----
##***************************************

# alpha <- uniform(0.9,1.1)
# utils <- as_data(matrix(c(5,10,1, 4,4,4), nrow = 2, byrow = T))
# logits <- exp(alpha * utils)
# logit_sums <- greta::apply(logits, MARGIN = 1, FUN = "sum")
# pred <- sweep(logits, 1, logit_sums, FUN = "/")
#
# m <- model(pred)
#
# opt(m)

##************************************
## ---- dummy fit for actual data ----
##************************************

# alpha <- uniform(0,100)
# y <- as_data(y_counts_high)
# # pred <- dirichlet(t(rep(1/ncol(y), ncol(y))), n_realisations = nrow(y))
# utils <- dirichlet(t(rep(1, ncol(y))), n_realisations = nrow(y))
# logits <- exp(alpha * utils)
# logit_sums <- greta::apply(logits, MARGIN = 1, FUN = "sum")
# pred <- sweep(logits, 1, logit_sums, FUN = "/")
# distribution(y) <- multinomial(size = rowSums(y), prob = pred)
# m <- model(pred)
# opt(m)$par$pred -> fit_opt

# fit_opt[1:5, 1:5]
# prop.table(y_counts_high,1)[1:5, 1:5]

# plot(prop.table(y_counts_high,1) %>% as.vector, fit_opt %>% as.vector)

##*************************************
## ---- actual fit for actual data ----
##*************************************

## data for greta

y_high <- as_data(y_counts_high)
# y_high_i <- as_data(t(y_counts_high[1,]))
y_low  <- as_data(y_counts_low)

## priors

# theta_false <- inverse_gamma(.5, .5)
# theta_neg <- gamma(0.5,0.5)
# theta_false <- uniform(- 10000, 0)
# theta_neg <- uniform(- 10000, 0)
# theta_false <- uniform(-100,0)
# theta_neg <- uniform(-10,0)
theta_neg <- -3
theta_info_arg_weight <- uniform(0,1)
theta_alpha <- uniform(0,5)

## predictions
#### (build matrix representations for utility ingredients (sit x sent))
truth_matrix_greta <- (1 - truth_table_matrix) * -60
# cost
boolean_negation_matrix <-  # entry 1 for all sentences containing "none"
  matrix(rep(str_detect(sentences, "none") %>% as.numeric, times = 20), nrow = 20, byrow = T)
cost_matrix_greta <- theta_neg * boolean_negation_matrix
# informativity
info_matrix_greta <-
  matrix(rep(informativity_vector, each = 20), nrow = 20)
# argumentative strength
argstr_matrix_greta_high <-
  matrix(rep(arg_strength_vector, times = 20), nrow = 20, byrow = T)
argstr_matrix_greta_low <-
  matrix(rep(-arg_strength_vector, times = 20), nrow = 20, byrow = T)
# utility
util_high <- truth_matrix_greta +
  cost_matrix_greta +
  theta_info_arg_weight * info_matrix_greta +
  (1 - theta_info_arg_weight) * argstr_matrix_greta_high
util_low <- truth_matrix_greta +
  cost_matrix_greta +
  theta_info_arg_weight * info_matrix_greta +
  (1 - theta_info_arg_weight) * argstr_matrix_greta_low

# prediction
logits_high <- exp(theta_alpha * util_high)
logits_low  <- exp(theta_alpha * util_low)
logit_sums_high <- greta::apply(logits_high, MARGIN = 1, FUN = "sum")
logit_sums_low  <- greta::apply(logits_low,  MARGIN = 1, FUN = "sum")
pred_high <- sweep(logits_high, 1, logit_sums_high, FUN = "/")
pred_low  <- sweep(logits_low, 1,  logit_sums_low,  FUN = "/")

## likelihood

distribution(y_high) <- multinomial(size = rowSums(y_counts_high), prob = pred_high)
distribution(y_low)  <- multinomial(size = rowSums(y_counts_low),  prob = pred_low)

## define model

m <- model(
  pred_high,
  pred_low,
  theta_info_arg_weight,
  theta_alpha
)

# samples <- greta::mcmc(m, n_samples =1000)
# bayesplot::mcmc_dens(samples)
# bayesplot::mcmc_pairs(samples)

fit_MAP <- opt(m)
show(fit_MAP)
saveRDS(fit_MAP, 'fit_MAP.RDS')

# exploring MAP-predictions

obs_tibble <- as_tibble(
  rbind(prop.table(y_counts_high,1),
        prop.table(y_counts_low,1)
  )
) %>%
  mutate(
    situation = rep(1:20,2),
    condition = rep(c("high", "low"), each = 20)
  ) %>%
  pivot_longer(
    cols = - c("situation", "condition"),
    names_to = "sentence",
    values_to = "observed"
  ) %>%
  mutate(
    predicted = rbind(fit_MAP$par$pred_high, fit_MAP$par$pred_low)  %>%
      as_tibble() %>%
      pivot_longer(everything()) %>%
      pull(value) %>%
      as.vector(),
    truth = rbind(truth_table_matrix, truth_table_matrix) %>%
      as_tibble() %>%
      pivot_longer(everything()) %>%
      pull(value) %>%
      as.vector(),
    arg_str = arg_strength_vector[sentence],
    informativity = informativity_vector[sentence],
    pred_error = predicted - observed
    ) %>%
  arrange(condition, situation, -abs(pred_error))

with(obs_tibble,
     cor.test(predicted, observed)
) %>% show()

message(
  "Correlation overall: ",
  with(obs_tibble, cor.test(predicted, observed))$estimate %>% signif(3)
)
message(
  "Correlation 'high': ",
  with(obs_tibble %>% filter(condition == "high"), cor.test(predicted, observed))$estimate %>% signif(3)
)
message(
  "Correlation 'low': ",
  with(obs_tibble %>% filter(condition == "low"), cor.test(predicted, observed))$estimate %>% signif(3)
)

# View(obs_tibble)

obs_pred_plot <- obs_tibble %>%
  ggplot(aes( x = predicted, y = observed, color = condition)) +
  geom_smooth(method = "lm") +
  geom_point( alpha = 0.5)

##******************************************
## ---- samples from Bayesian posterior ----
##******************************************

samples <- greta::mcmc(m, n_samples = 4000, thin = 2)
tidy_draws <- ggmcmc::ggs(samples) %>%
  filter(!str_detect(Parameter, "pred"))

# obtain Bayesian point and interval estimates
Bayes_estimates <- tidy_draws %>%
  group_by(Parameter) %>%
  summarise(
    '|95%' = HDInterval::hdi(value)[1],
    mean = mean(value),
    '95|%' = HDInterval::hdi(value)[2]
  )
Bayes_estimates

##******************************************
## ---- plotting the Bayesian posterior ----
##******************************************

dens_alpha <- filter(tidy_draws, Parameter == "theta_alpha") %>% pull(value) %>%
  density()
dens_beta <- filter(tidy_draws, Parameter == "theta_info_arg_weight") %>% pull(value) %>%
  density()

post_plot_data <-
  tibble(
    parameter = c(rep("alpha", length(dens_alpha$x)), rep("beta", length(dens_beta$x))),
    x = c(dens_alpha$x, dens_beta$x),
    y = c(dens_alpha$y, dens_beta$y),
    x_area = case_when(
      parameter == "alpha" ~ ifelse(x > Bayes_estimates[1,2] %>% as.numeric & x < Bayes_estimates[1,4] %>% as.numeric, x, NA ),
      parameter == "beta"  ~ ifelse(x > Bayes_estimates[2,2] %>% as.numeric & x < Bayes_estimates[2,4] %>% as.numeric, x, NA )
    )
  )

posterior_plot <-
  post_plot_data %>%
  ggplot(aes(x = x, y = y)) +
  geom_line(size = 1.5) +
  geom_area(aes(x = x_area),
            fill = "firebrick", alpha = 0.5) +
  facet_wrap(~parameter, scales = "free", labeller = label_parsed) +
  labs(
    x = "",
    y = ""
  )

ggsave(plot = posterior_plot, filename = "posterior_plot.png", width = 4, height = 2.5)


#弯月面Meniscus的高度和角度随流量，极间距离，针头直径变化而变化
#针头三种液体，ethanol，acetone， isoproply
#height高度和angle角度，在一张图上，分为上下部分
#三张图，分别对应三种x轴，流量，极间距离，电压
#固定电压数值为2.0kv
#用mtext函数标记其他相关参数信息
#函数名为men_ah & men_ea, men_ah & men_aa，men_ih & men_ia

#设定工作区间
setwd("D:/data")
library(xlsx)

#读取数据
men_ah<-read.xlsx("set_voltage.xls", sheetName="distance_h", header=TRUE)
men_aa<-read.xlsx("set_voltage.xls", sheetName="distance_a", header=TRUE)

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

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

################################画图-高度曲线###########################
plot(men_ah$distance, men_ah$ethanol, col=0, xaxs="i", xlim=c(0.9, 4.1), ylim=c(0.1, 1.1),
xlab="Distance (mm)", cex.lab=1, ylab="Height of Meniscus (mm)", main="Height with H in meniscus")

lines(lowess(men_ah$distance, men_ah$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ah$distance, men_ah$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ah$distance, men_ah$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("topleft", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

##############################画图--角度曲线############################
plot(men_aa$distance, men_aa$ethanol, col=0, xaxs="i", xlim=c(0.9, 4.1), ylim=c(50, 140),
xlab="Distance (mm)", cex.lab=1, ylab="Taylor Angle (°)", main="Angle with H in meniscus")

lines(lowess(men_aa$distance, men_aa$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_aa$distance, men_aa$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_aa$distance, men_aa$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("topright", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

mtext("Voltage is set at 2.0 kv", 1, line=1, col="black", cex=1.3, font=2, outer=TRUE)

###标注信息

dev.off()


#######################################################################################################
#   Parameter estimation using R's optim function
#   Minimal error checking is done.  You should run is.marssMLE() before calling this.
#   Q and R are not allowed to be time-varying
#   Likelihood computation is via  Kalman filter
#######################################################################################################
MARSSoptim <- function(MLEobj) {
  # This function does not check if user specified a legal MLE object.
  ##
  # Define needed negLogLik function with chol transformed variances
  #
  neglogLik <- function(x, MLEobj = NULL) { # NULL assignment needed for optim call syntax
    # MLEobj is tmp.MLEobj so has altered free and fixed
    # x is the paramvector

    # update the MLEobj by putting the estimated pars from optim in
    MLEobj <- MARSSvectorizeparam(MLEobj, x)
    free <- MLEobj$marss$free
    pars <- MLEobj$par
    par.dims <- attr(MLEobj[["marss"]], "model.dims")
    for (elem in c("Q", "R", "V0")) {
      if (!is.fixed(free[[elem]])) # recompute par if needed since par in parlist is transformed
        {
          d <- sub3D(free[[elem]], t = 1) # this will be the one with the upper tri zero-ed out
          par.dim <- par.dims[[elem]][1:2]
          # t=1 since D not allowed to be time-varying; since code 4 lines down won't work otherwise
          L <- unvec(d %*% pars[[elem]], dim = par.dim) # this by def will have 0 row/col at the fixed values
          the.par <- tcrossprod(L) # L%*%t(L)
          # from f+Dm=M and if f!=0, D==0 so can leave off f
          MLEobj$par[[elem]] <- solve(crossprod(d)) %*% t(d) %*% vec(the.par)
          # solve(t(d)%*%d)%*%t(d)%*%vec(the.par)
        }
    } # end for over elem
    # This function is passed a special MLEobj with a marss.original element
    MLEobj$marss$fixed <- MLEobj$fixed.original
    MLEobj$marss$free <- MLEobj$free.original

    # kfsel selects the Kalman filter / smoother function based on MLEobj$fun.kf
    negLL <- MARSSkf(MLEobj, only.logLik = TRUE, return.lag.one = FALSE)$logLik

    -1 * negLL
  }

  if (!inherits(MLEobj, "marssMLE")) {
    stop("Stopped in MARSSoptim(). Object of class marssMLE is required.\n", call. = FALSE)
  }
  for (elem in c("Q", "R")) {
    if (dim(MLEobj$model$free[[elem]])[3] > 1) {
      stop(paste("Stopped in MARSSoptim() because this function does not allow estimated part of ", elem, " to be time-varying.\n", sep = ""), call. = FALSE)
    }
  }
  # the is.marssMODEL call is.validvarcov() which tests that the blocks are diagonal or unconstrained in the varcov matrices

  ## attach would be risky here since user might have one of these variables in their workspace
  MODELobj <- MLEobj[["marss"]]
  y <- MODELobj$data # must have time going across columns
  free <- MODELobj$free
  fixed <- MODELobj$fixed
  tmp.inits <- MLEobj$start
  control <- MLEobj$control
  par.dims <- attr(MODELobj, "model.dims")
  m <- par.dims[["x"]][1]
  n <- par.dims[["y"]][1]

  ## Set up the control list for optim; only pass in optim control elements
  control.names <- c("trace", "fnscale", "parscale", "ndeps", "maxit", "abstol", "reltol", "alpha", "beta", "gamma", "REPORT", "type", "lmm", "factr", "pgtol", "temp", "tmax")
  optim.control <- list()
  for (elem in control.names) {
    if (!is.null(control[[elem]])) optim.control[[elem]] <- control[[elem]]
  }
  if (is.null(control[["lower"]])) {
    lower <- -Inf
  } else {
    lower <- control[["lower"]]
  }
  if (is.null(control[["upper"]])) {
    upper <- Inf
  } else {
    upper <- control$upper
  }
  if (control$trace == -1) optim.control$trace <- 0

  # The code is used to set things up to use MARSSvectorizeparam to just select inits for the estimated parameters
  # Q=t(chol(Q)%*%chol(Q)); t(chol(Q)) has 0 in upper triangle
  tmp.MLEobj <- MLEobj
  # This is needed for the likelihood calculation
  tmp.MLEobj$fixed.original <- tmp.MLEobj$marss$fixed
  tmp.MLEobj$free.original <- tmp.MLEobj$marss$free

  tmp.MLEobj$par <- tmp.inits # set initial conditions for estimated parameters
  for (elem in c("Q", "R", "V0")) { # need the chol for these
    d <- sub3D(free[[elem]], t = 1) # free[[elem]] is required to be time constant
    f <- sub3D(fixed[[elem]], t = 1) # placeholder.  Need structure not actual values
    the.par <- unvec(f + d %*% tmp.inits[[elem]], dim = par.dims[[elem]][1:2])
    is.zero <- diag(the.par) == 0 # where the 0s on diagonal are
    if (any(is.zero)) diag(the.par)[is.zero] <- 1 # so the chol doesn't fail if there are zeros on the diagonal
    the.par <- t(chol(the.par)) # convert to transpose of chol
    if (any(is.zero)) diag(the.par)[is.zero] <- 0 # set back to 0
    if (!is.fixed(free[[elem]])) {
      # from f+Dm=M so m = solve(crossprod(d))%*%t(d)%*%(vec(the.par)-f)
      # but if d!=0,then f==0. if f!-0, then d==0.
      # Thus crossprod(d))%*%t(d) has 0 cols where fs appear in the.par and f is not needed
      tmp.MLEobj$par[[elem]] <- solve(crossprod(d)) %*% t(d) %*% vec(the.par)
    } else {
      tmp.MLEobj$par[[elem]] <- matrix(0, 0, 1)
    }
    # when being passed to optim, pars for var-cov mat is the chol, so need to reset free so we can get the L=t(chol) matrix
    # we don't need to reset fixed because it won't be used;
    # step 1, compute the D matrix corresponding to upper.tri=0 in t(chol)
    # note this only works because it is required that
    # a) if f!=0, d=0. so 1+a never appears in var-cov mat  b) a+b never appears in a var-cov mat, c) for BFGS, var-cov mat is time-invariant
    tmp.list.mat <- fixed.free.to.formula(f, d, par.dims[[elem]][1:2])
    tmp.list.mat[upper.tri(tmp.list.mat)] <- 0 # set upper tri to zero
    tmp.MLEobj$marss$free[[elem]] <- convert.model.mat(tmp.list.mat)$free
  }
  # will return the inits only for the estimated parameters
  pars <- MARSSvectorizeparam(tmp.MLEobj)

  if (substr(tmp.MLEobj$method, 1, 4) == "BFGS") {
    optim.method <- "BFGS"
  } else {
    optim.method <- "something wrong"
  }

  kf.function <- MLEobj$fun.kf # used for printing
  optim.output <- try(optim(pars, neglogLik, MLEobj = tmp.MLEobj, method = optim.method, lower = lower, upper = upper, control = optim.control, hessian = FALSE), silent = TRUE)

  if (inherits(optim.output, "try-error")) { # try MARSSkfss if the user did not use it
    if (MLEobj$fun.kf != "MARSSkfss") { # if user did not request MARSSkf
      cat("MARSSkfas returned error.  Trying MARSSkfss.\n")
      tmp.MLEobj$fun.kf <- "MARSSkfss"
      kf.function <- "MARSSkfss" # used for printing
      optim.output <- try(optim(pars, neglogLik, MLEobj = tmp.MLEobj, method = optim.method, lower = lower, upper = upper, control = optim.control, hessian = FALSE), silent = TRUE)
    }
  }

  # error returned
  if (inherits(optim.output, "try-error")) {
    optim.output <- list(convergence = 53, message = c("MARSSkfas and MARSSkfss tried to compute log likelihood and encountered numerical problems.\n", sep = ""))
  }

  MLEobj.return <- MLEobj
  MLEobj.return$iter.record <- optim.output$message
  #   MLEobj.return$control=MLEobj$control
  #   MLEobj.return$model=MLEobj$model
  MLEobj.return$start <- tmp.inits # set to what was used here
  MLEobj.return$convergence <- optim.output$convergence
  if (optim.output$convergence %in% c(1, 0)) {
    if ((!control$silent || control$silent == 2) && optim.output$convergence == 0) cat(paste("Success! Converged in ", optim.output$counts[1], " iterations.\n", "Function ", kf.function, " used for likelihood calculation.\n", sep = ""))
    if ((!control$silent || control$silent == 2) && optim.output$convergence == 1) cat(paste("Warning! Max iterations of ", control$maxit, " reached before convergence.\n", "Function ", kf.function, " used for likelihood calculation.\n", sep = ""))

    tmp.MLEobj <- MARSSvectorizeparam(tmp.MLEobj, optim.output$par)
    # par has the fixed and estimated values using t chol of Q and R

    # back transform Q, R and V0 if needed from chol form to usual form
    for (elem in c("Q", "R", "V0")) { # this works because by def fixed and free blocks of var-cov mats are independent
      if (!is.fixed(MODELobj$free[[elem]])) # get a new par if needed
        {
          d <- sub3D(tmp.MLEobj$marss$free[[elem]], t = 1) # this will be the one with the upper tri zero-ed out but ok since symmetric
          par.dim <- par.dims[[elem]][1:2]
          L <- unvec(tmp.MLEobj$marss$free[[elem]][, , 1] %*% tmp.MLEobj$par[[elem]], dim = par.dim) # this by def will have 0 row/col at the fixed values
          the.par <- tcrossprod(L) # L%*%t(L)
          tmp.MLEobj$par[[elem]] <- solve(crossprod(d)) %*% t(d) %*% vec(the.par)
        }
    } # end for

    pars <- MARSSvectorizeparam(tmp.MLEobj) # now the pars values have been adjusted back to normal scaling
    # now put the estimated values back into the original MLEobj; fixed and free matrices as in original
    MLEobj.return <- MARSSvectorizeparam(MLEobj.return, pars)
    kf.out <- try(MARSSkf(MLEobj.return), silent = TRUE)

    if (inherits(kf.out, "try-error")) {
      MLEobj.return$numIter <- optim.output$counts[1]
      MLEobj.return$logLik <- -1 * optim.output$value
      MLEobj.return$errors <- c(paste0("\nWARNING: optim() successfully fit the model but ", kf.function, " returned an error with the fitted model. Try MARSSinfo('optimerror54') for insight.", sep = ""), "\nError: ", kf.out[1])
      MLEobj.return$convergence <- 54
      MLEobj.return <- MARSSaic(MLEobj.return)
      kf.out <- NULL
    }
  } else {
    if (optim.output$convergence == 10) optim.output$message <- c("degeneracy of the Nelder-Mead simplex\n", paste("Function ", kf.function, " used for likelihood calculation.\n", sep = ""), optim.output$message)
    optim.output$counts <- NULL
    if (!control$silent) cat("MARSSoptim() stopped with errors. No parameter estimates returned.\n")
    if (control$silent == 2) cat("MARSSoptim() stopped with errors. No parameter estimates returned. See $errors in output for details.\n")

    MLEobj.return$par <- NULL
    MLEobj.return$errors <- optim.output$message
    kf.out <- NULL
  }

  if (!is.null(kf.out)) {
    if (control$trace > 0) MLEobj.return$kf <- kf.out
    MLEobj.return$states <- kf.out$xtT
    MLEobj.return$numIter <- optim.output$counts[1]
    MLEobj.return$logLik <- kf.out$logLik
  }
  MLEobj.return$method <- MLEobj$method

  ## Add AIC and AICc to the object
  if (!is.null(kf.out)) MLEobj.return <- MARSSaic(MLEobj.return)

  return(MLEobj.return)
}


######
# selex
######

library(ALDEx2)
data(selex)
conds <- c(rep("NS", 7), rep("E", 7))
x <- aldex.clr(selex, conds)
x.e <- aldex.effect(x, CI=T)
x.t <- aldex.ttest(x, verbose=T)
x.all.S <- data.frame(x.e,x.t)

sgn <-  sign(x.all.S$effect.low) == sign(x.all.S$effect.high)
eff <- abs(x.all.S$effect) > 2

aldex.plot(x.all.S)
points(x.all.S$diff.win[eff], x.all.S$diff.btw[eff], pch=19, cex=0.5, col="cyan")
points(x.all.S$diff.win[sgn], x.all.S$diff.btw[sgn], col="blue")

mtext("SELEX", 3, line=1,cex=1.5)

######
# BARTON Tscome
######
# depends on effect/code/setup.r

conds <- c(rep("WT", length(WT.g$good)), rep("KO", length(SNF.g$good)))
x <- aldex.clr(d.good, conds)
x.e <- aldex.effect(x, CI=T)
x.t <- aldex.ttest(x, verbose=T)
x.all.Y <- data.frame(x.e,x.t)

sgn <-  sign(x.all.Y$effect.low) == sign(x.all.Y$effect.high)
eff <- abs(x.all.Y$effect) > 2

aldex.plot(x.all.Y)
points(x.all.Y$diff.win[eff], x.all.Y$diff.btw[eff], pch=19, cex=0.5, col="cyan")
points(x.all.Y$diff.win[sgn], x.all.Y$diff.btw[sgn], col="blue")

cols <- grep("rab.win", colnames(x.all.Y))

mtext("Transcriptome", 3, line=1,cex=1.5)

#######
# tiyani 16S
#######
load("data/tiyani_pup_vs_ys.Rdata")

conds <- c(rep("Pup", 161), rep("YS", 212))
x <- aldex.clr(d, conds=conds)
x.e <- aldex.effect(x, CI=T)
x.t <- aldex.ttest(x, verbose=T)
x.all.16 <- data.frame(x.e,x.t)

sgn <-  sign(x.all.16$effect.low) == sign(x.all.16$effect.high)
eff <- abs(x.all.16$effect) > 2

aldex.plot(x.all.16)
points(x.all.16$diff.win[eff], x.all.16$diff.btw[eff], pch=19, cex=0.5, col="cyan")
points(x.all.16$diff.win[sgn], x.all.16$diff.btw[sgn], col="blue")

cols <- grep("rab.win", colnames(x.all.16))

mtext("16S rRNA gene sequencing", 3, line=1,cex=1.5)


#' brms model for estimating variant transmissibility
#'
#' @description Fit an additive mixture of a baseline and variant reproduction
#' number (Rt) to estimated non-parametric Rt values. The variant Rt is
#' described by a multiplication of the baseline Rt. The baseline Rt is
#' described by any covariate combination supported by `brms`.
#'
#' Uncertainty is included in the observed Rt estimates  by assuming that they
#' have student T distribution with standard deviation derived as a combination
#' of a modelled estimate and the observed standard error of the estimates.
#' Uncertainty is also included by modelling variant samples (`positive_prop`) as a
#' latent variable informed by the number of overall samples available and the
#' number of samples which are postive for the variant of interest.
#'
#' @param log_rt Formula describing the covariates  predicting the log of the
#' baseline variants time-varying reproduction number.
#' @param data Data frame that must contain the responses: `rt_mean`,
#' `rt_sd`, `positive_samples`, `samples` and a dummy variable `positive_prop` which
#' is `NA_real`. If wanting to not model uncertainty in the variant proportion
#' fill this variable with the point estimate of the proportion.
#' @param brm_fn Function from `brms` to apply. Common options are
#' `brm()` for model fitting,`get_prior()` to see the priors (not may not
#' be accurate in all cases), and `make_stancode()` to see the generated
#' stan code.
#' @param ... Additional arguments to pass to `brm_fn`.
#' @import brms
variant_rt <- function(log_rt = ~ 1, data, brm_fn = brm, ...) {

  # define Rt variant mixture
  rt_model <-
    bf(rt_mean | se(rt_sd, sigma = TRUE) ~ (1 + var) * exp(logRt),
       nl = TRUE) +
    lf(var ~ 0 + mi(positive_prop)) +
    lf(as.formula(paste0("logRt ", paste(log_rt, collapse = " ")))) +
    student()

  # define samples observation model
  samples_obs_model <- bf(positive_samples | trials(samples) ~ 0 + mi(positive_prop)) +
    binomial(link = "identity")

  # define model for latent variant proportion
  variant_model <- bf(positive_prop | mi() ~ 1, family = "beta")

  # set weak priors
  # set positive proportion to be latent and observed directly with no modifier
  priors <- c(
    prior(student_t(3, 0, 0.5), nlpar = "var", resp = "rtmean"),
    prior(student_t(3, 0, 0.5), nlpar = "logRt", resp = "rtmean"),
    prior(constant(1), class = "phi", resp = "positive_samples"),
    prior(constant(1), class = "Intercept", resp = "positive_samples"),
    prior(constant(1), resp = "positivesamples")
  )

# fit model
brm_out <- do.call(brm_fn, c(
  list(
    mvbf(samples_obs_model, variant_model, rt_model, rescor = FALSE),
    data = data,
    prior = priors),
  ...)
)

return(brm_out)
}


library(ggplot2)
library(data.table)
library(scales)

deviations <- data.table::fread('deviations.csv')
centroids <- data.table::fread('centroid-errors.csv')
errors <- data.table::fread('errors.csv')

png(filename = 'sizes.png', width = 2560, height = 1440)
system.time(print(
  ggplot(data = centroids,
         aes(x     = approx_cdf,
             y     = weight,
             color = dist)) +
  geom_point(alpha = 0.1,
             shape = 3) +
  ggtitle('Centroid Weights') +
  scale_x_continuous(name   = 'Quantile',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n=10)) +
  scale_y_continuous(name   = 'Weight (# of Samples)',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n=10))
))
dev.off()

png(filename = 'mean-uniformity.png', width = 2560, height = 1440)
system.time(print(
  ggplot(data = centroids,
         aes(x     = (left / (left + right) - 0.5),
             color = dist)) +
  geom_freqpoly(binwidth = 0.001,
                center   = 0,
                alpha    = 0.5) +
  ggtitle('Mean Uniformity Between Adjacent Centroids') +
  scale_x_continuous(name   = 'Normalized Distance to Adjacent Centroid',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10)) +
  scale_y_continuous(name   = '# of Centroids',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10))
))
dev.off()

png(filename = 'sample-deviations.png', width = 2560, height = 1440)
system.time(print(
  ggplot(data = deviations,
         aes(x     = deviation,
             color = dist)) +
  geom_freqpoly(binwidth = 0.01,
                center   = 0,
                alpha    = 0.5) +
  geom_vline(xintercept = c(-0.5, 0.5),
             color = 'darkgray') +
  ggtitle('Deviation of Samples Assigned To a Single Centroid (Fig2)') +
  scale_x_continuous(name   = 'Normalized Distance to Adjacent Centroid',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10)) +
  scale_y_continuous(name   = '# of Samples',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10))
))
dev.off()

png(filename = 'error-cdf.png', width = 2560, height = 1440)
system.time(print(
  ggplot(data = errors,
         aes(x     = Q,
             group = interaction(Q, dist),
             y     = (approx_Q - Q) * 1e6,
             color = dist)) +
  geom_boxplot(position      = 'identity',
               fill          = 'white',
               alpha         = 0,
               outlier.shape = 3) +
  ggtitle('Absolute Error of CDF Estimate (Fig3)') +
  scale_x_continuous(name   = 'Quantile',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10)) +
  scale_y_continuous(name   = 'CDF Absolute Error (ppm)',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10))
))
dev.off()

png(filename = 'mean-uniformity-by-quantile.png', width = 2560, height = 1440)
system.time(print(
  ggplot(data = centroids,
         aes(x     = approx_cdf,
             group = interaction(cut_width(approx_cdf, 0.001, boundary = 0), dist),
             y     = (left / (left + right) - 0.5),
             color = dist)) +
  geom_boxplot(position      = 'identity',
               fill          = 'white',
               alpha         = 0,
               outlier.shape = 3) +
  ggtitle('Mean Uniformity Between Adjacent Centroids, by Quantile') +
  scale_x_continuous(name   = 'Quantile',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10)) +
  scale_y_continuous(name   = 'Normalized Distance to Adjacent Centroid',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10))
))
dev.off()

png(filename = 'sample-deviations-by-quantile.png', width = 2560, height = 1440)
system.time(print(
  ggplot(data = deviations,
         aes(x     = Q,
             group = interaction(cut_width(Q, 0.001, boundary = 0), dist),
             y     = deviation,
             color = dist)) +
  geom_boxplot(position      = 'identity',
               fill          = 'white',
               alpha         = 0,
               outlier.shape = 3) +
  geom_hline(yintercept = c(-0.5, 0.5),
             color = 'darkgray') +
  ggtitle('Deviation of Samples Assigned To a Single Centroid (Fig2), by Quantile') +
  scale_x_continuous(name   = 'Quantile',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10)) +
  scale_y_continuous(name   = 'Normalized Distance to Adjacent Centroid',
                     expand = c(0.01, 0),
                     breaks = scales::extended_breaks(n = 10))
))
dev.off()


#Title: Estimate fitting decay curve
#Auther: Naoto Imamachi
#ver: 1.0.0
#Date: 2015-10-08

###Estimate_normalization_factor_function###
BridgeRHalfLifeCalcRaw <- function(filename = "BridgeR_4_Normalized_expression_data.txt",
                                   group,
                                   hour,
                                   InforColumn = 4,
                                   CutoffRelExp = 0.1,
                                   CutoffDataPoint = 3,
                                   OutputFile = "BridgeR_5_HalfLife_calculation.txt"){
    ###Prepare_file_infor###
    time_points <- length(hour)
    group_number <- length(group)
    input_file <- fread(filename, header=T)
    output_file <- OutputFile

    ###print_header###
    cat("",file=output_file)
    hour_label <- NULL
    for(a in 1:group_number){
        if(!is.null(hour_label)){
            cat("\t", file=output_file, append=T)
        }
        hour_label <- NULL
        for(x in hour){
            hour_label <- append(hour_label, paste("T", x, "_", a, sep=""))
        }
        infor_st <- 1 + (a - 1)*(time_points + InforColumn)
        infor_ed <- (InforColumn)*a + (a - 1)*time_points
        infor <- colnames(input_file)[infor_st:infor_ed]
        cat(infor,hour_label, sep="\t", file=output_file, append=T)
        cat("\t", sep="", file=output_file, append=T)
        cat("Model","R2","half_life", sep="\t", file=output_file, append=T)
    }
    cat("\n", sep="", file=output_file, append=T)

    ###calc_RNA_half_lives###
    gene_number <- length(input_file[[1]])
    for(x in 1:gene_number){
        data <- as.vector(as.matrix(input_file[x,]))
        for(a in 1:group_number){
            if(a != 1){
                cat("\t", sep="", file=output_file, append=T)
            }
            infor_st <- 1 + (a - 1)*(time_points + InforColumn)
            infor_ed <- (InforColumn)*a + (a - 1)*time_points
            exp_st <- infor_ed + 1
            exp_ed <- infor_ed + time_points

            gene_infor <- data[infor_st:infor_ed]
            cat(gene_infor, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)
            exp <- as.numeric(data[exp_st:exp_ed])
            cat(exp, sep="\t", file=output_file, append=T)
            cat("\t", file=output_file, append=T)
            time_point_exp <- data.frame(hour,exp)
            time_point_exp <- time_point_exp[time_point_exp$exp >= CutoffRelExp, ]
            data_point <- length(time_point_exp$exp)
            if(!is.null(time_point_exp)){
                if(data_point >= CutoffDataPoint){
                    model <- lm(log(time_point_exp$exp) ~ time_point_exp$hour - 1)
                    model_summary <- summary(model)
                    coef <- -model_summary$coefficients[1]
                    #coef_error <- model_summary$coefficients[2]
                    #coef_p <- model_summary$coefficients[4]
                    r_squared <- model_summary$r.squared
                    #adj_r_squared <- model_summary$adj.r.squared
                    #residual_standard_err <- model_summary$sigma
                    half_life <- log(2)/coef
                    if(coef < 0 || half_life >= 24){
                        half_life <- 24
                    }
                    cat("Raw",r_squared,half_life, sep="\t", file=output_file, append=T)
                }else{
                    cat("Notest","NA","NA", sep="\t", file=output_file, append=T)
                }
            }else{
                cat("Notest","NA","NA", sep="\t", file=output_file, append=T)
            }
        }
        cat("\n", file=output_file, append=T)
    }
}


#Library

library(fastcluster)
source("")

classif <- function(raster, method.dist="euclidean", method.classif="ward.D2", nb.clust){
  df <- raster::as.data.frame(raster, xy=T)
  d <- dist(df,method=method.dist)
  clust <-fastcluster::hclust(d, method = method.classif)
  rez<-FastNbClust(tmp4, diss=dais,distance=NULL,min.nc = 2, max.nc = 10, index="all", method = "ward.D2")
  zones <- cutree(clust.classif ,6)
}
  pixelok <- which(!is.na(apply(raster::as.data.frame(mpa_sst),1,mean)))
  zone <- mpa_sst[[1]]
  values(zone) <- NA
  zone <- zones
  return(clust)
}
classif(mpa_sst)

tmp <- data.frame(raster::as.data.frame(mpa_sst,xy=T)[,c(1:2)],clust=zones)

ggplot(tmp)+
  geom_point(aes(x=x,y=y,col=clust))