library(austin)
library(ca)
data(iebudget2009)

# estimate the CA model
ca.model <- ca(iebudget2009)

# extract speaker column positions and names
results <- data.frame(pos=ca.model$colcoord[,1], names=ca.model$colnames)
results <- results[order(results$pos),]
# one-dimensional plot of speaker positions
dotchart(results$pos, labels=results$names)

# two dimensional plot of words and speakers
plot(ca.model, labels=c(1,2))


#!/usr/bin/env Rscript

#########################################################################
# Dependencies
suppressMessages(library(purrr))
suppressMessages(library(tidyr))
suppressMessages(library(dplyr))
suppressMessages(library(xtable))
suppressMessages(source("src/utils.r"))

options(tibble.width = Inf)

#########################################################################
# Analysis

#########################################################################
# Data ingestion

ingest <- function() {
  est <- read.csv("res2/est.csv")
  stats <- read.csv("res2/stats.csv")
  configs <- read.csv("configs/configs.csv")

  list(est = est, stats = stats, configs = configs)
}

#########################################################################
# Coverage

cvg <-function(res, .sigma0_u=0.7, .sigma0_v=0.7) {
  est <- res$est; stats <- res$stats; configs <- res$configs
  est %>%
    filter(estimator %in% c("Debiased_CLIME", "Debiased_JM")) %>%
    inner_join(dplyr::select(configs, config_id, n, sigma0_u, sigma0_v),
               by = "config_id") %>%
    filter(sigma0_u == .sigma0_u, sigma0_v == .sigma0_v) %>%
    # inner_join(filter(stats, estimator %in% c("Debiased_CLIME", "Debiased_JM")) %>%
    #            dplyr::select(config_id, trial_id),
    #            by = c("config_id", "trial_id", "estimator")) %>%
    mutate(cvgj = covered(estimate_j, beta0_j,
                          SE2/sqrt(n))) %>%
    group_by(estimator, config_id, j) %>%
    summarize(cvgj = mean(cvgj),
              ntrials = n()) %>%
      # sdj = sd(estimate_j),
              # SEj = mean(SE1.la)) %>%
    group_by(estimator, config_id) %>%
    summarize(cvg = mean(cvgj),
              ntrials = mean(ntrials)) %>%
              # SE = mean(SEj),
              # sd = mean(sdj)) %>%
    inner_join(configs, by = "config_id") %>%
    dplyr::select(config_id, n, px, pz, s_beta, s.j, type, cvg, sigma0_u, sigma0_v, ntrials) %>%
    arrange(type)
}

diagnose.Theta <- function(res, .sigma0_u=0.7, .sigma0_v=0.7) {
  est <- res$est; stats <- res$stats; configs <- res$configs
  est %>%
    filter(estimator %in% c("Debiased_CLIME", "Debiased_JM")) %>%
    mutate(
      bias.Theta_jj = Theta.hat_jj-Theta_jj
    ) %>%
    group_by(estimator, config_id) %>%
    summarize(
      # Theta_jj = mean(Theta_jj),
      # Theta.hat_jj = mean(Theta.hat_jj),
      avg_bias.Theta_jj = mean(bias.Theta_jj),
      max_abs_bias.Theta_jj = max(abs(bias.Theta_jj))
    ) %>%
    inner_join(dplyr::select(configs, config_id, n, n, px, pz, s_beta, s.j, type, sigma0_u, sigma0_v),
             by = "config_id") %>%
    filter(sigma0_u == .sigma0_u, sigma0_v == .sigma0_v) %>%
    arrange(estimator, type)
}

diagnose.sd_u <- function(res, .sigma0_u=0.7, .sigma0_v=0.7) {
  est <- res$est; stats <- res$stats; configs <- res$configs
  stats %>%
    filter(estimator %in% c("Debiased_CLIME", "Debiased_JM")) %>%
    group_by(config_id) %>%
    summarize(sd_u.hat = mean(sd_u)) %>%
    inner_join(configs, by = "config_id") %>%
    filter(sigma0_u == .sigma0_u, sigma0_v == .sigma0_v) %>%
    dplyr::select(config_id, n, px, pz, s_beta, s.j, type, sd_u.hat, sigma0_u)
}

mse_beta <- function(res, .sigma0_u=0.7, .sigma0_v=0.7) {
  est <- res$est; stats <- res$stats; configs <- res$configs
  est %>%
    filter(estimator == "Lasso") %>%
    mutate(bias = estimate_j - beta0_j) %>%
    group_by(config_id, trial_id) %>%
    summarize(mse = mean(bias^2)) %>%
    group_by(config_id) %>%
    summarize(avg_mse = mean(mse)) %>%
    inner_join(configs, by = "config_id") %>%
    filter(sigma0_u == .sigma0_u, sigma0_v == .sigma0_v) %>%
    dplyr::select(config_id, n, px, pz, s_beta, s.j, type, avg_mse)
}

diagnose_rems <- function(res) {
  est <- res$est; stats <- res$stats; configs <- res$configs
  est %>%
    filter(estimator %in% c("Debiased_CLIME", "Debiased_JM")) %>%
    inner_join(dplyr::select(configs, config_id, n, sigma0_u),
               by = "config_id") %>%
    mutate(z_j = w/(sqrt(sigma0_u*Theta_jj)),
           cvg_j = ((z_j >= -1.96) & (z_j <= 1.96))) %>%
    group_by(estimator, config_id) %>%
    summarize(cvg = mean(cvg_j),
              avg_rem_1 = mean(abs(rem_1)),
              avg_rem_2 = mean(abs(rem_2)),
              avg_rem_3 = mean(abs(rem_3)),
              avg_rem_4 = mean(abs(rem_4))) %>%
    inner_join(configs, by = "config_id") %>%
    dplyr::select(config_id, n, px, pz, s_beta, s.j, type, cvg, avg_rem_1, avg_rem_2, avg_rem_3, avg_rem_4) %>%
    arrange(estimator, type)
}

res <- ingest()
res %>% cvg %>% print(n=Inf)
res %>% diagnose.Theta %>% print(n=Inf)
res %>% diagnose.sd_u %>% print(n=Inf)
res %>% mse_beta %>% print(n=Inf)
res %>% diagnose_rems %>% print(n=Inf)

res$stats %>%
  filter(estimator %in% c("Debiased_CLIME", "Debiased_JM")) %>%
  inner_join(res$configs, by="config_id") %>%
  filter(sigma0_u==0.7, sigma0_v==0.7) %>%
  group_by(estimator, config_id) %>%
  summarize(avg_mu_star = mean(mu_star)) %>%
  inner_join(res$configs, by="config_id") %>%
  dplyr::select(config_id, n, px, pz, s_beta, s.j, type, avg_mu_star) %>%
  arrange(estimator, type) %>%
  print(n=Inf)

# ingest() %>%
#   summ %>%
#   dplyr::select(config_id, n, px, pz, s_beta, s.j, b, a, cor_hv, type, cvg1.la, SE1.la) %>%
#   print

# tbl <- filter(res$est,
#                estimator == "Debiased") %>%
#   cvg(res$stats, res$configs)
# tblS0 <- filter(res$est,
#                 estimator == "Debiased",
#                 beta0_j != 0) %>%
#   cvg(res$stats, res$configs)
# tblS0C <- filter(res$est,
#                 estimator == "Debiased",
#                 beta0_j == 0) %>%
#   cvg(res$stats, res$configs)


library(fastmap)

x = matrix(1:30, 10)

set.seed(1234)
test = fastmap(x)

set.seed(1234)
truth = fastmap:::.fastmap(x)

stopifnot(all.equal(test$a, truth$a))
stopifnot(all.equal(test$b, truth$b))


library(limma)
library(affy)
library(oligo)

### set directory and folders
setwd("C:/Users/Hunter/Desktop/ohsu/Thesis/data/Mouse")

FigureFolder<-"C:/Users/Hunter/Desktop/ohsu/Thesis/Figures/MouseExpression/"

### declare CEL files and read into R
target1<-c(
"16441x8024_f106_d7.CEL",
"16441x8024_f112_d7.CEL",
"16441x8024_f113_d7.CEL",
"16441x8024_f114_d7.CEL",
"16441x8024_f78_d4m.CEL",
"16441x8024_f79_d4m.CEL",
"16441x8024_f80_d4m.CEL")

target8<-c(
"8048x8026_23_f_Lu_H_IV_D7.CEL",
"8048x8026_28_f_Lu_H_M_D4.CEL",
"8048x8026_37_f_Lu_H_M_D4.CEL",
"8048x8026_38_f_Lu_H_M_D4.CEL",
"8048x8026_59_f_Lu_H_IV_D7.CEL",
"8048x8026_60_f_Lu_H_IV_D7.CEL")

rawData1<-read.celfiles(target1)
rawData8<-read.celfiles(target8)

### rma normalization

normData1<-rma(rawData1)
normData8<-rma(rawData8)

### unnormalized and normalized MA plots

par(mfrow=c(3,3))
MAplot(rawData1, main="")
dev.print(pdf, paste(FigureFolder,"16441x8024_MA_noNormalize.pdf", sep=""))

par(mfrow=c(3,3))
MAplot(rawData8, main="")
dev.print(pdf, paste(FigureFolder,"8048x8026_MA_noNormalize.pdf", sep=""))

par(mfrow=c(3,3))
MAplot(normData1, main="normalized")
dev.print(pdf, paste(FigureFolder,"16441x8024_MA_Normalize.pdf", sep=""))

par(mfrow=c(3,3))
MAplot(normData8, main="normalized")
dev.print(pdf, paste(FigureFolder,"8048x8026_MA_Normalize.pdf", sep=""))

dev.off()

### unnormalized and normalized box plots
color1<-c("blue", "blue", "blue", "blue", "blue", "blue", "blue")
color8<-c("red", "red", "red", "red", "red", "red")

color1[which(grepl("d7", sampleNames(rawData1)))]<-"red"
color8[which(grepl("M_D4", sampleNames(rawData8)))]<-"blue"

boxplot(rawData1, col=color1)
dev.print(pdf, paste(FigureFolder,"16441x8024_boxplot_noNormalize.pdf", sep=""))

boxplot(normData1, col=color1)
dev.print(pdf, paste(FigureFolder,"16441x8024_boxplot_Normalize.pdf", sep=""))

boxplot(rawData8, col=color8)
dev.print(pdf, paste(FigureFolder,"8048x8026_boxplot_noNormalize.pdf", sep=""))

boxplot(normData8, col=color8)
dev.print(pdf, paste(FigureFolder,"8048x8026_boxplot_Normalize.pdf", sep=""))

### create design
Cy5<-as.factor(color1)
levels(Cy5)<-c("control", "infected")
Cy5<-as.character(Cy5)
Cy3<-"ref"
design1<-modelMatrix(cbind(target1,Cy5,Cy3),ref="ref")
cont.matrix1<-makeContrasts(infected-control, levels=design1)

Cy5<-as.factor(color8)
levels(Cy5)<-c("control", "infected")
Cy5<-as.character(Cy5)
Cy3<-"ref"
design8<-modelMatrix(cbind(target8,Cy5,Cy3),ref="ref")
cont.matrix8<-makeContrasts(infected-control, levels=design8)

### Create linear model and bayes
fit<-lmFit(normData1, design1)
fit1<-contrasts.fit(fit, cont.matrix1)
fit1.bayes<-eBayes(fit1)

fit<-lmFit(normData8, design8)
fit8<-contrasts.fit(fit, cont.matrix8)
fit8.bayes<-eBayes(fit8)

#create table of differential expression
#adjusted p-value cutoff of 0.05
#minimum fold change of 1.5
top1<-topTable(fit1.bayes, p.value=0.05, lfc=log2(1.5), number=30000)
results1<-decideTests(fit1.bayes, p.value=0.05, lfc=log2(1.5))

top8<-topTable(fit8.bayes, p.value=0.05, lfc=log2(1.5), number=30000)
results8<-decideTests(fit8.bayes, p.value=0.05, lfc=log2(1.5))

### transcript IDs
trans1 <- rownames(top1)
trans8 <- rownames(top8)
transInt <- intersect(trans1, trans8)

annotTable <- read.csv("MoGene-2_1-st-v1.na35.mm10.transcript.csv", skip=22)

which1 <- which(testTable[,1] %in% trans1)
which8 <- which(testTable[,1] %in% trans8)
whichInt <- which(testTable[,1] %in% transInt)

geneAssign1 <- testTable[which1,8]
geneAssign8 <- testTable[which8,8]
geneAssignInt <- testTable[whichInt,8]

### save results
tableFolder <- "C:/Users/Hunter/Desktop/ohsu/Thesis/tables/MouseExpression/"

write.csv(geneAssign1, file=paste(tableFolder, "16441x8024_DElist.csv", sep=""), row.names=F)
write.csv(geneAssign8, file=paste(tableFolder, "8048x8026_DElist.csv", sep=""), row.names=F)
write.csv(geneAssignInt, file=paste(tableFolder, "intersect_DElist.csv", sep=""), row.names=F)

write.csv(top1, file=paste(tableFolder, "16441x8024_DEValueTable.csv", sep=""))
write.csv(top8, file=paste(tableFolder, "8048x8026_DEValueTable.csv", sep=""))
write.csv(geneAssignInt, file=paste(tableFolder, "intersect_DElist.csv", sep=""), row.names=F)

write.csv(trans1, file=paste(tableFolder, "16441x8024_DElist_TranscriptID.csv", sep=""), row.names=F)
write.csv(trans8, file=paste(tableFolder, "8048x8026_DElist_TranscriptID.csv", sep=""), row.names=F)
write.csv(transInt, file=paste(tableFolder, "intersect_DElist_TranscriptID.csv", sep=""), row.names=F)

library(mogene21sttranscriptcluster.db)

EG1<-mget(trans1, envir=mogene21sttranscriptclusterENSEMBL, ifnotfound=NA)
EG8<-mget(trans8, envir=mogene21sttranscriptclusterENSEMBL, ifnotfound=NA)
EGI<-mget(transInt, envir=mogene21sttranscriptclusterENSEMBL, ifnotfound=NA)

EG1<-EG1[which(!is.na(EG1))]
EG8<-EG8[which(!is.na(EG8))]
EGI<-EGI[which(!is.na(EGI))]


library(plotly)
plot.3d <- function(d=d) {
    plot_ly(x=d$N,
            y=d$r,
            z=d$z,
            type="scatter3d",
            mode="markers",
            name = "Obs",
            marker = list(size = 3)) %>% add_surface()
}

if (FALSE) {
    source("./src/plot.3d.r")
    d <- cal.rate(N.lim=c(36, 60), r.lim=c(0, 0.001))
    plot.3d(d)

}


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
library(xts)
library(Quandl)
library(quantmod)

# Get constant-maturity (US) Treasuries
ust.tickers <- c("FRED/DGS3MO", "FRED/DGS2", "FRED/DGS10", "FRED/DGS30")
ust.raw <- Quandl(ust.tickers, type="xts")
ust.colnames <- c("UST3M", "UST2Y", "UST10Y", "UST30Y")
colnames(ust.raw) <- ust.colnames

corpbond.raw <- Quandl("FED/RIMLPBAAR_N_B", type="xts")
colnames(corpbond.raw) <- c("USBaaCorp")

re.tickers <- c("CHRIS/CME_JR1", "NLY", "EQR", "CAR-UN.TO")
re.raw <- Quandl(re.tickers[1], type="xts")[,"Settle"]
# Sadly, there is a data error: a few days reported 10x price
re.raw[re.raw>1000] <- re.raw[re.raw>2000]/10
for (j in 2:length(re.tickers)) {
    tmp <- getSymbols(re.tickers[j], src="yahoo", env=NULL)
    adj.col <- last(colnames(tmp))
    re.raw <- cbind(re.raw, tmp[,adj.col])
}
colnames(re.raw) <- c("DJUSRE", "NLY", "EqRes", "CdnApt")

commodities.tickers <- c("CHRIS/CME_GI1", "CHRIS/CME_C1", "CHRIS/CME_S1", "CHRIS/CME_HG1",
                         "CHRIS/SHFE_RB1", "CHRIS/CME_CL1", "CHRIS/CME_NG1")
commodities.raw <- Quandl(commodities.tickers[1], type="xts")[,"Settle"]
for (j in 2:length(commodities.tickers)) {
    tmp <- Quandl(commodities.tickers[j], type="xts")[,"Settle"]
    commodities.raw <- cbind(commodities.raw, tmp)
}
colnames(commodities.raw) <- c("GSCI", "Corn", "Soybeans", "Copper", "Rebar",
                               "WTI", "USNatgas")

eqtidx.tickers <- c("^GSPC", "^RUT", "^GSPTSE", "^MXX", "^FTSE", "^STOXX50E",
                    "^SSMI", "^HSI", "^STI", "^N225")
tmp <- getSymbols(eqtidx.tickers[1], src="yahoo", env=NULL)
adj.col <- last(colnames(tmp))
eqtidx.raw <- tmp[,adj.col]
for (j in 2:length(eqtidx.tickers)) {
    tmp <- getSymbols(eqtidx.tickers[j], src="yahoo", env=NULL)
    adj.col <- last(colnames(tmp))
    eqtidx.raw <- cbind(eqtidx.raw, tmp[,adj.col])
}
colnames(eqtidx.raw) <- c("SP500", "R2000", "TSX", "IPC", "FTSE100", "ESTX50",
                          "SMI", "HangSeng", "STI", "NK225")

fx.tickers <- c("CHRIS/CME_JY1", "CHRIS/CME_EC1", "CHRIS/CME_CD1", "CHRIS/ICE_AR1")
fx.raw <- Quandl(fx.tickers[1], type="xts")[,"Settle"]
for (j in 2:length(fx.tickers)) {
    tmp <- Quandl(fx.tickers[j], type="xts")[,"Settle"]
    fx.raw <- cbind(fx.raw, tmp)
}
colnames(fx.raw) <- c("USDJPY", "USDEUR", "USDCAD", "AUDNZD")

alldata.full <- cbind(ust.raw, corpbond.raw, re.raw, commodities.raw,
                      eqtidx.raw, fx.raw)
alldata <- alldata.full["20140101/20180515"]

summary(alldata)

for (v in colnames(alldata)) {
    plot.tmp <- plot(alldata[,v], main=v)
    print(plot.tmp)
    invisible(readline(prompt="Press [enter] to continue"))
}


bogosort <- function(x) {
   while(is.unsorted(x)) x <- sample(x)
   x
}

n <- c(1, 10, 9, 7, 3, 0)
bogosort(n)


# Analysis of differences between one barometer and many others in its neighbourhood.

locations <- read.csv('./../../data/meta/inbo/Baro_Position_Lambert72.csv',
                      dec = ',', sep = ';', na.strings = 'NULL', stringsAsFactors = FALSE)
data.table::setDT(locations)
data.table::setkey(locations, ppnt_cde)

d <- function(xy1, xy2) sqrt(sum((xy1 - xy2)^2))
d.vec <- function(xy.from, xy.to.df) {
  stopifnot(length(xy.from) == 2L)
  stopifnot(!is.null(nrow(xy.to.df)))

  apply(xy.to.df, 1, d, xy1 = xy.from)
}

read.full <- function(location) {
  loggers <- grep(paste0('barometer/', location), gwloggeR.data::enumerate(), value = TRUE)
  df <- data.table::rbindlist(lapply(loggers, function(logger) gwloggeR.data::read(logger)$df), use.names = TRUE)
  if (nrow(df) == 0L) return(df)
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  data.table::setkey(df, TIMESTAMP_UTC)
  structure(df, 'location' = location, 'loggers' = basename(loggers))
}

compare <- function(df1, df2, distance = NA) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(data.table::data.table())
  df1.name <- attr(df1, 'location')
  df2.name <- attr(df2, 'location')

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE, TIMESTAMP_UTC)][!is.na(PRESSURE_DIFF), ]
  if (nrow(diff.df) < 250L) return(data.table::data.table())

  ap <- gwloggeR::apriori('air pressure')
  df1.operc <- sum(gwloggeR::detect_outliers(df1[J(diff.df), PRESSURE_VALUE], apriori = ap))/nrow(diff.df)
  df2.operc <- sum(gwloggeR::detect_outliers(df2[J(diff.df), PRESSURE_VALUE], apriori = ap))/nrow(diff.df)
  if (df1.operc > 0.1 || df2.operc > 0.1) return(data.table::data.table())

  diff.df
}

compute <- function(logger.loc, nr_surrounding_barros = length(distances)) {
  logger.xy <- unlist(locations[J(logger.loc), .(Lambert72_X, Lambert72_Y)])
  logger.df <- read.full(logger.loc)

  distances <- d.vec(logger.xy, locations[, .(Lambert72_X, Lambert72_Y)])/1000
  names(distances) <- locations$ppnt_cde
  distances <- sort(distances, na.last = TRUE)[-1L]

  df.diff <- lapply(names(distances[1L:nr_surrounding_barros]), function(other.loc) {
    other.df <- read.full(other.loc)
    compare(logger.df, other.df, distances[other.loc])
  })
  df.diff <- data.table::rbindlist(df.diff, use.names = TRUE, fill = TRUE)

  if (nrow(df.diff) == 0L) return()

  df.quant <- df.diff[
    , .(Q.025 = quantile(PRESSURE_DIFF, 0.025),
        Q.5 = quantile(PRESSURE_DIFF, 0.5),
        Q.975 = quantile(PRESSURE_DIFF, 0.975)),
    by = TIMESTAMP_UTC]

  plt <- ggplot2::ggplot(data = df.diff, mapping = ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_DIFF)) +
    ggplot2::geom_point(pch = '.') +
    ggplot2::geom_line(data = df.quant, mapping = ggplot2::aes(y = Q.5), col = 'red', alpha = 0.5) +
    ggplot2::stat_smooth(method = 'gam', formula = y ~ s(x, k = 40), color = 'yellow', se = FALSE) +
    ggplot2::coord_cartesian(ylim = quantile(df.diff$PRESSURE_DIFF, probs = c(0.025, 0.975))) +
    ggplot2::scale_x_datetime(date_breaks = '1 year', date_labels = '%Y') +
    ggplot2::ggtitle(sprintf('%s (%s) #%s', logger.loc, paste0(attr(logger.df, 'loggers'), collapse = ', '), nrow(df.diff))) +
    ggplot2::theme_light()

  filename <- sprintf('./drifts/analysis_02/%s.png', logger.loc)

  local({
    png(filename, width = 1280, height = 720)
    on.exit(dev.off())
    print(plt)
  })

}

# A, B, dist, sd
# tmp <- compute(locations$ppnt_cde[15L])
# tmp <- lapply(locations$ppnt_cde, compute)

parallel::setDefaultCluster(parallel::makeCluster(spec = 7L))
parallel::clusterExport(varlist = c('d', 'd.vec', 'compare', 'read.full', 'locations'))
results <- parallel::clusterApplyLB(x = locations$ppnt_cde, fun = compute)
parallel::stopCluster(cl = parallel::getDefaultCluster())


decay_instant <- function(t, hl, C_max){
     C_max * 2^(-t/hl)
 }

decay_instant_integral <- function(t, hl, C_max){
    -hl * C_max * 2^(-t/hl)/log(2)
 }

return_druginf <- function(){

    druginf <- list()

    druginf[['3TC']] <-
        c(IC_50 = 0.0298, slope = 1.15, c_max = 15.3, hl = 10, dosing = 2)
    druginf[['AZT']] <-
        c(IC_50 = 0.1823, slope = 0.85, c_max = 4.5, hl = 8.5, dosing = 2)
    druginf[['D4T']] <-
        c(IC_50 = 0.5524, slope = 1.13, c_max = 2.3, hl = 3.5, dosing = 2)
    druginf[['EFV']] <-
        c(IC_50 = 0.0035, slope = 1.69, c_max = 12.9, hl = 35.8, dosing = 1)
    druginf[['NFV']] <-
        c(IC_50 = 0.2360, slope = 1.88, c_max = 5.1, hl = 4.0, dosing = 3)
    druginf[['LPV']] <-
        c(IC_50 = 0.0380, slope = 2.1, c_max = 15.6, hl = 9.9, dosing = 2)
    druginf[['NVP']] <-
        c(IC_50 = 0.0490, slope = 1.49, c_max = 25.2, hl = 21.5, dosing = 1)

    return(druginf)
}

return_mutinf <- function(){
    mutinf <- list()

    #For 3TC, mutation options are:
    #K65R, M184V
    mutinf[['3TC']] <-
        c(
            #s is taken from K65R
            s = 0.41,
            #mu is equivalent
            mu =  1.1 * (10^-5),
            #rho and sigma are from M184V
            rho =  963,
            sigma = -0.58)

    #For AZT, mutation options are:
    #M184V, M41L, T215Y* (excluded, because multi-nuc)
    mutinf[['AZT']] <-
        c(
            #s is taken from M41L
            s = 0.17,
            #mu is taken from M184V
            mu = 1.1 * 10^(-5),
            #rho and sigma are taken from M41L
            rho = 2.2,
            sigma = 0.07)

    #For D4T, mutation options are:
    #M41L, T215Y* (excluded, because multi-nuc)
    #all parameters taken from M41L
    mutinf[['D4T']] <-
        c(s = 0.17,
          mu = 1.3 * 10^(-6),
#          rho = 1.0,
#          sigma = 0.07)
          rho = 1.08,
          sigma = -0.12)

    #For EFV, mutation options are:
    #G190S, K103N, Y181C
    mutinf[['EFV']] <-
        #s is taken from Y181C
        c(s = 0.26,
          #mu is taken from G190S
          mu = 2.2 * 10^(-5),
          #rho is taken from K103N
          rho = 85,
          sigma = -0.17)

    #For NFV, mutation options are
    #D30N, L90M,
    mutinf[['NFV']] <-
        #s is taken from D30N
        c(s = 0.27,
          #mut is taken from D30N
          mu = 5.5 * 10^(-5),
          #rho and sigma are taken from D30N
          rho = 2.3,
          sigma = -0.29)

    #For LPV/r, mutation options are
    #I47A*, I47V, V32I, V82A, V82F,
    mutinf[['LPV']] <-
        #s is taken from I47V
        c(s = 0.05,
          #mut is taken from V32I
          mu = 4.1 * 10^(-5),
          #rho and sigma are taken from I47V
          rho = 1.8,
          sigma = -0.29)

    #For NVP, mutation options are
    #G190S, K103N, Y181C, #Y181I
    mutinf[['NVP']] <-
        #s is taken from K103N
        c(s = 0.3,
          #mut is taken from G190S
          mu = 2.2 * 10^(-5),
          #rho and sigma are taken from K103N
          rho = 94,
          sigma = -0.15)

    return(mutinf)

}


rm(list=ls())
stem = "C:/Users/clecarpenti/Documents/sauvegarde_rapeseed_partielle/Modelisation/Troisieme-run-FSPM2020/"

path = paste0(stem,"2-SensitivityAnalysis/")
out_path = paste0(stem, "simulation_output/")

library(multisensi)
library(wesanderson)

wes_palette("Royal1")

# LOADING SIMULATION OUTPUTS

Set = "ThdAS-Fst-One-005"
AS = read.table(paste0(out_path, "Out-", Set, ".csv"), sep=";", header=TRUE, dec=".")
AS$EL = AS$ELONG
AS$IBD = AS$DIR
AS$DelBEl = AS$DURDEVPRIM

summary(AS)

{
  ## Calculate main sensitivity indices and total sensitivity indices
  # DEFINE OUTPUT AND INPUT PARAMETERS

  Ys = c("BIOMASS","ROOTPROPORTION", "EXPLOREDSOILVOLUME","COLONIZATIONEFFICIENCY")
  Xs = c("DelBEl","DMIN","DMAX","EL","IBD","DLDM","VARD","RTD")

  as_01 = dynsi(formula = 2, model = as.data.frame(AS[,Ys]), factors = AS[,Xs])

  ## Calculate Residuals

  Res_01 = (1-colSums(as_01$SI))[1:length(Ys)]

}

#################### FIGURE 3 ###
#################################

png(paste0(path,"ArchiSimple-Sensitivity-Analysis-Thd-n7.png"), width = 8, height = 7, unit = "in", res=600)
{

  par(mfrow=c(2,2), mar=c(4,4,4,0.5))
  ymax = 0.7#max(c(as_svn_15$mSI[,Ys], as_svn_15$iSI[,Ys]))
  ymin = 0

  ### all plants

  # vector_color = rep(c("forestgreen","yellowgreen"), times = length(Xs))
  vector_color = c(wes_palette("Royal1")[2],wes_palette("Royal1")[1] )

  ## Biomass
  barplot(t(as.matrix(data.frame(MSI = as_01$mSI[,"BIOMASS"], ISI = as_01$iSI[,"BIOMASS"]))), beside=TRUE, las=3, ylim=c(ymin,ymax), main = "Root System Biomass", col = vector_color,ylab = "Indice Value")
  legend("topright", legend = c("MSI","ISI"), fill = vector_color, bty="n")

  ## Biomass
  barplot(t(as.matrix(data.frame(MSI = as_01$mSI[,"ROOTPROPORTION"], ISI = as_01$iSI[,"ROOTPROPORTION"]))), beside=TRUE, las=3, ylim=c(ymin,ymax), main = "Proportion of thin roots", col = vector_color,ylab = "Indice Value")
  legend("topright", legend = c("MSI","ISI"), fill = vector_color, bty="n")

  ##Exploration of space
  barplot(t(as.matrix(data.frame(MSI = as_01$mSI[,"EXPLOREDSOILVOLUME"], ISI = as_01$iSI[,"EXPLOREDSOILVOLUME"]))), beside=TRUE, las=3, ylim=c(ymin,ymax), main = "Soil Exploration (pyramid)", col = vector_color,ylab = "Indice Value")
  legend("topright", legend = c("MSI","ISI"), fill = vector_color, bty="n")

  ##Colonization efficiency
  barplot(t(as.matrix(data.frame(MSI = as_01$mSI[,"COLONIZATIONEFFICIENCY"], ISI = as_01$iSI[,"COLONIZATIONEFFICIENCY"]))), beside=TRUE, las=3, ylim=c(ymin,ymax), main = "Colonization efficiency", col = vector_color,ylab = "Indice Value")
  legend("topright", legend = c("MSI","ISI"), fill = vector_color, bty="n")

}
dev.off()


segZcep <- function(wav, seg, nc=12, 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, nc)
  sr <- as.double(wav$wav@samp.rate)
  nfr <- 0
  for (tx in seq(t1, t2, step)) {
    s <- s + zcep(sr, getFrame(wav, tx, absolute=F, winlen=32), nc)
    nfr <- nfr + 1
  }
  s <- s/nfr
  s
}


library(rstudioapi)
library(tidyverse)
library(patchwork)
library(dplyr)
library(emdbook)
library(drjacoby)

setwd(dirname(getActiveDocumentContext()$path))
data <- "Imperial"
#data <- "PHE"

##################################
##### LOAD THE PARAMETERS
##################################

if(data=="Imperial") {
  load("../Model Fits/imp_v2_20211219_AZPD2=FALSE_SB=TRUE_NewDecay=TRUE_mcmc_chain.Rdata")

}

if(data=="PHE") {
  load("../Model Fits/phe_20211219_AZPD2=FALSE_SB=TRUE_NewDecay=TRUE_mcmc_chain.Rdata")
}

draws <- sample_chains(mcmc, 5000)

draws_transform <- draws %>%
  select(-sample, -AZ_ns_off ) %>%
  mutate(d2_AZ_log10 = log10(32/59) - fold_red_AZ,
         d2_PF_log10 = log10(223/94) - fold_red_PF,
         d2_PF = 10^(d2_PF_log10),
         d2_AZ = 10^(d2_AZ_log10),
         d1_AZ = 10^(d2_AZ_log10 + d1_AZ),
         d1_PF = 10^(d2_PF_log10 + d1_PF),
         d3 = 10^(d2_PF_log10 + bst_PF),
         ab50 = 10^(d2_PF_log10 + ni50),
         ab50_s = 10^(d2_PF_log10 + ns50),
         ab50_d = 10^(d2_PF_log10 + nd50),
         om_red = 10^(om_red),
         fold_red_PF = 10^(fold_red_PF),
         fold_red_AZ = 10^(fold_red_AZ)) %>%
  select(-ni50, -ns50, -nd50, -d2_AZ_log10, -d2_PF_log10, -bst_AZ, -bst_PF)

posterior_median_transform <-draws_transform %>%
  summarise(
    across(where(is.numeric), median)
  )%>%
  mutate(measure = "median")

n<-lseq(0.01,100,length.out=100)

#len<-length(mcmc$output$k)
#sam<-mcmc$parameters$samples

#ni50v        <- 10^mcmc$output$ni50[seq(len-sam,len,100)]
#ns50v        <- 10^mcmc$output$ns50[seq(len-sam,len,100)]
#kv           <- mcmc$output$k[seq(len-sam,len,100)]

ni50v        <- draws_transform$ab50
ns50v        <- draws_transform$ab50_s
nd50v        <- draws_transform$ab50_d
kv           <- draws_transform$k

ru <-NULL

for (i in (1:length(kv))){

  ni50         <- ni50v[i] # titre relative to convalescent required to provide 50% protection from infection, on linear scale
  ns50         <- ns50v[i]
  nd50         <- nd50v[i]
  k            <- kv[i] # shape parameter of efficacy curve

  ef_infection <- 1 / (1 + exp(-k * (log10(n) - log10(ni50))))
  ef_severe    <- 1 / (1 + exp(-k * (log10(n) - log10(ns50))))
  ef_death    <- 1 / (1 + exp(-k * (log10(n) - log10(nd50))))

  r <- data.frame(n=n, run=rep(i,length(n)), ef_infection=ef_infection, ef_severe=ef_severe, ef_death=ef_death)
  ru<-rbind(ru,r)

}

ru <- ru %>%
  pivot_longer(cols = c("ef_infection", "ef_severe", "ef_death"), names_to = "type") %>%
  mutate(type = factor(type, levels = c("ef_infection", "ef_severe", "ef_death")))

ru_summary <- ru %>%
  group_by(type, n) %>%
  summarise(median = median(value),
            upper = quantile(value, 0.975),
            lower = quantile(value, 0.025),)

ni50      <- posterior_median_transform$ab50
ns50      <- posterior_median_transform$ab50_s
nd50      <- posterior_median_transform$ab50_d
k         <- posterior_median_transform$k

ef_infection <- 1 / (1 + exp(-k * (log10(n) - log10(ni50))))
ef_severe <- 1 / (1 + exp(-k * (log10(n) - log10(ns50))))
r1 <- data.frame(n,ef_infection,ef_severe, ef_death)

g1 <- ggplot(data = r1) +
  geom_ribbon(data = filter(ru_summary, type == "ef_infection"), aes(x = n, ymin = 100*lower, ymax = 100*upper), alpha = 0.2, fill = "darkblue") +
  geom_line(data = r1, aes(x = n, y = 100*ef_infection), size = 1,col = "darkblue") +
  labs(x = "NAT (fold of convalescent)", y = "vaccine efficacy mild (%)") +
  scale_x_log10(limits = c(0.01,100),breaks = c(0.01,0.1,1,10,100)) +
  scale_y_continuous(limits = c(0,100)) +
  theme_bw() +
  theme(strip.background = element_rect(fill = NA, color = "white"),
        panel.border = element_blank(),
        axis.line = element_line(),
        axis.text.x=element_text(angle=60, hjust = 1))

g2 <- ggplot(data = r1) +
  geom_ribbon(data = filter(ru_summary, type == "ef_severe"), aes(x = n, ymin = 100*lower, ymax = 100*upper), alpha = 0.2, fill = "darkgray") +
  geom_line(data = r1, aes(x = n, y = 100*ef_severe), size = 1,col = "black") +
  labs(x = "NAT  (fold of convalescent)", y = "vaccine efficacy severe (%)") +
  scale_x_log10(limits = c(0.01,100),breaks = c(0.01,0.1,1,10,100)) +
  scale_y_continuous(limits = c(0,100)) +
  theme_bw() +
  theme(strip.background = element_rect(fill = NA, color = "white"),
        panel.border = element_blank(),
        axis.line = element_line(),
        axis.text.x=element_text(angle=60, hjust = 1))

g3 <- ggplot(data = r1) +
  geom_ribbon(data = filter(ru_summary, type == "ef_death"), aes(x = n, ymin = 100*lower, ymax = 100*upper), alpha = 0.2, fill = "darkred") +
  geom_line(data = r1, aes(x = n, y = 100*ef_death), size = 1,col = "darkred") +
  labs(x = "NAT  (fold of convalescent)", y = "vaccine efficacy death (%)") +
  scale_x_log10(limits = c(0.01,100),breaks = c(0.01,0.1,1,10,100)) +
  scale_y_continuous(limits = c(0,100)) +
  theme_bw() +
  theme(strip.background = element_rect(fill = NA, color = "white"),
        panel.border = element_blank(),
        axis.line = element_line(),
        axis.text.x=element_text(angle=60, hjust = 1))

combined <- g1 + g2  + g3 + plot_annotation(tag_levels = "A")
combined
if(data=="Imperial") {
  ggsave("../Figures/FigureS1.png",combined, height = 5, width = 15)
}
if(data=="PHE") {
  ggsave("../Figures/FigureS1_phe.png",combined, height = 5, width = 15)
}

0_antibody_model_fitting/Plotting and Table Code/Figure S1 plotting code.r


plot.pca.image <- function(pcascores,classes=12){

# takes pca scores from a pca on the data
# matrix in bartlett20xx as input:
# pcadata = princomp(datamatrix)
# pcascores = pcadata$scores
# needs more tweaking for descent plotting

source('~/Dropbox/phenocam_classification/code/image.plot.R')

print('printing the pca images for')
print(classes)
print('classes')

#par(ask=T)
par(mfrow=c(3,1))
par(mar=c(0,2,2,2))
for (i in 1:3){

c <- matrix(pcascores[,i],480,640)
#myImagePlot(c)

image(t(c[ nrow(c):1, ]),col=rainbow(classes),main=paste('PCA ',i,sep=''),xaxt='n',yaxt='n')

}

}
plot.pca.image(res,12)


#################################################################################
# Monte Carlo method to calculate Multi-Species Indices (MSI) 3.0
# CBS (Statistics Netherlands), june 2017
# 	- generate MSIs with confidence interval, accounting for sampling error
#   - baseyear for simulated MSIs is flexible
#   - baseyear for plots can be set to 100 for index or for smoothed trend value
#	  - linear trend classification
#   - smoothed trend classification
#   - compare linear trends before and after changepoint
#   - assess overall change and change in last years
#   - truncation of low indices (and their SE set to 0)
#################################################################################
# LOAD PACKAGES
library(ggplot2)

# DATA IMPORT AND SPECIFICATIONS
setwd("E:/Ontwikkel/Lslt/Graadmeter/BASISTOOLS") # set working directory for input and output files
rdata <- read.table("Padhout.txt", header=TRUE) # name of input file
jobname <- as.character ("Padhout") # generic name for output fileS
nsim <- 1000		    # number of Monte Carlo simulations
SEbaseyear <- 2013 # year to set SE to 0. SE of other years is relative to the SE of SEbaseyear
plotbaseyear <- 1965 # year to set MSI or smoothed trend (dependend on 'index_smooth') to 100 in final MSI-plot
index_smooth <- "SMOOTH" # INDEX / SMOOTH: "INDEX" will cause the MSI in plotbaseyear set to 100; "SMOOTH" will set the smoothed trend value in the plotbaseyear to 100
lastyears <- 10		# last X years of time series for which separate trend (short-term trends) should be calculated
maxCV <- 3       # maximum allowed mean Coefficient of Variation (CV) of species indices (0.5 = 50%). Species with higher mean CV are excluded
changepoint <- 1994 # compare trends before and after this year
truncfac <- 10    # truncation factor (=maximum allowed year-to-year index ratio). Default for Living Planet Index = 10
TRUNC <- 1 # set all indices below TRUNC to this value and their SE to 0. TRUNC <- 0 means no truncation
# testyear <- 1994 # additional year smoothed trend values should be compared with
# END OF SPECIFICATIONS

# Define and calculate model parameters
species <- rdata[,"species"]
year <- rdata[,"year"]
index <- rdata[,"index"]
se <- rdata[,"se"]
uspecies <- sort(unique(species))
nspecies <- length(uspecies)
uyear <- sort(unique(year))
nyear <- length(unique(year))
meanindex <- tapply(index, species, mean, na.rm=TRUE)/100
mnindex1 <- as.data.frame(rep(meanindex,each=nyear))
minyear <- min(year)
maxyear <- max(year)
plotbaseyear <- plotbaseyear-minyear+1
baseyear <- max(1,SEbaseyear-minyear+1)
lastyears <- min(lastyears,nyear)
# testyear <- nyear-(maxyear-testyear)
INP <- data.frame(cbind(species, year, index, se))
SPEC <- as.matrix(species)
species <- sort(rep(uspecies,each=nyear))
year <- rep(uyear,nspecies)
INP1 <- data.frame(cbind(species,year))
INP2 <- merge(INP, INP1, by=c("species","year"), sort=TRUE, all=TRUE)

# Calculate and plot mean CV for indices per species
CVtemp <- INP2[INP2$index >= 10, ] # select records with index >= 10 for CV calculation
CVtemp <- CVtemp[!is.na(CVtemp$index), ] # reject missing values
CV1 <- CVtemp$se/CVtemp$index
CV1[CV1== 0] <- NA
CV1[CV1== Inf] <- NA
species2 <- CVtemp$species
mnCV <- tapply(CV1, species2, mean, na.rm=TRUE)
plot(uspecies, mnCV, type="p", pch=19, col="black", main=jobname, xlab="species code", ylab="meanCV")
CV <- as.data.frame(rep(mnCV, each=nyear))

# replace small indices by TRUNC and their SE by zero
INP3 <- data.frame(cbind(species, year, CV, mnindex1))
colnames(INP3) <- c("species","year", "CV", "mnindex1")
INP4 <- merge(INP2, INP3, by=c("species","year"), sort=FALSE, all=TRUE)
INP5 <- subset(INP4, CV < maxCV, select = c(species, year, index, se, mnindex1))
INP5$index[INP5$index < TRUNC & !is.na(INP5$index)] <- TRUNC
INP5$se[INP5$index == TRUNC & !is.na(INP5$index)] <- 0

# reset parameters
index <- as.vector(INP5["index"])
se <- as.vector(INP5["se"])
nobs <- NROW(INP5)
uspecies <- sort(unique(INP5$species))
nspecies <- length(uspecies)
year <- rep(uyear, nspecies)

# Transform indices and standard deviations to log scale (Delta method)
LNindex <- as.vector(log(index))
LNse <- as.vector(se/index)

# Monte Carlo simulations of species indices
MC <- matrix(NA, nobs, nsim)
for (s in 1:nsim) {
       MC[,s] <- rnorm(nobs, LNindex[,1], LNse[,1])
 }
MC[MC < log(TRUNC)] <- log(TRUNC)

# impute missing values using chain method
CHAIN <- matrix(NA, nobs, nsim)
for (s in 1:nsim ){
  for (o in 1:nobs-1) {
    CHAIN[o,s] <- MC[o+1,s]-MC[o,s]
  }
  for (sp in 1:nspecies) {
    CHAIN[sp*nyear,s] <- NA
  }
}

CHAIN[CHAIN > log(truncfac)] <- log(truncfac)
CHAIN[CHAIN < log(1/truncfac)] <- log(1/truncfac)

mnCHAIN <- matrix(NA, nyear, nsim)
for (s in 1:nsim) {
  mnCHAIN[,s] <- tapply(CHAIN[,s], year, mean, na.rm=TRUE)
}

simMSI <- matrix(NA, nyear, nsim)
bmin <- baseyear-1
bplus <- baseyear+1
for (s in 1:nsim){
simMSI[baseyear,s] <- log(100)
  for (y in bmin:min(bmin,1)){
    simMSI[y,s] <- simMSI[y+1,s] - mnCHAIN[y,s]
  }
  for (y in min(bplus,nyear):nyear){
    simMSI[y,s] <- simMSI[y-1,s] + mnCHAIN[y-1,s]
  }
}

# calculate MSI and SE
meanMSI <- array(NA, dim=c(1, nyear))
stdevMSI <- array(NA, dim=c(1, nyear))
for (y in 1:nyear) {
  meanMSI[y] <- mean(simMSI[y,])
  stdevMSI[y] <- sd(simMSI[y,])
}

# Monte Carlo simulations of MSI (for trend calculation)
simMSI <- matrix(NA, nyear, nsim)
for (s in 1:nsim) {
  for (y in 1:nyear) {
    simMSI[y,s] <- rnorm(1, meanMSI[y], stdevMSI[y])
  }
}

# Back-transformation of MSI to index scale (Delta method)
meanMSI <- array(NA, dim=c(1, nyear))
stdevMSI <- array(NA, dim=c(1, nyear))
for (y in 1:nyear) {
  meanMSI[y] <- round(exp(mean(simMSI[y,])), digits=2)
  stdevMSI[y] <- round(sd(simMSI[y,])*meanMSI[y], digits=2)
}

# Confidence interval of MSI on index-scale
CI <- array(NA, dim=c(nyear, 2))
for (y in 1:nyear){
  CI[y,1] <- exp(mean(simMSI[y,])-1.96*sd(simMSI[y,]))
  CI[y,2] <- exp(mean(simMSI[y,])+1.96*sd(simMSI[y,]))
}

# Overall linear trend per simulation
lrMSI <- array(NA, dim=c(2, nsim))
for (s in 1:nsim) {
  summ <- summary(lm(simMSI[,s] ~ uyear, na.action=na.exclude))
  lrMSI[1,s] <- round(summ$coefficients[2], digits=4)	# coeff[2] = slope
  lrMSI[2,s] <- round(summ$coefficients[2,2], digits=4) 	# coeff[2,2] = se of slope
}
SLOPE <- mean(lrMSI[1,])
sdSLOPE <- sd(as.vector(lrMSI[1,]))

# Back transform trends to index scale:
SLOPE_mult <- round(exp(SLOPE), digits=4)
sdSLOPE_mult <- round(sdSLOPE*SLOPE_mult, digits=4)

# Overall trend classification (see Soldaat et al. 2007 (J. Ornithol. DOI 10.1007/s10336-007-0176-7))
TrendClass <- "X"
if (SLOPE_mult - 1.96*sdSLOPE_mult > 1.05) {TrendClass <- "strong increase" } else
  if (SLOPE_mult + 1.96*sdSLOPE_mult < 0.95) { TrendClass <- "steep decline" } else
    if (SLOPE_mult - 1.96*sdSLOPE_mult > 1.00) { TrendClass <- "moderate increase"} else
      if (SLOPE_mult + 1.96*sdSLOPE_mult < 1.00) { TrendClass <- "moderate decline" } else
        if ((SLOPE_mult - 1.96*sdSLOPE_mult - 0.95)*(1.05 - SLOPE_mult + 1.96*sdSLOPE_mult) < 0.00) { TrendClass <- "uncertain"} else
          if ((SLOPE_mult + 1.96*sdSLOPE_mult) - (SLOPE_mult - 1.96*sdSLOPE_mult) > 0.10) { TrendClass <- "uncertain" } else
          {TrendClass <- "stable"}
TrendClass

# Short term linear trend per simulation
lrMSI_short <- array(NA, dim=c(2, nsim))
lyear <- c((maxyear-lastyears+1):maxyear)
simMSI_short <- array(NA, dim=c(lastyears, nsim))
for (s in 1:nsim) {
  for (y in 1:lastyears) {
    simMSI_short[y, s] <- simMSI[(nyear-lastyears+y),s]
  }
}
for (s in 1:nsim) {
  summ <- summary(lm(simMSI_short[,s] ~ lyear, na.action=na.exclude))
  lrMSI_short[1,s] <- round(summ$coefficients[2], digits=4)	# coeff[2] = slope
  lrMSI_short[2,s] <- round(summ$coefficients[2,2], digits=4) 	# coeff[2,2] = sd of slope
}
SLOPE_short <- mean(lrMSI_short[1,])
sdSLOPE_short <- sd(as.vector(lrMSI_short[1,]))

# Back-transform short-term trends to index scale
SLOPE_short_mult <- round(exp(SLOPE_short), digits=4)
sdSLOPE_short_mult <- round(sdSLOPE_short*SLOPE_short_mult, digits=4)

# Short term trend classification (Soldaat et al. 2007 (J. Ornithol. DOI 10.1007/s10336-007-0176-7))
TrendClass_short <- "X"
if (SLOPE_short_mult - 1.96*sdSLOPE_short_mult > 1.05) {TrendClass_short <- "strong increase" } else
  if (SLOPE_short_mult + 1.96*sdSLOPE_short_mult < 0.95) { TrendClass_short <- "steep decline" } else
    if (SLOPE_short_mult - 1.96*sdSLOPE_short_mult > 1.00) { TrendClass_short <- "moderate increase"} else
      if (SLOPE_short_mult + 1.96*sdSLOPE_short_mult < 1.00) { TrendClass_short <- "moderate decline" } else
        if ((SLOPE_short_mult - 1.96*sdSLOPE_short_mult - 0.95)*(1.05 - SLOPE_short_mult + 1.96*sdSLOPE_short_mult) < 0.00) { TrendClass_short <- "uncertain"} else
          if ((SLOPE_short_mult + 1.96*sdSLOPE_short_mult) - (SLOPE_short_mult - 1.96*sdSLOPE_short_mult) > 0.10) { TrendClass_short <- "uncertain" } else
          {TrendClass_short <- "stable"}
TrendClass_short

# linear trend before changepoint per simulation
lrMSI_before <- array(NA, dim=c(2, nsim))
byear <- c(minyear:changepoint)
byears <- length(byear)
simMSI_before <- array(NA, dim=c(byears, nsim))
for (s in 1:nsim) {
  for (y in 1:byears) {
    simMSI_before[y, s] <- simMSI[y,s]
  }
}
for (s in 1:nsim) {
  summb <- summary(lm(simMSI_before[,s] ~ byear, na.action=na.exclude))
  lrMSI_before[1,s] <- round(summb$coefficients[2], digits=4)  # coeff[2] = slope
  lrMSI_before[2,s] <- round(summb$coefficients[2,2], digits=4) 	# coeff[2,2] = sd of slope
}
SLOPE_before <- round(mean(lrMSI_before[1,]), digits=5)
sdSLOPE_before <- round(sd(as.vector(lrMSI_before[1,])), digits=5)

# Back-transform trends before changepoint to index scale
SLOPE_before_mult <- round(exp(SLOPE_before), digits=4)
sdSLOPE_before_mult <- round(sdSLOPE_before*SLOPE_before_mult, digits=4)

# Trend classification before changepoint
TrendClass_before <- "X"
if (SLOPE_before_mult - 1.96*sdSLOPE_before_mult > 1.05) {TrendClass_before <- "strong increase" } else
  if (SLOPE_before_mult + 1.96*sdSLOPE_before_mult < 0.95) { TrendClass_before <- "steep decline" } else
    if (SLOPE_before_mult - 1.96*sdSLOPE_before_mult > 1.00) { TrendClass_before <- "moderate increase"} else
      if (SLOPE_before_mult + 1.96*sdSLOPE_before_mult < 1.00) { TrendClass_before <- "moderate decline" } else
        if ((SLOPE_before_mult - 1.96*sdSLOPE_before_mult - 0.95)*(1.05 - SLOPE_before_mult + 1.96*sdSLOPE_before_mult) < 0.00) { TrendClass_before <- "uncertain"} else
          if ((SLOPE_before_mult + 1.96*sdSLOPE_before_mult) - (SLOPE_before_mult - 1.96*sdSLOPE_before_mult) > 0.10) { TrendClass_before <- "uncertain" } else
          {TrendClass_before <- "stable"}
TrendClass_before

# linear trend after changepoint per simulation
lrMSI_after <- array(NA, dim=c(2, nsim))
ayear <- c(changepoint:maxyear)
ayears <- length(ayear)
simMSI_after <- array(NA, dim=c(ayears, nsim))
for (s in 1:nsim) {
  for (y in 1:ayears) {
    simMSI_after[y, s] <- simMSI[(byears-1+y),s]
  }
}
for (s in 1:nsim) {
  summa <- summary(lm(simMSI_after[,s] ~ ayear, na.action=na.exclude))
  lrMSI_after[1,s] <- round(summa$coefficients[2], digits=4)  # coeff[2] = slope
  lrMSI_after[2,s] <- round(summa$coefficients[2,2], digits=4)   # coeff[2,2] = sd of slope
}
SLOPE_after <- round(mean(lrMSI_after[1,]), digits=5)
sdSLOPE_after <- round(sd(as.vector(lrMSI_after[1,])),digits=5)

# Trend classification before changepoint
SLOPE_after_mult <- round(exp(SLOPE_after), digits=4)
sdSLOPE_after_mult <- round(sdSLOPE_after*SLOPE_after_mult, digits=4)

# Trend classification after changepoint
TrendClass_after <- "X"
if (SLOPE_after_mult - 1.96*sdSLOPE_after_mult > 1.05) {TrendClass_after <- "strong increase" } else
  if (SLOPE_after_mult + 1.96*sdSLOPE_after_mult < 0.95) { TrendClass_after <- "steep decline" } else
    if (SLOPE_after_mult - 1.96*sdSLOPE_after_mult > 1.00) { TrendClass_after <- "moderate increase"} else
      if (SLOPE_after_mult + 1.96*sdSLOPE_after_mult < 1.00) { TrendClass_after <- "moderate decline" } else
        if ((SLOPE_after_mult - 1.96*sdSLOPE_after_mult - 0.95)*(1.05 - SLOPE_after_mult + 1.96*sdSLOPE_after_mult) < 0.00) { TrendClass_after <- "uncertain"} else
          if ((SLOPE_after_mult + 1.96*sdSLOPE_after_mult) - (SLOPE_after_mult - 1.96*sdSLOPE_after_mult) > 0.10) { TrendClass_after <- "uncertain" } else
          {TrendClass_after <- "stable"}
TrendClass_after

# compare linear trends before and after changepoint
compare <- array(NA, dim=c(nsim, 1))
for (s in 1:nsim){
  compare[s,1] <- lrMSI_after[1,s]-lrMSI_before[1,s]
}
meanTrendDiff <- mean(compare)
seTrendDiff <- sd(as.vector(compare))
significance <- NA
if (abs(meanTrendDiff)-2.58*seTrendDiff > 0) { significance <- "p<0.01" } else
  if (abs(meanTrendDiff)-1.96*seTrendDiff > 0) { significance <- "p<0.05" } else
    {significance <- "n.s."}

# Smoothing
# span = 0.75 is default in R and usually fits well. But trying other values may give better results, depending on your data
loessMSI <- array(NA, dim=c(nyear, nsim))
Diff <- array(NA, dim=c(nyear, nsim))
# Difftest <- array(NA, dim=c(nyear, nsim))
for (s in 1:nsim) {
  smooth <- predict(loess(simMSI[,s]~uyear, span=0.75, degree=2, na.action=na.exclude),
                    data.frame(uyear), se=TRUE)
  loessMSI[,s] <- round(smooth$fit, digits=4)

  for (y in 1:nyear) {
    Diff[y,s] <- loessMSI[nyear,s] - loessMSI[y,s]
#    Difftest[y,s] <- loessMSI[testyear,s] - loessMSI[y,s]
  }
}

# calculate overall change (first year set to 100) and change in last years
pct_CHANGE <- array(NA, dim=c(nsim, 2))
for (s in 1:nsim) {
pct_CHANGE[s,1] <- exp(loessMSI[nyear,s])*100/exp(loessMSI[1,s])-100
pct_CHANGE[s,2] <- exp(loessMSI[nyear,s])*100/exp(loessMSI[1,s])-exp(loessMSI[(nyear-lastyears+1),s])*100/exp(loessMSI[1,s])
}
pct_CHANGE_long <- round(mean(pct_CHANGE[,1]),digits=3)
sd_pct_CHANGE_long <- round(sd(pct_CHANGE[,1]), digits=3)
pct_CHANGE_short <- round(mean(pct_CHANGE[,2]),digits=3)
sd_pct_CHANGE_short <- round(sd(pct_CHANGE[,2]), digits=3)

# significance of percentage change
significance_PCT_long <- NA
if (abs(pct_CHANGE_long)-2.58*sd_pct_CHANGE_long > 0) { significance_PCT_long <- "p<0.01" } else
  if (abs(pct_CHANGE_long)-1.96*sd_pct_CHANGE_long > 0) { significance_PCT_long <- "p<0.05" } else
  {significance_PCT_long <- "n.s."}
significance_PCT_short <- NA
if (abs(pct_CHANGE_short)-2.58*sd_pct_CHANGE_short > 0) { significance_PCT_short <- "p<0.01" } else
  if (abs(pct_CHANGE_short)-1.96*sd_pct_CHANGE_short > 0) { significance_PCT_short <- "p<0.05" } else
  {significance_PCT_short <- "n.s."}

# Test for difference in smoothed trend value between each year and 'testyear'
# YEARTEST <- array(NA, dim=c(nyear, 4))
# for (y in 1:nyear) {
#   YEARTEST[y,1] <- round(mean(Difftest[y,]), digits=3)
#  YEARTEST[y,2] <- round(sd(Difftest[y,]), digits=3)
#  YEARTEST[y,3] <- round(YEARTEST[y,1]-1.96*YEARTEST[y,2], digits=3)
#  YEARTEST[y,4] <- round(YEARTEST[y,1]+1.96*YEARTEST[y,2], digits=3)
# }

# create output for flexible trend estimates
smoothMSI <- array(NA, dim=c(nyear, 13))
for (y in 1:nyear) {
smoothMSI[y,1] <- round(mean(loessMSI[y,]), digits=4) # smooth MSI on log scale
smoothMSI[y,2] <- round(sd(loessMSI[y,]), digits=4) # SE of smooth MSI on log scale
smoothMSI[y,3] <- round(mean(Diff[y,]), digits=4) # Difference smooth MSI with last year on log scale
smoothMSI[y,4] <- round(sd(Diff[y,]), digits=4) # SE of difference with ast year
smoothMSI[y,12] <- round(smoothMSI[y,1]-1.96*smoothMSI[y,2], digits=2) # lower CI of smooth MSI on log scale
smoothMSI[y,13] <- round(smoothMSI[y,1]+1.96*smoothMSI[y,2], digits=2) # upper CI of smooth MSI on log scale
}

# Trendclassification, based on smoothed trends (Soldaat et al. 2007 (J. Ornithol. DOI 10.1007/s10336-007-0176-7))
for (y in 1:nyear) {
  smoothMSI[y,5] <- round(smoothMSI[nyear,1]/smoothMSI[y,1], digits=4)		# = TCR
  smoothMSI[y,6] <- round(smoothMSI[y,5]-1.96*(smoothMSI[y,4]/smoothMSI[y,1]), digits=4)	# = CI- TCR
  smoothMSI[y,7] <- round(smoothMSI[y,5]+1.96*(smoothMSI[y,4]/smoothMSI[y,1]), digits=4)	# = CI+ TCR
  smoothMSI[y,8] <- round(exp(log(smoothMSI[y,5])/(nyear-y)), digits=4)		# = YCR
  smoothMSI[y,9] <- round(exp(log(smoothMSI[y,6])/(nyear-y)), digits=4)		# = CI- YCR
  smoothMSI[y,10] <- round(exp(log(smoothMSI[y,7])/(nyear-y)), digits=4)		# = CI+ YCR
}
for (y in 1:(nyear-1)) {
  if (smoothMSI[y,9] > 1.05) {smoothMSI[y,11] <- 1} else
    if (smoothMSI[y,10] < 0.95) {smoothMSI[y,11] <- 6} else
      if (smoothMSI[y,9] > 1.00) {smoothMSI[y,11] <- 2} else
        if (smoothMSI[y,10] < 1.00) {smoothMSI[y,11] <- 5} else
          if ((smoothMSI[y,9] - 0.95)*(1.05 - smoothMSI[y,10]) < 0.00) {smoothMSI[y,11] <- 3} else
            if ((smoothMSI[y,10]) - (smoothMSI[y,9]) > 0.10) {smoothMSI[y,11] <- 3} else
            {smoothMSI[y,11] <- 4}
}
TrendClass_flex <- matrix(NA, nrow= nyear, ncol=1)
for (y in 1:(nyear-1)) {
  if (smoothMSI[y,9] > 1.05) {TrendClass_flex[y] <- "strong_increase" } else
    if (smoothMSI[y,10] < 0.95) { TrendClass_flex[y] <- "steep_decline" } else
      if (smoothMSI[y,9] > 1.00) { TrendClass_flex[y] <- "moderate_increase"} else
        if (smoothMSI[y,10] < 1.00) { TrendClass_flex[y] <- "moderate_decline" } else
          if ((smoothMSI[y,9] - 0.95)*(1.05 - smoothMSI[y,10]) < 0.00) { TrendClass_flex[y] <- "uncertain"} else
            if ((smoothMSI[y,10]) - (smoothMSI[y,9]) > 0.10) { TrendClass_flex[y] <- "uncertain" } else
            {TrendClass_flex[y] <- "stable"}
}

# rescaling (for presentation of plot)
rescale <- NA
 if (index_smooth =="INDEX") {rescale <- 100/meanMSI[plotbaseyear]} else
  if (index_smooth =="SMOOTH") {rescale <- 100/exp(smoothMSI[plotbaseyear,1])} else
   {rescale <- NA}
simMSImean <- round(as.vector(rescale*meanMSI), digits=2)
simMSIsd <- round(as.vector(rescale*stdevMSI), digits=2)
uppCI_MSI <- round(rescale*CI[,2], digits=2)
lowCI_MSI <- round(rescale*CI[,1], digits=2)
trend_flex <- round(rescale*exp(smoothMSI[,1]), digits=2)
lowCI_trend_flex <- round(rescale*exp(smoothMSI[,12]), digits=2)
uppCI_trend_flex <- round(rescale* exp(smoothMSI[,13]), digits=2)

# create output file for MSI + smoothed trend
jobnameRESULTS <- paste (jobname, "_RESULTS.csv", sep = "")
RES <- as.data.frame(cbind(uyear, simMSImean, simMSIsd, lowCI_MSI, uppCI_MSI, trend_flex, lowCI_trend_flex, uppCI_trend_flex))
RES$trend_class <- TrendClass_flex
names(RES) <- c("year", "MSI", "sd_MSI", "lower_CL_MSI", "upper_CL_MSI", "Trend", "lower_CL_trend", "upper_CL_trend", "trend_class")
write.csv2(RES, file=jobnameRESULTS, row.names=FALSE, quote=FALSE)

# create output file with all linear trends
SIMTRENDS <- t(rbind(lrMSI[1,],lrMSI_short[1,]))
jobnameSIMTRENDS <- paste (jobname, "_SIMTRENDS.csv", sep = "")
write.csv2(SIMTRENDS, file=jobnameSIMTRENDS, row.names=FALSE)

# create output for linear trend estimates and % change
rownames <- rbind("overall trend","SE overall trend", "trend last years", "SE trend last years", "changepoint",
                  "trend before changepoint", "SE trend before changepoint", "trend after changepoint", "SE trend after changepoint",
                  "% change", "SE % change", "% change last years", "SE % change last years")
output <- cbind(SLOPE_mult, sdSLOPE_mult, SLOPE_short_mult, sdSLOPE_short_mult,
                changepoint, SLOPE_before_mult, sdSLOPE_before_mult, SLOPE_after_mult, sdSLOPE_after_mult,
                pct_CHANGE_long, sd_pct_CHANGE_long, pct_CHANGE_short, sd_pct_CHANGE_short)
TRENDS <- as.data.frame(t(output), row.names=rownames)
TRENDS$significance <- ""
TRENDS["changepoint", "significance"] <- significance
TRENDS[1, "significance"] <- TrendClass
TRENDS[3, "significance"] <- TrendClass_short
TRENDS[6, "significance"] <- TrendClass_before
TRENDS[8, "significance"] <- TrendClass_after
TRENDS[10, "significance"] <- significance_PCT_long
TRENDS[12, "significance"] <- significance_PCT_short
names(TRENDS) <- c("value", "significance")
jobnameTRENDS <- paste (jobname, "_TRENDS.csv", sep = "")
write.csv2(TRENDS, file=jobnameTRENDS)

# graph without error bars
limits <- aes(ymax = simMSImean+simMSIsd, ymin=simMSImean-simMSIsd)
jobnameGRAPH <- paste (jobname, "_GRAPH.jpg", sep = "")
x_position <- ifelse(SLOPE>0, maxyear-nyear/1.5, minyear+1)
y_position <- 50
legend10 <- paste(nspecies, "species")
legend11 <- paste("overall trend:", round(SLOPE_mult*100-100, digits=1), "% / yr,", TrendClass)
legend12 <- paste("last", lastyears, "years:", round(SLOPE_short_mult*100-100, digits=1), "% / yr,", TrendClass_short)
ylab <- paste("MSI (",plotbaseyear+minyear-1,"= 100 )")
lastyear01 <- c(rep(0,nyear-lastyears), rep(1,lastyears))
ggplot(RES, aes(x=year, y=MSI))+
  scale_color_manual(values=c("blue", "dark green"))+
  geom_point(colour = "dark green",size=3)+
  ylim(0, NA)+
  ylab(ylab)+
  ggtitle(jobname)+
        theme(plot.title = element_text(size = 25, face = "bold"),
        axis.title.x=element_blank(),
        axis.title.y=element_text(size=20,face="bold"),
        axis.text = element_text(size = 20),
        panel.background = element_blank(),
        panel.border = element_rect(colour = "black", fill=NA, size=1))+
  geom_ribbon(aes(ymin=lowCI_trend_flex, ymax=uppCI_trend_flex), alpha=0.2)+
  geom_line(aes(y=trend_flex), colour="dark green", size=1)+
  annotate("text", x=x_position, y=y_position, label = legend10, size=7, fontface=2, hjust=0)+
  annotate("text", x=x_position, y=y_position-15, label = legend11, size=7, hjust=0)+
  annotate("text", x=x_position, y=y_position-30, label = legend12, size=7, hjust=0)
ggsave(jobnameGRAPH)

# graph with error bars
# limits <- aes(ymax = simMSImean+simMSIsd, ymin=simMSImean-simMSIsd)
jobnameGRAPH2 <- paste (jobname, "_GRAPH2.jpg", sep = "")
ggplot(RES, aes(x=year, y=MSI))+
  scale_color_manual(values=c("blue", "dark green"))+
  geom_point(colour = "dark green",size=3)+
  ylim(0, NA)+
  ylab(ylab)+
  ggtitle(jobname)+
  theme(plot.title = element_text(size = 25, face = "bold"),
        axis.title.x=element_blank(),
        axis.title.y=element_text(size=20,face="bold"),
        axis.text = element_text(size = 20),
        panel.background = element_blank(),
        panel.border = element_rect(colour = "black", fill=NA, size=1))+
  geom_ribbon(aes(ymin=lowCI_trend_flex, ymax=uppCI_trend_flex), alpha=0.2)+
  geom_line(aes(y=trend_flex), colour="dark green", size=1)+
  geom_pointrange(limits, colour="dark green")+
annotate("text", x=x_position, y=y_position, label = legend10, size=7, fontface=2, hjust=0)+
annotate("text", x=x_position, y=y_position-15, label = legend11, size=7, hjust=0)+
annotate("text", x=x_position, y=y_position-30, label = legend12, size=7, hjust=0)
ggsave(jobnameGRAPH2)


 Hedge <- function(num_year){

      ###HEDGING
      #NORMAL RULES
      x <- c(1,32)
      y <- c(0.75*input$cc,0.7*input$cc)
      JAN <- approx(x,y,method="linear",n=31)
      x <- c(32,60)
      y <- c(0.7*input$cc,0.7*input$cc)
      FEB <- approx(x,y,method="linear",n=28)
      x <- c(60,91)
      y <- c(0.7*input$cc,0.7*input$cc)
      MAR <- approx(x,y,method="linear",n=31)
      x <- c(91,121)
      y <- c(0.7*input$cc,0.8*input$cc)
      APR <- approx(x,y,method="linear",n=30)
      x <- c(121,152)
      y <- c(0.8*input$cc,0.8*input$cc)
      MAY <- approx(x,y,method="linear",n=31)
      x <- c(152,182)
      y <- c(0.8*input$cc,0.8*input$cc)
      JUN <- approx(x,y,method="linear",n=30)
      x <- c(182,213)
      y <- c(0.8*input$cc,0.75*input$cc)
      JUL <- approx(x,y,method="linear",n=31)
      x <- c(213,244)
      y <- c(0.75*input$cc,0.7*input$cc)
      AUG <- approx(x,y,method="linear",n=31)
      x <- c(244,274)
      y <- c(0.7*input$cc,0.7*input$cc)
      SEP <- approx(x,y,method="linear",n=30)
      x <- c(274,305)
      y <- c(0.7*input$cc,0.7*input$cc)
      OCT <- approx(x,y,method="linear",n=31)
      x <- c(305,335)
      y <- c(0.7*input$cc,0.7*input$cc)
      NOV <- approx(x,y,method="linear",n=30)
      x <- c(335,365)
      y <- c(0.7*input$cc,0.7*input$cc)
      DEC <- approx(x,y,method="linear",n=31)
      STOR_NORM <- c(JAN$y,FEB$y,MAR$y,APR$y,MAY$y,JUN$y,JUL$y,AUG$y,SEP$y,OCT$y,NOV$y,DEC$y)
      STOR_NORM <- rep(STOR_NORM,num_year)

      #MODERATE RULES
      x1 <- c(1,32)
      y1 <- c(0.65*input$cc,0.625*input$cc)
      JAN1 <- approx(x1,y1,method="linear",n=31)
      x1 <- c(32,60)
      y1 <- c(0.625*input$cc,0.6*input$cc)
      FEB1 <- approx(x1,y1,method="linear",n=28)
      x1 <- c(60,91)
      y1 <- c(0.6*input$cc,0.6*input$cc)
      MAR1 <- approx(x1,y1,method="linear",n=31)
      x1 <- c(91,121)
      y1 <- c(0.6*input$cc,0.675*input$cc)
      APR1 <- approx(x1,y1,method="linear",n=30)
      x1 <- c(121,152)
      y1 <- c(0.675*input$cc,0.7*input$cc)
      MAY1 <- approx(x1,y1,method="linear",n=31)
      x1 <- c(152,182)
      y1 <- c(0.7*input$cc,0.675*input$cc)
      JUN1 <- approx(x1,y1,method="linear",n=30)
      x1 <- c(182,213)
      y1 <- c(0.675*input$cc,0.6*input$cc)
      JUL1 <- approx(x1,y1,method="linear",n=31)
      x1 <- c(213,244)
      y1 <- c(0.6*input$cc,0.6*input$cc)
      AUG1 <- approx(x1,y1,method="linear",n=31)
      x1 <- c(244,274)
      y1 <- c(0.6*input$cc,0.6*input$cc)
      SEP1 <- approx(x1,y1,method="linear",n=30)
      x1 <- c(274,305)
      y1 <- c(0.6*input$cc,0.6*input$cc)
      OCT1 <- approx(x1,y1,method="linear",n=31)
      x1 <- c(305,335)
      y1 <- c(0.6*input$cc,0.6*input$cc)
      NOV1 <- approx(x1,y1,method="linear",n=30)
      x1 <- c(335,365)
      y1 <- c(0.6*input$cc,0.6*input$cc)
      DEC1 <- approx(x1,y1,method="linear",n=31)
      STOR_MOD <- c(JAN1$y,FEB1$y,MAR1$y,APR1$y,MAY1$y,JUN1$y,JUL1$y,AUG1$y,SEP1$y,OCT1$y,NOV1$y,DEC1$y)
      STOR_MOD <- rep(STOR_MOD,num_year)

      RESULT <- list(STOR_NORM,STOR_MOD)
      return(RESULT)

}


#' steadman_outdoor_shade
#'
#' Computes Steadman's apparent temperature under shaded outdoor conditions.
#'
#' @param t numeric     Air temperature in Celsius degrees.
#' @param rh numeric    Relative humidity in percentage.
#' @param wind numeric  Wind speed in meters per second.
#' @return Apparent temperature index.
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  Steadman, outdoor, shade, apparent temperature.
#'
#' @export
#'
#'
#'
#'

steadman_outdoor_shade=function(t,rh,wind) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("wind", as.array(wind))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=steadman_outdoor_shade(t[i],rh[i],wind[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


library(related)
library(ggplot2)

# read in genotypes  (modify this name as necessary for different colonies or datasets)
x <- read.table("filtered_100kbp.related", stringsAsFactors=F)

# input species name (e.g., herculeanus, laevigatus, or modoc)
species <- "laevigatus"

# input colony number (e.g., 1, 2, or 3)
colony_number <- 1

# define number of simulations
nsims <- 100

# simulations
# first, obtain overall allele freqs for each locus
# allow 5% variation of allele frequencies (i.e., a little randomness)
n_loci <- (ncol(x) - 1) / 2
alleles <- list()
allele_freqs <- list()
for(a in 1:n_loci) {
	alleles[[a]] <- c(x[,a * 2], x[,a * 2 + 1])
	af1 <- length(alleles[[a]][alleles[[a]] == 1]) / length(alleles[[a]])
	# add +/- 5% variation to allele frequencies (some stochasticity for small sample sizes)
	af1 <- af1 + sample(seq(from=-0.05, to=0.05, by=0.001), 1)
	# make sure the frequency is between 0.01 and 0.99
	if(af1 < 0.01) {
		af1 <- 0.01
	} else if (af1 > 0.99) {
		af1 <- 0.99
	}
	# change to integer on zero to one hundred scale
	af1 <- round(af1, digits=2) * 100
	af2 <- 100 - af1
	allele_freqs[[a]] <- c(rep(1, af1), rep(5, af2))
}

# output sim lists
offspring_sims <- list()
half_sibs <- list()
unrelated <- list()
# loop for simulations (this may take up to 30-60 minutes)
for(a in 1:nsims) {
	if(a %% 10 == 0) {
		writeLines(paste("Simulation ", a, " started.", sep=""))
	}

	# generate a haploid male
	male <- list()
	for(b in 1:n_loci) {
		male[[b]] <- sample(allele_freqs[[b]], 1)
	}
	male <- unlist(male)

	# sample a diploid female
	female_1 <- list()
	female_2 <- list()
	for(b in 1:n_loci) {
		female_1[[b]] <- sample(allele_freqs[[b]], 1)
		female_2[[b]] <- sample(allele_freqs[[b]], 1)
	}
	female_1 <- unlist(female_1)
	female_2 <- unlist(female_2)

	# create 1st offspring of the two parents
	offspring1 <- list()
	for(b in 1:length(female_1)) {
		offspring1[[b]] <- sort(c(male[b], sample(c(female_1[b], female_2[b]), 1)))
	}
	offspring1 <- unlist(offspring1)

	# create 2nd offspring of the two parents
	offspring2 <- list()
	for(b in 1:length(female_1)) {
		offspring2[[b]] <- sort(c(male[b], sample(c(female_1[b], female_2[b]), 1)))
	}
	offspring2 <- unlist(offspring2)

	# combine two offspring's data into one dataframe
	sim <- as.data.frame(cbind(c(paste("offspring1__", a, sep=""), paste("offspring2__", a, sep="")), rbind(offspring1, offspring2)))
	# make sure the first column of sim is character
	sim[,1] <- as.character(sim[,1])
	# add to offspring sims
	offspring_sims[[a]] <- sim

	# for half sib relationships with queen and two males mated
	# generate a second haploid male
	male2 <- list()
	for(b in 1:n_loci) {
		male2[[b]] <- sample(allele_freqs[[b]], 1)
	}
	male2 <- unlist(male2)

	# create 1st offspring of the one female and male 1
	halfsib1 <- list()
	for(b in 1:length(female_1)) {
		halfsib1[[b]] <- sort(c(male[b], sample(c(female_1[b], female_2[b]), 1)))
	}
	halfsib1 <- unlist(halfsib1)

	# create 2nd offspring of the one female, but mated to male 2
	halfsib2 <- list()
	for(b in 1:length(female_1)) {
		halfsib2[[b]] <- sort(c(male2[b], sample(c(female_1[b], female_2[b]), 1)))
	}
	halfsib2 <- unlist(halfsib2)

	# combine two halfsib's data into one dataframe
	sim <- as.data.frame(cbind(c(paste("halfsib1__", a, sep=""), paste("halfsib2__", a, sep="")), rbind(halfsib1, halfsib2)))
	# make sure the first column of sim is character
	sim[,1] <- as.character(sim[,1])
	# add to halfsib sims
	half_sibs[[a]] <- sim

	# unrelated individuals
	# sample a random genotype (x2) from the allele freqs
	random_1 <- list()
	random_2 <- list()
	for(b in 1:n_loci) {
		random_1[[b]] <- sample(allele_freqs[[b]], 2)
		random_2[[b]] <- sample(allele_freqs[[b]], 2)
	}
	random_1 <- unlist(random_1)
	random_2 <- unlist(random_2)

	# combine two randoms' data into one dataframe
	sim <- as.data.frame(cbind(c(paste("unrelated1__", a, sep=""), paste("unrelated2__", a, sep="")), rbind(random_1, random_2)))
	# make sure the first column of sim is character
	sim[,1] <- as.character(sim[,1])
	# add to unrelated sims
	unrelated[[a]] <- sim
}

# add all real and simulated data into a single data frame for relatedness estimates
total <- x
offspring_sims2 <- do.call("rbind", offspring_sims)
half_sibs2 <- do.call("rbind", half_sibs)
unrelated2 <- do.call("rbind", unrelated)
total <- rbind(total, offspring_sims2, half_sibs2, unrelated2)

# clean up objects no longer needed and clean up garbage
rm(offspring_sims2, half_sibs2, unrelated2, offspring_sims, half_sibs, unrelated)

# measure relatedness of all real and simulated individuals (this may take up to 30-60 minutes)
total_relate <- coancestry(total, lynchli=2, wang=2)

# extract point estimates of relatedness for each grouping
# real data
real_data_relatedness <- total_relate$relatedness[total_relate$relatedness$group == "C-C-",]
real_data_95CI <- total_relate$relatedness.ci95[total_relate$relatedness.ci95$group == "C-C-",]

# full sister simulations
full_sister_relatedness <- total_relate$relatedness[total_relate$relatedness$group == "ofof",]
full_sister_relatedness <- full_sister_relatedness[sapply(strsplit(full_sister_relatedness[,2], "__"), "[[", 2) == sapply(strsplit(full_sister_relatedness[,3], "__"), "[[", 2), ]

# half sister simulations
half_sister_relatedness <- total_relate$relatedness[total_relate$relatedness$group == "haha",]
half_sister_relatedness <- half_sister_relatedness[sapply(strsplit(half_sister_relatedness[,2], "__"), "[[", 2) == sapply(strsplit(half_sister_relatedness[,3], "__"), "[[", 2), ]

# unrelated individuals simulations
unrelated_relatedness <- total_relate$relatedness[total_relate$relatedness$group == "unun",]
unrelated_relatedness <- unrelated_relatedness[sapply(strsplit(unrelated_relatedness[,2], "__"), "[[", 2) == sapply(strsplit(unrelated_relatedness[,3], "__"), "[[", 2), ]

# save the work
save.image(paste(species, "__", colony_number, "__relatedness.RData", sep=""))

# make a merged data frame for boxplots of simulations
full_sister_related <- data.frame(Relationship=as.character(rep("Full Sister", nrow(full_sister_relatedness)*2)), Measurement=as.character(c(rep("Wang (2002)", nrow(full_sister_relatedness)), rep("Li et al. (1993)", nrow(full_sister_relatedness)))), Relatedness=as.numeric(c(full_sister_relatedness$wang, full_sister_relatedness$lynchli)))
half_sister_related <- data.frame(Relationship=as.character(rep("Half Sister", nrow(half_sister_relatedness)*2)), Measurement=as.character(c(rep("Wang (2002)", nrow(half_sister_relatedness)), rep("Li et al. (1993)", nrow(half_sister_relatedness)))), Relatedness=as.numeric(c(half_sister_relatedness$wang, half_sister_relatedness$lynchli)))
unrelated_sister_related <- data.frame(Relationship=as.character(rep("Unrelated", nrow(unrelated_relatedness)*2)), Measurement=as.character(c(rep("Wang (2002)", nrow(unrelated_relatedness)), rep("Li et al. (1993)", nrow(unrelated_relatedness)))), Relatedness=as.numeric(c(unrelated_relatedness$wang, unrelated_relatedness$lynchli)))

# combine the three into one
total_related <- rbind(full_sister_related, half_sister_related, unrelated_sister_related)

# make a boxplot
ggplot(total_related, aes(x=Relationship, y=Relatedness, fill=Measurement)) + geom_boxplot()

# save a pdf of the boxplot (change the name as necessary)
pdf(file=paste(species, "__", colony_number, "__simboxplot.pdf", sep=""), width=5, height=7)
ggplot(total_related, aes(x=Relationship, y=Relatedness, fill=Measurement)) + geom_boxplot()
dev.off()

# combine the real data into a nice data matrix and save the table
real_data_output <- data.frame(Ind1=as.character(real_data_relatedness$ind1.id),
							   Ind2=as.character(real_data_relatedness$ind2.id),
							   Species=as.character(species),
							   Colony=as.character(colony_number),
							   Wang=as.numeric(real_data_relatedness$wang),
							   Wang_low=as.numeric(real_data_95CI$wang.low),
							   Wang_high=as.numeric(real_data_95CI$wang.high),
							   Li=as.numeric(real_data_relatedness$lynchli),
							   Li_low=as.numeric(real_data_95CI$lynchli.low),
							   Li_high=as.numeric(real_data_95CI$lynchli.high))
# print the matrix to look at
real_data_output
# write the matrix to table
write.table(real_data_output, file=paste(species, "__", colony_number, "__relatedness.txt", sep=""), sep="\t",
			quote=F, col.names=T, row.names=F)


#!/usr/bin/env Rscript
#autor:      Joao Sollari Lopes
#local:      University of Reading, Reading, UK
#Rversion:   3.2.3
#criado:     01.03.2010
#modificado: 20.11.2017

# @arg data_file - file with summary of 'real' data (.trg)
# @arg rej_file  - file with rejection step results (.rej)
# @arg pri_file  - file with sample of priors (.pri)
reg_step <- function(data_file , rej_file , pri_file){

	#import libraries
	library(locfit)
	library(nnet)
    library(abc)

	#import Mark Beaumont's scripts
	source("make_pd2.r")

	#demographic parameters' priors (minimum and maximum values)
	mintev <- 0
	maxtev <- 10000
	minNe1 <- 0
	maxNe1 <- 12500
	minNe2 <- 0
	maxNe2 <- 40000
	minNeA <- 0
	maxNeA <- 10000
	minmig1 <- 0
	maxmig1 <- 0.0005
	minmig2 <- 0
	maxmig2 <- 0.0005

    truetev <- 5000
    trueNe1 <- 10000
    trueNe2 <- 20000
    trueNeA <- 5000
    truemig1 <- 0.0001
    truemig2 <- 0.0001

	#import the .rej file
	abc.rej <- data.matrix(read.table(rej_file))

	#import the .pri files
	priors <- data.matrix(read.table(pri_file))

	#import the .trg files
	target <- data.matrix(read.table(data_file))

	# Plot line for splitting time and save it in a .eps file
	abc.reg.tev <- makepd4(target,abc.rej[,7],abc.rej[,13:21],tol=1,rej=F,transf="log")
	abc.nn.tev <- abc(target,abc.rej[,7],abc.rej[,13:21],tol=1,method="neuralnet",transf="log")
    fname <- "../results/tev_reg.eps"
    postscript(file=fname,width=7,height=7,colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special")
	plot(locfit(~abc.reg.tev$x,weight=abc.reg.tev$wt,xlim=c(mintev,maxtev)),main="prior (black) and posterior (blue) distributions",xlab="tev",col="blue")
	lines(locfit(~abc.nn.tev$adj.values,weight=abc.nn.tev$weights,xlim=c(mintev,maxtev)),col="purple")
	lines(locfit(~priors[,7],xlim=c(mintev,maxtev)),col="black")
    abline(v=truetev,lty=2,col="black")
	dev.off()
	print("tev done.")

	# Plot line for effective size of population 1 and save it in a .eps file
	abc.reg.ne1 <- makepd4(target,abc.rej[,8],abc.rej[,13:21],tol=1,rej=F,transf="log")
	abc.nn.ne1 <- abc(target,abc.rej[,8],abc.rej[,13:21],tol=1,method="neuralnet",transf="log")
    fname <- "../results/Ne1_reg.eps"
    postscript(file=fname,width=7,height=7,colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special")
	plot(locfit(~abc.reg.ne1$x,weight=abc.reg.ne1$wt,xlim=c(minNe1,maxNe1)),main="prior (black) and posterior (blue) distributions",xlab="Ne1",col="blue")
	lines(locfit(~abc.nn.ne1$adj.values,weight=abc.nn.ne1$weights,xlim=c(minNe1,maxNe1)),col="purple")
	lines(locfit(~priors[,8],xlim=c(minNe1,maxNe1)),col="black")
    abline(v=trueNe1,lty=2,col="black")
	dev.off()
	print("Ne1 done.")

	# Plot line for effective size of population 2 and save it in a .eps file
	abc.reg.ne2 <- makepd4(target,abc.rej[,9],abc.rej[,13:21],tol=1,rej=F,transf="log")
	abc.nn.ne2 <- abc(target,abc.rej[,9],abc.rej[,13:21],tol=1,method="neuralnet",transf="log")
    fname <- "../results/Ne2_reg.eps"
    postscript(file=fname,width=7,height=7,colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special")
	plot(locfit(~abc.reg.ne2$x,weight=abc.reg.ne2$wt,xlim=c(minNe2,maxNe2)),main="prior (black) and posterior (blue) distributions",xlab="Ne2",col="blue")
	lines(locfit(~abc.nn.ne2$adj.values,weight=abc.nn.ne2$weights,xlim=c(minNe2,maxNe2)),col="purple")
	lines(locfit(~priors[,9],xlim=c(minNe2,maxNe2)),col="black")
    abline(v=trueNe2,lty=2,col="black")
	dev.off()
	print("Ne2 done.")

	# Plot line for effective size of ancestor population and save it in a .eps file
	abc.reg.nea <- makepd4(target,abc.rej[,10],abc.rej[,13:21],tol=1,rej=F,transf="log")
	abc.nn.nea <- abc(target,abc.rej[,10],abc.rej[,13:21],tol=1,method="neuralnet",transf="log")
    fname <- "../results/NeA_reg.eps"
    postscript(file=fname,width=7,height=7,colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special")
	plot(locfit(~abc.reg.nea$x,weight=abc.reg.nea$wt,xlim=c(minNeA,maxNeA)),main="prior (black) and posterior (blue) distributions",xlab="NeA",col="blue")
	lines(locfit(~abc.nn.nea$adj.values,weight=abc.nn.nea$weights,xlim=c(minNeA,maxNeA)),col="purple")
	lines(locfit(~priors[,10],xlim=c(minNeA,maxNeA)),col="black")
    abline(v=trueNeA,lty=2,col="black")
	dev.off()
	print("NeA done.")

	# Plot line for migration rate of population 1 and save it in a .eps file
	abc.reg.mig1 <- makepd4(target,abc.rej[,11],abc.rej[,13:21],tol=1,rej=F,transf="log")
	abc.nn.mig1 <- abc(target,abc.rej[,11],abc.rej[,13:21],tol=1,method="neuralnet",transf="log")
    fname <- "../results/mig1_reg.eps"
    postscript(file=fname,width=7,height=7,colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special")
	plot(locfit(~abc.reg.mig1$x,weight=abc.reg.mig1$wt,xlim=c(minmig1,maxmig1)),main="prior (black) and posterior (blue) distributions",xlab="mig1",col="blue")
	lines(locfit(~abc.nn.mig1$adj.values,weight=abc.nn.mig1$weights,xlim=c(minmig1,maxmig1)),col="purple")
	lines(locfit(~priors[,11],xlim=c(minmig1,maxmig1)),col="black")
    abline(v=truemig1,lty=2,col="black")
	dev.off()
	print("mig1 done.")

	# Plot line for migration rate of population 2 and save it in a .eps file
	abc.reg.mig2 <- makepd4(target,abc.rej[,12],abc.rej[,13:21],tol=1,rej=F,transf="log")
	abc.nn.mig2 <- abc(target,abc.rej[,12],abc.rej[,13:21],tol=1,method="neuralnet",transf="log")
    fname <- "../results/mig2_reg.eps"
    postscript(file=fname,width=7,height=7,colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special")
	plot(locfit(~abc.reg.mig2$x,weight=abc.reg.mig2$wt,xlim=c(minmig2,maxmig2)),main="prior (black) and posterior (blue) distributions",xlab="mig2",col="blue")
	lines(locfit(~abc.nn.mig2$adj.values,weight=abc.nn.mig2$weights,xlim=c(minmig2,maxmig2)),col="purple")
	lines(locfit(~priors[,12],xlim=c(minmig2,maxmig2)),col="black")
    abline(v=truemig2,lty=2,col="black")
	dev.off()
	print("mig2 done.")

}

args = commandArgs(trailingOnly=TRUE)
reg_step(args[1],args[2],args[3])


### ROCs ###
x = data.matrix(train_table[,my_features[my_features!="status"]])

y = train_table$status
y[which(y=="TP")] = 1
y[which(y=="FP")] = 0
y=as.matrix(as.numeric(y))
model_mlp <- monmlp.fit(x, y, hidden1=3, n.ensemble=1, monotone=1, bag=TRUE)

pred = monmlp.predict(x = x, weights = model_mlp)

library(ROCR)
perf = performance( prediction( pred, y ), "prec","rec" )
plot(perf, colorize=T, xlim=c(1,0.9))
auc = performance( prediction( pred, y ), "auc" )@y.values[[1]]

# analyses #

coeffs_from_2_pts <- function(x1, y1, x2, y2){
  if(y1==y2) return(list(a=0, b=y1))
  if(x1==x2) return(list(a=NULL, b=NULL))
  a = (y2 - y1) / (x2 - x1)
  b = y1 - a * x1
  return(list(a=a, b=b))
}

sens_thr = 0.98

cf = coeffs_from_2_pts(x1 = unlist(perf@x.values)[rev(which(unlist(perf@x.values)<=sens_thr))[1]],
                       y1 = unlist(perf@y.values)[rev(which(unlist(perf@x.values)<=sens_thr))[1]],
                       x2 = unlist(perf@x.values)[which(unlist(perf@x.values)>=sens_thr)[1]],
                       y2 = unlist(perf@y.values)[which(unlist(perf@x.values)>=sens_thr)[1]])

fdr = cf[["a"]] * sens_thr + cf[["b"]]

points(sens_thr, fdr)

mlp_thr =

  # compute FDR given sens #

  tdr_thr = 0.98
cf = coeffs_from_2_pts(x1 = unlist(perf@x.values)[rev(which(rev(unlist(perf@y.values))<=tdr_thr))[1]],
                       y1 = rev(unlist(perf@y.values))[rev(which(rev(unlist(perf@y.values))<=tdr_thr))[1]],
                       x2 = unlist(perf@x.values)[which(rev(unlist(perf@y.values))>=tdr_thr)[1]],
                       y2 = rev(unlist(perf@y.values))[which(rev(unlist(perf@y.values))>=tdr_thr)[1]])

sens = cf[["a"]] * tdr_thr + cf[["b"]]
if(length(sens)==0) sens = unlist(perf@x.values)[rev(which(rev(unlist(perf@y.values))<=tdr_thr))[1]]

points(sens_thr, fdr)

#### using K-fold ####
#### run the beginning of MLP.r script to have the table status ####

folds <- createFolds(train_table$status, 10)

#all_pred = c()
#all_status = c()

all_pred_rf = c()
all_status_rf = c()

for(i in 1:10){
  print(paste("fold: ",i,sep=""))
  test = train_table[folds[[i]],]
  train = train_table[-folds[[i]],]

  #xtest = data.matrix(test[,my_features[my_features!="status"]])
  #ytest = test$status
  #ytest[which(ytest=="TP")] = 1
  #ytest[which(ytest=="FP")] = 0
  #ytest=as.matrix(as.numeric(ytest))

  #xtrain = data.matrix(train[,my_features[my_features!="status"]])
  #ytrain = train$status
  #ytrain[which(ytrain=="TP")] = 1
  #ytrain[which(ytrain=="FP")] = 0
  #ytrain=as.matrix(as.numeric(ytrain))

  #model_mlp <- monmlp.fit(xtrain, ytrain, hidden1=3, n.ensemble=1, monotone=1, bag=TRUE)

  #test$prediction = monmlp.predict(x = xtest, weights = model_mlp)
  #all_pred=c(all_pred, test$prediction)
  #all_status = c(all_status, ytest)

  train$old_status=train$status; test$old_status=test$status
  train$status = 0 ; train[which(train$old_status=="TP"),"status"] = 1
  test$status = 0 ; test[which(test$old_status=="TP"),"status"] = 1
  rf_fold = randomForest(as.factor(status) ~ ., data = train[,my_features], importance = TRUE,
                         ntree = 500, sampsize = as.numeric(table(train$status)["1"]), probs=T)
  prediction = predict(rf_fold, test, type="prob")[,2]
  all_pred_rf = c(all_pred_rf, prediction)
  all_status_rf = c(all_status_rf, test$status)
}

library(ROCR)
#perf = performance( prediction( all_pred, all_status ), "prec","rec" )
#plot(perf, colorize=T, xlim=c(1,0), lwd=3)
#auc = performance( prediction( all_pred, all_status ), "auc" )@y.values[[1]]

perf = performance( prediction( all_pred_rf, all_status_rf ), "rec" ,"ppv" ) #sens in y and tdr in x
if(type=="snv"){
  plot(perf, colorize=T, lwd=3, xlab="1-FDR", ylab="sensitivity", xaxt='n', main=type,
       xlim=c(1,0.95), ylim=c(0.5,1))
} else {
  plot(perf, colorize=T, xlim=c(1,0), lwd=3, xlab="1-FDR", ylab="sensitivity", xaxt='n', main=type, colorkey=F)
}

auc = performance( prediction( all_pred_rf, all_status_rf ), "auc" )@y.values[[1]]

# compare with home filters
train_table$prediction_home_filters = "FP"
rvsbthr = ifelse(type=="snv", 0.95, 0.85)
train_table[which(train_table$AF>0.1 & train_table$RVSB<rvsbthr & train_table$DP>50 & train_table$ERR<(-2)),"prediction_home_filters"] = "TP"
sens_home_filter = sum(train_table$status=="TP" & train_table$prediction_home_filters=="TP") / sum(train_table$status=="TP")
TDR_home_filters = sum(train_table$status == "TP" & train_table$prediction_home_filters == "TP") / sum(train_table$prediction_home_filters == "TP")

points(TDR_home_filters, sens_home_filter, pch=4, lwd=2)
legend(x=0.96, y=0.7, c("AF>0.1","RVSB<0.95","DP>50","ERR<0.01"),
       col=c("black","white","white","white"), pch=4, bty="n", cex=0.75)

id = which(unlist(perf@x.values) <= TDR_home_filters)[1]
points(unlist(perf@x.values)[id], unlist(perf@y.values)[id])


"
Перечислить по памяти зарезервированные слова языка R. Сколько их всего?
Объяснить смысл NULL, Inf, NA, NaN. Получить эти значения несколькими способами в
результате выполнения каких-либо операции
"

#NA Обращение к несуществующему элементу вектора
my.list <- list(Text=c("A", "B", "C"))
print(my.list)
print(my.list$Text[4])

#NULL Обращение к несуществующему элементу списка
print(my.list$Kot[4])

#Inf при делении на 0
r <- 10/0
print(r)

#NaN – неопределенный результат
result <- 1+NaN
print(result)


Args<-commandArgs()
n1=as.numeric(unlist(strsplit(Args[6], ",")))
n2=as.numeric(unlist(strsplit(Args[7], ",")))
t<-cor.test(n1,n2)
g<-cor.test(n1,n2,alternative="g")
l<-cor.test(n1,n2,alternative="l")
cat(paste(t$p.value, g$p.value, l$p.value))


# Test
require(igraph)
fileName <- c(system.file("extdata",  package = "multiweb"))
fileName <- system.file("extdata", "BarentsBoreal_FW.csv", package = "multiweb")
g <- readNetwork(fileName)
V(g)$weigth <-  runif(vcount(g))
plotTrophLevel(g,vertexLabel = FALSE,vertexSizeFactor = 3,modules = TRUE,maxTL=4,weights=NULL, frame.color="black")
tk <- plotTrophLevel(g,vertexLabel = FALSE,vertexSizeFactor = 3,modules = TRUE, tk=TRUE)
plotTrophLevel(g,vertexLabel = FALSE,vertexSizeFactor = 3,modules = TRUE, lMat=tk)

dn <- list.files("inst/extdata",pattern = "^.*\\.csv$")
g<- readNetwork(dn,"inst/extdata")
names(g)
E(g[[1]])[which_loop(g[[1]])]

plotTrophLevel(g[[1]])

require(igraph)
require(NetIndices)
g <-   graph_from_literal( 1 -+ 4 -+ 7,2 -+ 5 -+7, 3-+6-+7, 7-+7, 4+-3, simplify = FALSE)
calc_topological_indices(g)
plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE,maxTL=4,weights=NULL)
plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE,maxTL=4,weights=NULL, bpal=viridisLite::viridis(11))

# Test tk and use of lMat
tk <- plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE, tk=TRUE,vertex.label.color="white")
tk [,2] <- seq(0,100, length.out = 7)
plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE, lMat=tk,maxTL=2)

# add weights
#
E(g)$weight <- c(2,2.5,0.1,0.2,1,5,0.1,2)
plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE,maxTL=4,weights=NA,edge.width=5)

plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE,maxTL=4,weights=NULL,edge.width=5)

# Test incoherence
#
calcIncoherence(g)

g <-   graph_from_literal( 1 -+ 4 -+ 7,2 -+ 5 -+7, 3-+6-+7, 4+-5, simplify = FALSE)
calcTopologicalIndices(g)
plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20, modules = TRUE)
nullg <- generateERbasal(g,10)
calcIncoherence(nullg,ncores=0)

calcModularitySWnessZScore(g,nullg,0.1)
calc_swness_zscore(g,nullg,0.1,ncores = 0)

# test reading .csv files
#
dn <- list.files("~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs",pattern = "^.*\\.csv$")
#
# BEWARE different files have different structure
#
nets <- readNetwork(dn[11],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
nets <- readNetwork(dn[16],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
nets <- readNetwork(dn[17],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
nets <- readNetwork(dn[18],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
nets <- readNetwork(dn[19],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
nets <- readNetwork(dn[20],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
nets <- readNetwork(dn[21],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
V(nets)[[]]
nets <- readNetwork(dn[22],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
nets <- readNetwork(dn[23],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
nets <- readNetwork(dn,"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs")
nets$CaymanIs_FW <- readNetwork(dn[8],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs",fhead = FALSE,skipColumn = 0)
nets$Jamaica_FW <- readNetwork(dn[15],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs",fhead = FALSE,skipColumn = 0)
nets$Cuba_FW <- readNetwork(dn[11],"~/Academicos/GitProjects/MarineFoodWebsSmallWorld/Data/FoodWebs",fhead = FALSE,skipColumn = 0)

calcTopologicalIndices(nets)
calcIncoherence(nets)
#netData <- nets
#devtools::use_data(netData,overwrite = TRUE)

# test reading .dat files from Johnson 2017
#

dn <- list.files("~/Dropbox/Projects/NetworksAsUnifyingPrinciple/Data",pattern = "^.*\\.dat$")
nets <- readNetwork(dn,"~/Dropbox/Projects/NetworksAsUnifyingPrinciple/Data",fhead=FALSE)
calcTopologicalIndices(list(netData$CaymanIs_FW,nets$cayman_islands))
require(RColorBrewer)
plotTrophLevel(nets$cayman_islands)
plotTrophLevel(netData$CaymanIs_FW)

#
nets <- readNetwork("Meta.dat","~/Dropbox/Projects/StabilityConstraints/Data",edgeListFormat = 2)

# The incoherence parameter seems not well calculated compared to Johnson 2017 Appendix Table S1
#
require(igraph)
calcTopologicalIndices(nets)
calcIncoherence(nets)
mean(degree(nets$benguela,mode="out"))
calcIncoherence(nets$bridge)

mean(degree(nets$bridge))
degree()

# Test modularity & incoherence Q
# 1 =Omnivory link 5+-4
#
g <-   graph_from_literal( 1 -+ 4 -+ 7,2 -+ 5 -+ 9, 4+-5,
                           3 -+ 6 -+ 8,5 -+8, simplify = FALSE)
plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE)
title(main="9 species")
calcTopologicalIndices(g)
calcIncoherence(g)
calcModularitySWnessZScore(g,generateERbasal(g,10),0.1)

# Completely coherent Q=0 network
#
g <-   graph_from_literal( 1 -+ 4 -+ 7,2 -+ 5 , 2-+4, 5-+7, 3-+6 -+8,
                           5 -+8, simplify = FALSE)
plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE)
calcTopologicalIndices(g)
calcIncoherence(g)
calcModularitySWnessZScore(g,generateERbasal(g,100),0.1,ncores = 0)
dg <- components(g)
m<-cluster_spinglass(g)
m$membership

#
# Testing Curve Ball algorithm
#
g <-   graph_from_literal( 2 -+ 1 +-3,4 -+ 1, 3+-3, 4-+6-+2, 2+-5-+3, simplify = FALSE)
calcTopologicalIndices(g)
plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE)
gg <- curveBall(g,10)
gg <- curve_ball(g,1000)
calcTopologicalIndices(gg,ncores=48)

plotTrophLevel(gg[[1]],vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE)
plotTrophLevel(gg[[2]],vertexLabel = TRUE,vertexSizeFactor = 10,modules=TRUE)
plotTrophLevel(gg[[3]],vertexLabel = TRUE,vertexSizeFactor = 10,modules = TRUE)
plotTrophLevel(gg[[10]],vertexLabel = TRUE,vertexSizeFactor = 20,modules = TRUE)

#
# Add weight
#
E(g)$weight <- sample(c(.1,.2,.8,.9),gsize(g),replace=TRUE)
m <- get.adjacency(g,sparse=FALSE,attr="weight")
gg <- curveBall(g,2,istrength =TRUE)
m1 <- get.adjacency(gg[[1]],sparse=FALSE)
m
m1

# Test SW zscores
#
any(sapply(gg, function(g) components(g)$no>1))
calcModularitySWnessZScore(g,gg,0.01)

# Test Parallel
#
p <- calcTopologicalIndices(gg,4)
p <- calcIncoherence(gg,4)

# Calculate 1000 randomizations of a real network
#
gg <- curveBall(netData[[1]],100)
sapply(gg, function(g) components(g)$no)

lapply(gg,count_components)!=1
tp <- calcTopologicalIndices(gg)
tp1<- calcTopologicalIndices(gg,4)
any(tp!=tp1)
tp <- calcIncoherence(gg)
tp1 <- calcIncoherence(gg,ncores=4)
any(tp!=tp1)

#
# Duplicate the same network to test the function
#
gg <- rep(list(netData[[1]]),100)
p <- calcIncoherence(gg)
p1 <- calcIncoherence(gg,ncores=4)
any(p!=p1)

require(ggplot2)
ggplot(tp, aes(Omnivory)) + geom_density() + theme_bw()

require(ggplot2)
ggplot(tp, aes(Q)) + geom_density() + theme_bw()
ggplot(tp, aes(mTI)) + geom_density() + theme_bw()

tp1<- calcIncoherence(netData[[1]])
tp1$y <- 0
ggplot(tp, aes(Q)) + geom_density() + theme_bw() + geom_point(data=tp1,aes(Q,y))

# generalization = in degree
# vulnerability  = out degree

dn <- list.files("~/Academicos/InconclusedProjects/NetworksAsUnifyingPrinciple/Data",pattern = "^PotterCove.*\\.txt$")
gt <- readMultiplex("~/Academicos/InconclusedProjects/NetworksAsUnifyingPrinciple/Data/PotterCove_Multiplex.txt",format="GLV")

# Number of interaction by type
sapply(gt,ecount)
sapply(gt,vcount)

# Proportion of interactions by type
sapply(gt,ecount)/sum(sapply(gt,ecount))

# Connectivity
sapply(gt,ecount)/(sapply(gt,vcount)*sapply(gt,vcount))

glv <- toGLVadjMat(gt)

sum(glv==-1)   # Competitive + trophic

# Meta-web assembly models package
#
require(meweasmo)

pin  <- calcPropInteractionsGLVadjMat(glv, rep(1,times=nrow(glv)))

# Read the file directly
#
mtm <- read.delim("~/Dropbox/Projects/NetworksAsUnifyingPrinciple/Data/PotterCove_Multiplex.txt")
mtm <- as.matrix(mtm[,2:92])
pin1  <- calcPropInteractionsGLVadjMat(mtm, rep(1,times=nrow(glv)))

# The proportion of types of interactions must be equal
#
pin == pin1

plotTrophLevel(gt[[3]],modules = T)

# Read multiple interaction network in different layers
#

fileName <- c(system.file("extdata",  package = "multiweb"))
dn <- list.files(fileName,pattern = "^Kefi2015.*\\.txt$")
g <- readNetwork(dn,fileName, skipColumn = 2)
gt <- fromIgraphToMgraph(g,c("Negative","Positive","Antagonistic"))

types <- c("Competitive","Mutualistic","Trophic")
gt <- readMultiplex(dn,types,fileName, skipColumn = 2)
tp <- calc_topological_indices(gt)
# how many interactions from each type
#
sapply(gt,ecount)/sum(sapply(gt,ecount))

# Number of species
sapply(gt,vcount)

# Total Connectivity
sum(sapply(gt,ecount))/(106*106)

# Calc multi type interaction QSS
#
calc_QSS(gt)
# QSS    MEing
# 1   0 25.53313

calc_QSS(g[[3]])               # QSS with trophic interactions only should be more stable
#  QSS    MEing
# 1   0 3.055153

#
# Select the first type of interaction
#
nm <- names(gt)
gt[[nm[1]]]

glv <- toGLVadjMat(gt)

sum(glv==-1)   # Competitive + trophic

#
# Simple test
#
g <-   graph_from_literal( 2 -+ 1 +-3,4 -+ 1, 4-+4, 3+-3, 5-+5, 4-+6-+2, 2+-5-+3, simplify = FALSE)
E(g)$type <- "Trophic"
c <- cluster_infomap(as.undirected(g))
plot_troph_level(g,vertexLabel = TRUE,vertexSizeFactor = 20,vertexSizeMin = 12, modules = TRUE, community_obj = c)
plot_troph_level(g,tk=FALSE,vertexLabel = TRUE,vertexSizeFactor = 20,vertexSizeMin = 12, modules = TRUE,vertex.label.color="white",edge.width = 0.3)
plot_troph_level(g,modules =FALSE ,tk=TRUE, vertexLabel = TRUE,vertexSizeFactor = 20)

g1 <-   graph_from_literal(1,2,3, 4 -+ 5, 5-+4,6, simplify = FALSE)
E(g1)$type <- "Competitive"

g2 <-   graph_from_literal(1 -+ 2,2,3,4,5, 6 -+ 3, 3-+6, simplify = FALSE)
E(g2)$type <- "Mutualistic"
g2
#
# Builds an mgraph object
#
mg <- fromIgraphToMgraph(list(g1,g2,g),c("Competitive", "Mutualistic", "Trophic"))

#
# Automatically uses the function toGLVadjMat to calculate the Generalized Lotka-Volterra interaction matrix
# and then calculates the QSS
#
calc_QSS(list(g,g1,g2))
calc_QSS(mg)

#
# Add weights
#
set.seed(1231)
E(g)$weight <- sample(c(.1,.2,.8,.9),gsize(g),replace=TRUE)
E(g1)$weight <- sample(c(.1,.2,.8,.9),gsize(g1),replace=TRUE)
E(g2)$weight <- sample(c(.1,.2,.8,.9),gsize(g2),replace=TRUE)
mg <- fromIgraphToMgraph(list(g1,g2,g),c("Competitive", "Mutualistic", "Trophic"))

calc_QSS(list(g,g1,g2))
calc_QSS(list(g,g1,g2),istrength = TRUE)
calc_QSS(mg)
calc_QSS(mg,istrength = TRUE)

require(meweasmo)

calcPropInteractionsGLVadjMat(glv, rep(1,times=nrow(glv)))

#
# Test network with weights
#
fileName <- "../../Collaborations/NetworkGolfoSanJorge/Data/TTSinPescaInteraccion.dat"
g <- readNetwork(fileName,edgeListFormat=2 )
V(g)[nei(V(g)[name=="POM"],"out")]
V(g)[nei(V(g)[name=="POM"],"in")]
g
g[]
# Get the weights of a predator
g[,"Acanthistius patachonicus"]
# Get the adjacency matrix with weights
as_adjacency_matrix(g,attr="weight",sparse = FALSE)

edge_attr(g,"weight")

#
calc_QSS(g)

glvI <- fromIgraphToMgraph(list(make_empty_graph(n=vcount(g)),make_empty_graph(n=vcount(g)),g) ,c("empty","empty","Antagonistic"))
glv <- toGLVadjMat(glvI,c("empty","empty","Antagonistic"),istrength = TRUE)   #
mean(glv[glv>0])
glv[glv>0] <- glv[glv>0]*0.1
plotTrophLevel(g,vertexLabel = TRUE,vertexSizeFactor = 5,modules = TRUE)

null <- curveBall(g,100)
calc_weighted_topological_indices(null[[1]])
calc_topological_indices(null[[2]])

null <- curveBall(g,100,istrength = TRUE)
calc_weighted_topological_indices(null[[1]])
calc_weighted_topological_indices(null[[2]])

calc_modularity_swness_zscore(g,null)

# Plot a network with two different components as modules
#
g <-   graph_from_literal( 2 -+ 1 +-3,4 -+ 1, 3+-3, 5-+5, 4-+6-+2, 2+-5-+3, simplify = FALSE)
g1 <-   graph_from_literal( 7 -+ 8 +-9,10 -+ 8, 10-+10, 9+-9, 11-+11, 10-+13-+12, 12+-11-+9, simplify = FALSE)

g2 <- g+g1
plotTrophLevel(g2,vertexLabel = TRUE,vertexSizeFactor = 7,modules = TRUE)

# Test quantitative connectance
#
#
# Equal fluxes
m <- matrix(0,nrow=4,ncol=4)
m[1,2] <- m[1,3] <- m[3,4]<- 2
m[2,1] <- m[3,1] <- m[4,3] <- -2
calc_quantitative_connectance(m, c(1,1,1,1))
calcQuantitativeConnectance(m, c(1,1,1,1))
g <- fromGLVadjToIgraph(m,c(1,1,1,1))
print(calcTopologicalIndices(g))
print(calc_topological_indices(g))
plotTrophLevel(g,vertexLabel = T)
# Unequal fluxes
#
m <- matrix(0,nrow=4,ncol=4)
m[1,2] <- m[1,3] <- m[3,4]<- .2
m[2,1] <- m[3,1] <- m[4,3] <- -2
calc_quantitative_connectance(m, c(1,1,1,1))

# Examples from  Ulanowicz, R.E. & Wolff, W.F. (1991). Ecosystem flow networks: Loaded dice? Math. Biosci., 103, 45–68
#
m <- matrix(0,nrow=4,ncol=4)
m[1,2] <- m[2,3] <- m[3,4] <- m[4,1] <- 75
m[1,3] <- m[3,1] <- m[2,4] <- m[4,2] <- 75
calc_quantitative_connectance(m, c(1,1,1,1)) # 0.5, 2
sum(m>0)/(nrow(m)^2)

m <- matrix(0,nrow=4,ncol=4)
m[1,2] <- m[2,3] <- m[3,4] <- m[4,1] <- 50
m[1,3] <- m[3,1] <- m[2,4] <- m[4,2] <- 100
print(calc_quantitative_connectance(m, c(1,1,1,1))) # =0.4724704, 1.889882
sum(m>0)/(nrow(m)^2)

m <- matrix(0,nrow=4,ncol=4)
m[1,2] <-  560
m[1,3] <- m[2,3] <- m[3,4] <- m[4,1] <- m[3,1] <- m[2,4] <- m[4,2] <- 5.66
print(calc_quantitative_connectance(m, c(1,1,1,1))) # =0.4411018, 1.096489
sum(m>0)/(nrow(m)^2)

#
# Test Topological roles
#

sapply(netData,igraph::vcount)

g <- netData[[1]]

tp <- calc_topological_roles(g,nsim=10,ncores=4)

classify_topological_roles(tp,g,plt=TRUE)

#
# Test QSS
#

sapply(netData,vcount)

set.seed(342)
g <- netData[[2]]
g1 <- netData[[18]]
tp <- calc_QSS(list(g,g1),nsim=1000,ncores=48)

# with default values QSS is almost always 0
tp
#  QSS    MEing
#1   0 4.591426
#2   0 2.052344

set.seed(342)
tp <- calc_QSS(list(g,g1),nsim=100,ncores=48,negative=-1,positive=1)
tp
#      QSS      MEing
# 1 0.0005 0.24024671
# 2 0.3224 0.07553226

# Test for differences
#
prop.test(x=tp$QSS*10000, n=c(10000,10000))

#
# test calc_modularity
#

nullg <- generateERbasal(netData[[1]],10)
calc_modularity(nullg)

# with weigths
g <- netData[[1]]
calc_modularity(g)

V(g)$weight <-  runif(vcount(g))
calc_modularity(g,weights = NULL)