##########################################################################
#                          COPYRIGHT & SUPPORT                           #
##########################################################################
#
# FiPSPi-validation: R code for the validation of the results of FiPSPi
# with independent data from the publication (Murgia_et_al_data.txt):
#     Murgia M, (...), Mann M.,
#     Single muscle fiber proteomics reveals unexpected
#     mitochondrial specialization.
#     EMBO Rep. 2015 Mar;16(3):387-95.
#     doi: 10.15252/embr.201439757.
#     Epub 2015 Feb 2. PMID: 25643707.
#
# This code has been developed by Dr. Michael Turewicz at the Ruhr University
# Bochum, Germany. It is licensed under the BSD 3-Clause License provided in
# the file 'LICENSE.txt'.
#
# For support please write an e-mail to 'michael.turewicz[at]rub.de'.
#
# This is the original version of the code written for the publication
# by Eggers et al. 'Deep proteomic characterization of skeletal muscle fiber
# types by laser microdissection and mass spectrometry (...)'. The latest
# version of FiPSPi-validation can be found here:
# https://github.com/mpc-bioinformatics/FiPSPi
#
##########################################################################
#                            USER SETTINGS                               #
##########################################################################

### set path to current working directory
cwd <- "C:/UNI/Publikationen/2021.06.XX_submitted_Britta_Eggers_Fasertypen/FiPSPi"

### set path to data file (relative path to the working directory specified above)
data.path <- paste0(cwd, "/data/Murgia_et_al_data.txt")

### set path to selected features file (relative path to the working directory specified above)
selected.features.path <- paste0(cwd, "/FiPSPi_results/selected_features.txt")

### set output.path where all created output and graphics are saved
output.path <- paste0(cwd, "/FiPSPi-validation_results")

### -------> Note: the above files and folders must already exist and be accessible!

##########################################################################
#                 FURTHER SETTINGS & DEPENDENCIES                        #
##########################################################################
options(scipen=100000)
options(stringsAsFactors=FALSE)

set.seed(1234)

library(randomForest)
library(ROCR)
library(caret)
library(rpart)
library(rpart.plot)

##########################################################################
#                            FUNCTIONS                                   #
##########################################################################

#+++++++++++++++++++++++++++ classify.rf.evaluation +++++++++++++++++++++++++++++++++++++++
classify.rf.evaluation <- function(iteration=NULL, trainset=NULL, testset=NULL, classes_train=NULL,
                                   classes_test=NULL, label1="A", label2="B", label3 = "C", output.path=NULL, ...){
  if(is.null(trainset) || is.null(testset)) {
    stop("ERROR: Not all mandatory arguments have been defined!")
  }

  train.dat <- t(as.matrix(trainset))
  test.dat <- t(as.matrix(testset))

  model.rf <- randomForest(x=train.dat, y=classes_train, importance=TRUE, keep.forest=TRUE)
  pred.rf <- predict(object=model.rf, newdata=test.dat, type="response", norm.votes=TRUE)
  confusion <- table(observed = classes_test, predicted = pred.rf)

  ### class 1:
  TP <- confusion[1,1]
  FN <- confusion[1,2]+confusion[1,3]
  FP <- confusion[2,1]+confusion[3,1]
  TN <- confusion[2,2]+confusion[2,3]+confusion[3,2]+confusion[3,3]
  ACCURACY1 <- {TP+TN}/{TP+FP+TN+FN}
  SENSITIVITY1 <- TP/{TP+FN}   #=TPR
  SPECIFICITY1 <- TN/{TN+FP}  #=(1-FPR)

  ### class 2:
  TP <- confusion[2,2]
  FN <- confusion[2,1]+confusion[2,3]
  FP <- confusion[1,2]+confusion[3,2]
  TN <- confusion[1,1]+confusion[1,3]+confusion[3,1]+confusion[3,3]
  ACCURACY2 <- {TP+TN}/{TP+FP+TN+FN}
  SENSITIVITY2 <- TP/{TP+FN}   #=TPR
  SPECIFICITY2 <- TN/{TN+FP}  #=(1-FPR)

  ### class 3:
  TP <- confusion[3,3]
  FN <- confusion[3,1]+confusion[3,2]
  FP <- confusion[1,3]+confusion[2,3]
  TN <- confusion[1,1]+confusion[1,2]+confusion[2,1]+confusion[2,2]
  ACCURACY3 <- {TP+TN}/{TP+FP+TN+FN}
  SENSITIVITY3 <- TP/{TP+FN}   #=TPR
  SPECIFICITY3 <- TN/{TN+FP}  #=(1-FPR)

  ACCURACY_total <- sum(diag(confusion))/ sum(confusion) # total Accuracy
  SENSITIVITY_total <- (SENSITIVITY1 + SENSITIVITY2 + SENSITIVITY3) / 3
  SPECIFICITY_total <- (SPECIFICITY1 + SPECIFICITY2 + SPECIFICITY3) / 3

  results <- c(acc_total = ACCURACY_total, sens_total = SENSITIVITY_total, spec_total = SPECIFICITY_total,
               acc1 = ACCURACY1,  sens1 = SENSITIVITY1, spec1 = SPECIFICITY1,
               acc2 = ACCURACY2,  sens2 = SENSITIVITY2, spec2 = SPECIFICITY2,
               acc3 = ACCURACY3,  sens3 = SENSITIVITY3, spec3 = SPECIFICITY3)

  return(results)
}
#+++++++++++++++++++++++++++ classify.rf.evaluation +++++++++++++++++++++++++++++++++++++++

##########################################################################
#                               MAIN                                     #
##########################################################################

#-----------------------------> Begin: Data Import & Pre-Processing

dat <- read.table(data.path, sep="\t", header=TRUE, na.strings = "NA")
colnames(dat) <- gsub("Type\\.I", "Type I", colnames(dat))

label1 <- "Type I"
#label2 <- "Type IIa"
label3 <- "Type IIb"
label4 <- "Type IIx"

# Exclusion of 6 samples due to following criteria:
# -	Samples without predominant Myh-isoform and/or without unambiguous fiber-type in the column 'Fiber type, renamed'
# -	Samples with at least one missing value for the peptides to be validated
# -	After the first two exclusion criteria group 'Type IIa' has only 3 samples --> group too small --> exclusion of complete group
# -	Samples with weakly predominant Myh-isoform and which were outliers in PCA
dat <- dat[,-match(c("Type I_9", "Type IIb_1", "Type IIb_3", "Type IIb_6", "Type IIx_5", "Type IIx_7"), colnames(dat))]

group1 <- grep("Type I_", colnames(dat), value=TRUE)
#group2 <- grep("Type IIa_", colnames(dat), value=TRUE)
group3 <- grep("Type IIb_", colnames(dat), value=TRUE)
group4 <- grep("Type IIx_", colnames(dat), value=TRUE)
n1 <- length(group1)
#n2 <- length(group2)
n3 <- length(group3)
n4 <- length(group4)

descriptive.columns <- dat[,1:5]
selected.features <- read.table(selected.features.path, sep="\t", header=TRUE, na.strings = "NA")
rownames(descriptive.columns) <- selected.features[,"Sequence"]
#rownames(descriptive.columns) <- c("Q5SX40_peptide40", "O88990_peptide38")
rownames(dat) <- rownames(descriptive.columns)
write.table(x=cbind(rownames(descriptive.columns),descriptive.columns), file=paste0(output.path, "/descriptive.columns.txt"), sep="\t", col.names=TRUE, row.names=FALSE)

dat <- log2(data.matrix(dat))
dat <- dat[,c(group1,group3,group4)]
write.table(x=cbind(rownames(dat),dat), file=paste0(output.path, "/original_data.txt"), sep="\t", col.names=TRUE, row.names=FALSE)

#-----------------------------> Begin: Data Import & Pre-Processing

#-----------------------------> Begin: Diff. Analysis

classes <- gsub("\\_\\d+", "", colnames(dat))
rawdat <- 2^dat
p.values <- vector(mode="numeric", length=nrow(dat))
max.mean.ratios <- vector(mode="numeric", length=nrow(dat))
for(i in 1:nrow(dat)){
  p.values[i] <- summary(aov(dat[i,] ~ classes))[[1]][["Pr(>F)"]][1]

  mean.ratio1 <- max( mean(rawdat[i,group1])/mean(c(rawdat[i,group3], rawdat[i,group4])), mean(c(rawdat[i,group3], rawdat[i,group4]))/mean(rawdat[i,group1]) )
  mean.ratio3 <- max( mean(rawdat[i,group3])/mean(c(rawdat[i,group1], rawdat[i,group4])), mean(c(rawdat[i,group1], rawdat[i,group4]))/mean(rawdat[i,group3]) )
  mean.ratio4 <- max( mean(rawdat[i,group4])/mean(c(rawdat[i,group1], rawdat[i,group3])), mean(c(rawdat[i,group1], rawdat[i,group3]))/mean(rawdat[i,group4]) )
  max.mean.ratios[i] <- max(mean.ratio1, mean.ratio3, mean.ratio4)
}
p.values.adj <- p.adjust(p.values, method="fdr")
names(p.values.adj) <- rownames(dat)
diff.analysis.output <- cbind(names(p.values.adj), p.values, p.values.adj, max.mean.ratios)
colnames(diff.analysis.output) <- c("Feature", "P-value (Anova)", "Adj. p-value", "Max. mean ratio")
write.table(file=paste0(output.path, "/diff_analysis_output.txt"), x=diff.analysis.output,
            row.names=FALSE, col.names=TRUE, sep="\t")

#-----------------------------> End: Diff. Analysis

#-----------------------------> Begin: Validation with Test Set

### 1000 times train/test split for model validation
testruns <- 1000
features <- rownames(dat)
all.idx <- colnames(dat)
#perf.final <- vector("list", testruns)
perf.final <- matrix(nrow =  testruns, ncol = 12)
colnames(perf.final) = c("acc_total", "sens_total", "spec_total",
  "acc1",  "sens1", "spec1",
  "acc2",  "sens2", "spec2",
  "acc3",  "sens3", "spec3")

for(i in 1:testruns){
  cat("final classification: ", i, "\r")
  test.idx1 <- sample(group1, 3)  # n1=10
  #test.idx2 <- sample(group2, 1)  # n2=3
  test.idx3 <- sample(group3, 5)  # n3=15
  test.idx4 <- sample(group4, 3)  # n4=10
  #test.idx <- c(test.idx1, test.idx2, test.idx3, test.idx4)
  test.idx <- c(test.idx1, test.idx3, test.idx4)

  train.idx <- setdiff(all.idx, test.idx)

  classi <- classify.rf.evaluation(iteration=i, trainset=dat[features,train.idx,drop=FALSE],
                                   testset=dat[features,test.idx,drop=FALSE],
                                   classes_train=as.factor(gsub("\\_\\d+", "", train.idx)),
                                   classes_test=as.factor(gsub("\\_\\d+", "", test.idx)),
                                   label1="Type I", label2="Type IIb", label3="Type IIx", output.path=NULL,
                                   nrounds = best.nrounds, max_depth = best.max_depth)
  perf.final[i,] <- classi
}

write.table(perf.final, file = paste0(output.path, "/validation.txt"), row.names = FALSE, sep = "\t")

#-----------------------------> End: Validation with Test Set

#-----------------------------> Begin: PCA

pca.dat <- dat[features,]

group.vec <- c(
  "Type I",
  "Type IIb",
  "Type IIx"
)

col.vec <- c(
  adjustcolor("navy", alpha=0.3),
  adjustcolor("red", alpha=0.3),
  adjustcolor("darkorchid", alpha=0.3),
  adjustcolor("darkgreen", alpha=0.3)
)

pcdat <- prcomp(t(pca.dat), center=TRUE, scale=TRUE)
scores <- pcdat$x
for (i in 1:2){
  for (j in i:2){
    if (i<j){
      XLIM <- c(-max(abs(scores[,i])), max(abs(scores[,i])))
      XLIM <- XLIM+(XLIM*0.1)
      YLIM <- c(-max(abs(scores[,j])), max(abs(scores[,j])))
      YLIM <- YLIM+(YLIM*0.1)
      png(paste(output.path, "/01_pca_", i, "_", j, "_selectedFeatures.png", sep=""), width=3600, height=3600, pointsize=15, res=600)
      plot(scores[group1,i], scores[group1,j], xlab=paste("PC", i, sep=""), ylab=paste("PC", j, sep=""), xlim=XLIM, ylim=YLIM, pch=20, col=col.vec[1], main="PCA", cex=2)
      points(scores[group3,i], scores[group3,j], pch=20, col=col.vec[3], cex=2)
      points(scores[group4,i], scores[group4,j], pch=20, col=col.vec[4], cex=2)
      legend("topleft", legend=group.vec[1:3], col=col.vec[c(1,3,4)], pch=20, cex=0.75, bg="transparent")
      dev.off()
    }
  }
}

for (i in 1:2){
  for (j in i:2){
    if (i<j){
      XLIM <- c(-max(abs(scores[,i])), max(abs(scores[,i])))
      XLIM <- XLIM+(XLIM*0.1)
      YLIM <- c(-max(abs(scores[,j])), max(abs(scores[,j])))
      YLIM <- YLIM+(YLIM*0.1)
      png(paste(output.path, "/02_pca_", i, "_", j, "_selectedFeatures.png", sep=""), width=3600, height=3600, pointsize=15, res=600)
      plot(scores[group1,i], scores[group1,j], xlab=paste("PC", i, sep=""), ylab=paste("PC", j, sep=""), xlim=XLIM, ylim=YLIM, pch=20, col=col.vec[1], main="PCA", cex=2)
      points(scores[group3,i], scores[group3,j], pch=20, col=col.vec[3], cex=2)
      points(scores[group4,i], scores[group4,j], pch=20, col=col.vec[4], cex=2)
      text(scores[group1,i], scores[group1,j], labels=group1, col="navy", cex=0.4)
      text(scores[group3,i], scores[group3,j], labels=group3, col="darkorchid", cex=0.4)
      text(scores[group4,i], scores[group4,j], labels=group4, col="darkgreen", cex=0.4)
      legend("topleft", legend=group.vec[1:3], col=col.vec[c(1,3,4)], pch=20, cex=0.75, bg="transparent")
      dev.off()
    }
  }
}

#-----------------------------> End: PCA

#-----------------------------> Begin: Boxplots

for(i in 1:length(features)){
  idx <- match(features[i], rownames(dat))
  seq <- descriptive.columns[features[i],1]
  current.p.value <- formatC(p.values.adj[idx], format = "e", digits = 2)
  png(paste0(output.path,"/boxplot_", i, "_", features[i], ".png"), width=2000, height=2000, pointsize=15, res=300)
    boxplot(dat[features[i],group1], dat[features[i],group3], dat[features[i],group4], main=paste0(seq, "\np-value: ", current.p.value), names=c(label1, label3, label4), col=col.vec[c(1,3,4)], cex.axis=1.5, cex.main=1.5)
  dev.off()
}

#-----------------------------> End: Boxplots

#-----------------------------> Begin: Decision Tree

col.list <- list(
  adjustcolor("navy", alpha=0.3),
  adjustcolor("darkorchid", alpha=0.3),
  adjustcolor("darkgreen", alpha=0.3)
)
rpartdat <- data.frame(classes, t(dat[features,]), stringsAsFactors=TRUE)
for(i in 1:length(features)){
  colnames(rpartdat)[i+1] <- descriptive.columns[features[i],1]
}
rpart.model <- rpart(classes~., data=rpartdat, method="class")
png(paste0(output.path,"/rpart-plot.png"), width=2000, height=2000, pointsize=15, res=300)
    rpart.plot(rpart.model, roundint=FALSE,type=2,extra=101,box.palette=col.list)
dev.off()

#-----------------------------> End: Decision Tree


# load library
library(plotly)
library(dplyr)

# the function takes a dataframe and colorvar as variable
# and returns a barchart listing top 100 donation to specific candidate
BuildBarchart <- function(map.df, colorvar, candidate.name) {

  # margin setting
  m <- list(l = 50, r = 50, b = 280, t = 100, pad = 4)

  # use string name as variable name

  # chart 1: barchart

  # arrange bar with total contribution desc
  map.df$name <- factor(map.df$name,
                        levels = map.df$name[order(map.df$total,decreasing = TRUE)])

  # build barchart with hover text of organization name, industry and total donation
  bar <- map.df %>% plot_ly(x = ~name, y = ~total, type = 'bar',
                       color = eval(parse(text = colorvar)),
                       width = 1200, height = 1000,
                       text = ~paste0('Organization: ', name, '
',
                                      'Industry: ', industry, '
',
                                      '$', total)) %>%
    layout(margin = m, autosize = F, title = paste0('Top 100 Contributions to ', candidate.name))

  return(bar)
}

# chart 2: map
# the function takes dataframe as variable
# and returns a map showing where are the top 100 donations coming from
BuildMap <- function(map.df) {

  # geo setting
  g <- list(
    scope = 'usa',
    projection = list(type = 'albers usa'),
    showland = TRUE,
    landcolor = toRGB("gray95"),
    subunitcolor = toRGB("gray85"),
    countrycolor = toRGB("gray85"),
    countrywidth = 0.5,
    subunitwidth = 0.5
  )

  # build map with color bar showing the number of contribution
  map <- map.df %>% plot_geo(lat = ~Latitude, lon = ~Longitude) %>%
    add_markers(
      hoverinfo = 'text',
      size = ~total, color = ~total, opacity = 0.8,
      text = ~paste0(name, '
',
                     industry, '
 ', '# of records' ,records, '
 ',
                     '$',total)) %>%
    layout(title = 'Location of Top 100 Contribution
(Hover for details)', geo = g)

  return(map)
}

# chart 3: pie chart
# this function takes a dataframe as variable
# and returns a pie chart showing the parcentage of each industry's contribution
BuildPie <- function(pie.df) {

  # build piechart
  pie <- pie.df %>% plot_ly(labels = ~industry, values = ~percent, type = 'pie',
                       textposition = 'inside',
                       textinfo = 'label+percent',
                       hoverinfo = 'text',
                       text = ~paste0(industry, '
',
                                      '$', total),
                       width = 800, height = 800) %>%
    layout(title = 'Percentage of Industry Contribution')

  return(pie)
}


#!/usr/bin/Rscript
#===============================================================================
#  Copyright (c)   berrygenomics 2015
#
#  DESCRIPTION: 包括几个处理过程：1，合并bin  2，去除异常GC的bin 3，去除低复杂度的bin
#               4，去除低覆盖度的bin  5，如果需要，则进行GC校正
#
#      OPTIONS: ---
#         BUGS: ---
#        NOTES: ---
#       AUTHOR: sunhy
#         MAIL: sunhuaiyu@berrygnomics.com
#      VERSION: 2.0
#      CREATED:
#===============================================================================
library(getopt)
Spec <- matrix(c(
    'rcfile',    'r', 1, 'character', 'the reads count file path,            must',
    'gcfile',    'g', 1, 'character', 'the GC count file path,               must',
    'outdir',    'o', 1, 'character', 'the output dir path,                  must',
    'complexity','c', 2, 'character', 'the bins low-complexity matrix path,  option',
    'Merge',     'M', 2, 'integer',   'merge some bins to one,               default 5',
    'gccorrect', 'G', 0, 'integer',   'whether do GC correction,             default no',
    'help',      'h', 0, 'logical',   'This help'
), byrow=TRUE, ncol=5)
opt <- getopt(Spec)
# if help was asked for print a friendly message
# and exit with a non-zero error code
if ( !is.null(opt$help) | is.null(opt$rcfile) | is.null(opt$gcfile) | is.null(opt$outdir)) {
    cat(getopt(Spec, usage=TRUE));
    q(status=1);
}
# set options
if (is.null(opt$Merge)) { opt$Merge <- 5 }
if (is.null(opt$gccorrect)) {opt$gccorrect <- FALSE } else { opt$gccorrect <- TRUE }
BIN_LENGTH <- 20000   # the bins of the RD matrix are 20K

if ( !file.exists(opt$outdir) ) dir.create( path=opt$outdir )
## file name : /file/path/14C01700_L6_I333.R1.clean.fastq.gz.20K.txt
prefix <- strsplit(basename(opt$rcfile), '[.]', perl=T)
outprefix = paste(opt$outdir, '/', prefix[[1]][1], sep='')

logfile = paste(outprefix, '.filter.log', sep='')
if (file.exists(logfile)) { file.remove(logfile) }

############## processing start
## read
RC <- as.matrix(read.table(opt$rcfile, header=F, stringsAsFactors=F, row.names=1, sep='\t'))
GC <- as.matrix(read.table(opt$gcfile, header=F, stringsAsFactors=F, row.names=1, sep='\t'))

## only analysis autosome
RC <- RC[1:22, ]
GC <- GC[1:22, ]

## constructing a new matrix according to the merge number, the final left bins will be persist
library(zoo)
RC <- t(apply(RC, 1, FUN=function(x){ rollapply(x, width=opt$Merge, by=opt$Merge, FUN=sum, partial=T, align='left')} ))
GC <- t(apply(GC, 1, FUN=function(x){ rollapply(x, width=opt$Merge, by=opt$Merge, FUN=sum, partial=T, align='left')} ))

## transform GCs to GC rate (percentage), every reads length are 36.
GC <- 100 * GC / ( RC * 36 )
GC[is.nan(GC)] <- 0
GC <- round(GC, 2)

cat('The matrix dim', dim(RC), end='\n', file=logfile)
cat('usefull bins:', sum(RC != 0), end='\n', file=logfile, append=T)

## filter some extreme GC value and extreme RC, remove bins GC percent > 80% or < 20%
cat('remove extreme GC bins:', sum(GC != 0 & (GC<20 | GC>80)), end='\n', file=logfile, append=T)

GC[GC < 20 | GC > 80] <- NA
RC[is.na(GC)] <- NA

## filter low-complexity bins, remove bins which have more 80% repeat regions(considered as low-complexity DNA bin)

if (!is.null(opt$complexity)) {
    Complex_data <- as.matrix(read.table(opt$complexity, header=F, row.names=1, stringsAsFactors=F))
    Complex_data <- Complex_data[1:22, ]
    Complex_data <- t(apply(Complex_data, 1, FUN=function(x){
        rollapply(x, width=opt$Merge, by=opt$Merge, FUN=sum, partial=T, align='left')
        } ))

    if (nrow(RC) != nrow(Complex_data) | ncol(RC) != ncol(Complex_data)) {
        cat('Warning: the complexity file has not same dim', end='\n', file=stderr())
        quit(status=1)
    }
    Complex_data <- Complex_data/(BIN_LENGTH * opt$Merge)
    OutLier <- Complex_data > 0.8   # 80%
    cat('remove low-complexity bins:', sum(OutLier), end='\n', file=logfile, append=T)
	cat('low-complexity bins RD:', RC[OutLier], end='\n', file=logfile, append=T)
	cat('low-complexity bins RD mean:', mean(RC[OutLier]), end='\n', file=logfile, append=T)
    RC[OutLier] <- NA
    GC[OutLier] <- NA
}

## plot RCs density, and remove low-coverage bins, remove x < 1/3 of peak value
density_plot <- function(data, rate, main='RC density distribution') {
	Den <- density(data, na.rm=T)
	plot(Den, type='o', xlab='after RC', ylab='density', col='#4682B4', axes=T, xpd=F, pch=1, font.lab=1,2,
		 font.main=2, font.axis=1, lwd=2, cex.lab=1.5, cex.main=1.5, cex.axis=1, cex.sub=1, cex=0.5,
		 main=main)
	den_y_peak <- max(Den$y)
	den_x_peak <- Den$x[Den$y == den_y_peak]
	segments(den_x_peak, den_y_peak, den_x_peak, 0, col='black', lwd=1, lty=2)
	rm_cutoff <- den_x_peak * rate
	segments(rm_cutoff, den_y_peak, rm_cutoff, 0, col='red', lwd=2)
	legend('topright', legend=c(sprintf('Mean: %.4f', mean(data, na.rm=T)),
		 sprintf('Max density: %.4f', den_x_peak), sprintf('%.3f max density: %.4f', rate, rm_cutoff)),
		 cex=0.8,inset = 0.01)
	box()
	rm_cutoff
}

## GC cerrection: get loess curve
loessFit <- function(outprefix, rc, gc){
    rc <- as.vector(rc)
    rc <- rc[!is.na(rc)]
    gc <- as.vector(gc)
    gc <- gc[!is.na(gc)]

    png(file=paste(outprefix, '.GCcorrelation_before.png', sep=''), height=600, width=900)
    par(mar=c(5.1,4.5,4.1,2.1), mgp=c(3,1,0), ps=15)
    plot(gc, rc, main='Correlation between GC% and Read count', xlab='CG%', ylab='Read count', col='#A0522D',
        cex.lab=1.5, cex.main=1.5, cex.axis=1, cex.sub=1, cex=0.5, font.lab=1.2, font.main=2, font.axis=1, lwd=1,
        ylim=c(0, max(rc, na.rm=T)), xlim=c(10, 90), pch=21
    )

#	## fast loess
#	RC.bins.median <- tapply(rc, gc, function(x) median(x, na.rm=T))
#	GC.Levels <- as.numeric(names(RC.bins.median))
#	Loess <- loess(RC.bins.median ~ GC.Levels)
#   loess.fittedRC  <- predict( Loess, GC.Levels)
#	lines(GC.Levels, loess.fittedRC, col=3, lwd=2)

    ## normal loess
    Loess <- loess(rc ~ gc)
    loess.fittedRC  <- predict( Loess, gc[order(gc)])
    lines(gc[order(gc)], loess.fittedRC, col=3, lwd=2)

    # Lowess<-lowess(DF,f=0.05,delta=0.001)
    # lines(Lowess,col=4,lwd=2)

    M <- median(rc)
    segments(min(gc), M, max(gc), M, col=1, lwd=2, lty=2)
    legend('topright', c('loess'), col=c(3,4), lty = 1, pch = 20, inset = .02)
    dev.off()
    cat('Done loessFit\n',file=stderr())
    Loess
}

## rmove low coverage bins

pdf(file=paste(outprefix, 'RC_density.pdf', sep='_'), width=12, height=9)
par(mfrow=c(3,1), lend=1)
cutOff <- density_plot(RC, 1/3)
for (i in c(1:22)) {
	density_plot(RC[i, ], 1/3, paste('Rc density by chr', i, sep=''))
}
dev.off()
cat('Done plot \n', file=stderr())
cat('remove low-coverage bins:', sum( !is.na(RC) & RC < cutOff ), end='\n', file=logfile, append=T)
RC[!is.na(RC) & RC<cutOff] <- NA
GC[is.na(RC)] <- NA

cat('finally, persist bins:', sum(!is.na(RC)), end='\n', file=logfile, append=T)

if (opt$gccorrect) {
    MedianRC <- median(RC, na.rm=T)
    Loess <- loessFit(outprefix, RC, GC)
    loessFited <- predict( Loess, as.vector(GC))

    # RCgcCorrection <- ( MedianRC / loessFited ) * RC
    RCgcCorrection <- RC + ( MedianRC - loessFited)

    RCgcCorrection[!is.na(RCgcCorrection) & RCgcCorrection <= 0] <- NA

    ## after GC correction, RC distribution
    png(file=paste(outprefix, '.GCcorrelation_after.png', sep=''), height=600, width=900)
    plot(GC, as.vector(RCgcCorrection), main='after Correlation between GC% and Read count',
        xlab='CG%', ylab='Read count', col='#A0522D', cex.lab=1.5, cex.main=1.5, cex.axis=1, cex.sub=1, cex=0.5,
        font.lab=1.2, font.main=2, font.axis=1, lwd=1, ylim=c(0, max(RC, na.rm=T)), xlim=c(10, 90), pch=21
    )
    dev.off()

    cat('Done GC Correction\n', file=stderr())

    ## out after GC correction, RC matrix
    RCgcCorrection.tatal.reads <- sum(RCgcCorrection, na.rm=T)
    Matrixoutfile <- paste(outprefix, '.gc.filter.', opt$Merge * 20, 'K.txt', sep='')
    if (file.exists(Matrixoutfile)) { unlink(Matrixoutfile) }
    cat(paste('#uniqMapped', round(RCgcCorrection.tatal.reads, 2), sep='\t'), end='\n', file=Matrixoutfile)
    rownames(RCgcCorrection) <- paste('chr', c(1:22), sep='')
    write.table(RCgcCorrection, file=Matrixoutfile, col.names=F, row.names=T, append=T, quote=F, sep='\t')

    ## every chr's dis
    pdf(file=paste(outprefix, '.chromosome_dis.pdf', sep=''), height=9, width=12)
    par(mfrow=c(3, 1), lend=1)
    for (i in c(1:22)) {
       Chrs <- RCgcCorrection[i, ]
       last <- max(which(!is.na(Chrs)))
       x <- seq(1, last)
       plot(x * opt$Merge * BIN_LENGTH / 1000000, Chrs[x], type='h', xlab='pos(M)', ylab='reads count', col='gray', main=rownames(RCgcCorrection)[i])
    }
    dev.off()
}else{
    ## out after filtered RC matrix
    RCgcCorrection.tatal.reads <- sum(RC, na.rm=T)
    Matrixoutfile <- paste(outprefix, '.filter.', opt$Merge * 20, 'K.txt', sep='')
    if (file.exists(Matrixoutfile)) { unlink(Matrixoutfile) }
    cat(paste('#uniqMapped', round(RCgcCorrection.tatal.reads, 2), sep='\t'), end='\n', file=Matrixoutfile)
    rownames(RC) <- paste('chr', c(1:22), sep='')
    write.table(RC, file=Matrixoutfile, col.names=F, row.names=T, append=T, quote=F, sep='\t')

    ## every chr's dis
    pdf(file=paste(outprefix, '.chromosome_dis.pdf', sep=''), height=9, width=12)
    par(mfrow=c(3,1), lend=1)
    for (i in c(1:22)) {
        Chrs <- RC[i, ]
        last <- max(which(!is.na(Chrs)))
        x <- seq(1, last)
        plot(x * opt$Merge * BIN_LENGTH / 1000000, Chrs[x], type='h', xlab='pos(M)', ylab='reads count', col='gray', main=rownames(RC)[i])
    }
    dev.off()
}


install.packages("viridis")

library(viridis)

source("../utility_scripts/data_prep.r")
source("../utility_scripts/annotation_defaults.r")

data <- scent_data %>%
  select(year, level, trial) %>%
  distinct(trial, .keep_all=TRUE)

plot <- ggplot(data = data) +
  geom_bar(
    mapping = aes(y = year, fill = fct_relevel(level, c("L3", "L2", "L1", "Summit", "Elite", "NW3", "NW2", "NW1"))),
    position = "fill") +
  coord_cartesian(ylim=c(2009, 2021)) +
  scale_y_continuous(breaks=seq(2009, 2021, 1)) +
  scale_x_continuous(breaks=seq(0, 1, 0.25), labels=c("", "25%", "50%", "75%", "100%")) +
  scale_fill_viridis(option="turbo", name="Competition\nLevel", discrete=TRUE) +
  theme_void() +
  theme(
    legend.position = 'right',
    axis.title.y = element_blank(),
    axis.text = element_text(size = 9)
  )

annotated_plot <- getAnnotatedPlot(
  plot,
  title="NACSW Trials by Level",
  subtitle="Percentage of trials every year by competition level")
annotated_plot

ggsave("trials_by_level.png", plot=annotated_plot, path=".", width=4194, height=3226, units="px", bg="white")


pdf('output.DupRate_plot.pdf')
par(mar=c(5,4,4,5),las=0)
seq_occ=c(1)
seq_uniqRead=c(40)
pos_occ=c(1)
pos_uniqRead=c(40)
plot(pos_occ,log10(pos_uniqRead),ylab='Number of Reads (log10)',xlab='Occurrence of read',pch=4,cex=0.8,col='blue',xlim=c(1,500),yaxt='n')
points(seq_occ,log10(seq_uniqRead),pch=20,cex=0.8,col='red')
ym=floor(max(log10(pos_uniqRead)))
legend(300,ym,legend=c('Sequence-based','Mapping-based'),col=c('blue','red'),pch=c(4,20))
axis(side=2,at=0:ym,labels=0:ym)
axis(side=4,at=c(log10(pos_uniqRead[1]),log10(pos_uniqRead[2]),log10(pos_uniqRead[3]),log10(pos_uniqRead[4])), labels=c(round(pos_uniqRead[1]*100/sum(pos_uniqRead*pos_occ)),round(pos_uniqRead[2]*100/sum(pos_uniqRead*pos_occ)),round(pos_uniqRead[3]*100/sum(pos_uniqRead*pos_occ)),round(pos_uniqRead[4]*100/sum(pos_uniqRead*pos_occ))))
mtext(4, text = "Reads %", line = 2)
dev.off()


# Stand-alone script that takes a mask from timeseries-based cleaning and applies it to a given set of files
#
# Inputs: QC mask brick, virtual stack to apply it to
# Output: Cleaned brick of layers
library(raster); source("utils/set-temp-path.r")
library(probaV)
library(foreach)
library(doParallel)
library(iterators)
library(tools)

QCMaskFile = "../../userdata/composite/tscleaned/ts-mask-whole-optimised.tif"
CloudyFileDirectory = "../../userdata/semicleaned/ndvi/"
CloudyFilePattern = "NDVI_sm.tif$"
TileOfInterest = "X20Y01"
CleanDirectory = "../../userdata/cleaned/ndvi/"

CloudyVrt = timeVrtProbaV(CloudyFileDirectory, pattern = CloudyFilePattern,
    vrt_name = tempfile("CloudyVrt", rasterOptions()$tmpdir, ".vrt"),
    tile = TileOfInterest, return_raster = TRUE)
QCMask = brick(QCMaskFile)

if (nlayers(CloudyVrt) != nlayers(QCMask))
    stop("Number of layers does not match!")
LayerNames = names(QCMask) = names(CloudyVrt)

# One thread eats around 840 MB max, so limit to 20 cores for 16 GiB
# Alternatively, set rasterOptions() memory settings
Cores = 20
psnice(value = min(Cores - 1, 19))
registerDoParallel(cores = Cores)
foreach(i=iter(LayerNames), .packages = "raster", .verbose = TRUE, .inorder = FALSE) %dopar%
{
    mask(CloudyVrt[[i]], QCMask[[i]], maskvalue=c(2,0),
        filename=paste0(CleanDirectory, i), datatype="FLT4S", progress="text",
        options=c("COMPRESS=DEFLATE", "ZLEVEL=9"))
}


source("/home/kshah2/qqplots.R")
predixcanassociation<-function(co,tis,alpha) {
    #cohorts<-c("T2D")
    #alpha<-1
    #tissues<-c("Thyroid","Adipose-Visceral-Omentum") #"Adipose-Subcutaneous","WholeBlood","Brain-Cerebellum","Brain-Hypothalamus","Liver","Muscle-Skeletal","Pancreas","Pituitary","SmallIntestine-TerminalIleum","Stomach","Colon-Sigmoid","Nerve-Tibial","Colon-Transverse",)
    #for (tis in tissues) {
    #for (co in cohorts) {
    #control1<-read.table(paste("/group/im-lab/nas40t2/kaanan/PrediXcan/WTCCC/",co,"/PrediXcan/GTExTissues/PredictedExpression_","58C","_",tis,"_EN",alpha,".txt",sep=""),header=T)
    #control1[(dim(control1)[1]+1),]<-c(NA,rep(0,(dim(control1)[2]-1)))
    #control2<-read.table(paste("/group/im-lab/nas40t2/kaanan/PrediXcan/WTCCC/",co,"/PrediXcan/GTExTissues/PredictedExpression_","NBS","_",tis,"_EN",alpha,".txt",sep=""),header=T)
    #control2[(dim(control2)[1]+1),]<-c(NA,rep(0,(dim(control2)[2]-1)))
    #control<-merge(control1,control2,by.x=1,by.y=1,all.x=F,all.y=F)
    scorefile = paste("/group/im-lab/nas40t2/kaanan/PrediXcan/WTCCC/",co,"/PrediXcan/PredictedExpression_",co,"_",tis,"_EN",alpha,".txt",sep="")
    preds<-read.table(scorefile,header=T)
    phenorow<-dim(preds)[1]+1
    preds[phenorow,]<-c(NA,rep(1,(dim(preds)[2]-1)))
    preds[phenorow,grep("58C",colnames(preds))]<-0
    preds[phenorow,grep("NBS",colnames(preds))]<-0
    #dat<-merge(preds,control,by.x=1,by.y=1,all.x=F,all.y=F)
    dat<-preds
    OUT<-NULL
    for (i in 1:(dim(dat)[1]-1)) {
        testpheno<-as.numeric(as.vector(t(dat[phenorow,-1])))
        geneexp<-as.numeric(as.vector(t(dat[i,-1])))
        tmp = coef(summary(glm(testpheno~geneexp,family="binomial",maxit=10)))[c(2,6,8)]
        tmp<-c(as.character(dat$gene[i]),tmp)
        OUT<-rbind(OUT,tmp)
    }
    outfile = paste("/group/im-lab/nas40t2/kaanan/PrediXcan/WTCCC/",co,"/PrediXcan/PrediXcan_",co,"_",tis,"_EN",alpha,".txt",sep="")
    colnames(OUT)<-c("gene","beta","z-stat","p-val")
    write.table(OUT,outfile,col.names=T,row.names=F,quote=F)
    jpeg(paste("/group/im-lab/nas40t2/kaanan/PrediXcan/WTCCC/",co,"/PrediXcan/PrediXcan_",co,"_",tis,"_EN",alpha,".jpeg",sep=""))
    qqunif(OUT[,4],plot=T)
    dev.off()
}
#}
#}


code 'str_liquid'
name '流动性缺口'
dimensions {
	accbook null
	liquidGap null
}
dataRequest {
	table 'sceLiquid',{
		allDimensions (['accbook','liquidGap'])
	}
	fields 'accbook,liquidGap,principal value'
	contextParams (['stress'])
}

derivedHeads{
    accbook ([
			new Head(name:'流动性缺口',aggregate:true,
				formula:{
					def grids=thisColGrids({parent==null})
					def a=grids.find{it.rowHeadGrid.model?.alType=='A'}
					def l=grids.find{it.rowHeadGrid.model?.alType=='L'}
					if(a && l){
						a-l
					}
				}
			),
			new Head(name:'缺口累计',aggregate:true,
				formula:{
					(col==0)? higher:(left+higher)
                })
		])
}
dataGrids {
    apply selectRows({children!=null}),{
		formula {sumChildren()}
	}

}


library(quanteda)
library(data.table)

getNgramFreqs <- function(ng, dat, ignores=NULL, sort.by.ngram=TRUE, sort.by.freq=FALSE) {
  # http://stackoverflow.com/questions/36629329/
  # how-do-i-keep-intra-word-periods-in-unigrams-r-quanteda
  if(is.null(ignores)) {
    dat.dfm <- dfm(dat, ngrams=ng, toLower = FALSE, removePunct = FALSE,
                   what = "fasterword", verbose = FALSE)
  } else {
    dat.dfm <- dfm(dat, ngrams=ng, toLower = FALSE, ignoredFeatures=ignores,
                   removePunct = FALSE, what = "fasterword", verbose = FALSE)
  }
  rm(dat)
  # quanteda docfreq will get the document frequency of terms in the dfm
  ngram.freq <- docfreq(dat.dfm)
  if(sort.by.freq) { ngram.freq <- sort(ngram.freq, decreasing=TRUE) }
  if(sort.by.ngram) { ngram.freq <- ngram.freq[sort(names(ngram.freq))] }
  rm(dat.dfm)

  return(ngram.freq)
}

getNgramTables <- function(ng, linesCorpus, prefixFilter=NULL) {
  start_msg <- paste0("START getNgramTables building ", ng,
                      "-gram frequency table at ",
                      as.character(Sys.time()), "\n")
  cat(start_msg)
  ngrams <- getNgramFreqs(ng, linesCorpus)
  ngrams_dt <- data.table(ngram=names(ngrams), freq=ngrams)
  if(length(grep('^SOS', ngrams_dt$ngram)) > 0) {
    ngrams_dt <- ngrams_dt[-grep('^SOS', ngrams_dt$ngram),]
  }
  if(!is.null(prefixFilter)) {
    regex <- sprintf('%s%s', '^', prefixFilter)
    ngrams_dt <- ngrams_dt[grep(regex, ngrams_dt$ngram),]
  }

  end_msg <- paste0("*** FINISH building ", ng, "-gram frequency table at ",
                    as.character(Sys.time()), "***\n")
  cat(end_msg)

  return(ngrams_dt)
}

ltcorpus <- readLines("./capstone/final/finals/en_US.final.txt")

unigs <- getNgramTables(1, ltcorpus)
bigrs <- getNgramTables(2, ltcorpus)
trigs <- getNgramTables(3, ltcorpus)
tetrags <- getNgramTables(4, ltcorpus)
pentags <- getNgramTables(5, ltcorpus)

save(unigs, bigrs, trigs, tetrags, pentags, file = "ngrams.rdata")

countFreq <- function(tokens){
  size <- length(tokens)

  if(size == 1) tablefreq <- unigs
  else if(size == 2) tablefreq <- bigrs
  else if(size == 3) tablefreq <- trigs
  else if(size == 4) tablefreq <- tetrags
  else if(size == 5) tablefreq <- pentags

  phrase <- paste(tokens, collapse = "_")
  r <- tablefreq[ngram == phrase]

  if(length(r) == 0) 0
  else as.numeric(r$freq)
}

Pmle <- function(words, size=2){
  #sum(sapply(1:(length(words)-size+1),function(x) {
  #  currentGram <- words[x:(x+size-1)]
  #  print(sprintf("%s/%s",paste(currentGram, collapse = "_"),paste(head(currentGram, n = size-1), collapse = "_")))
    #log(countFreq(currentGram)/countFreq(head(currentGram, n = size-1)))
  #}))
  #countFreq(words)/countFreq(head(words, n = length(words) - 1))
  currentGram <- words[(length(words):-size):]
  Pmle(head(words, n = length(words) - 1), size)
}

#When you breathe, I want to be the air for you. I'll be there for you, I'd live and I'd
Pmle(c("i","would","sleep"))
Pmle(c("i","would","eat"))
Pmle(c("i","would","give"))
Pmle(c("i","would","die"))

Pmle(c("and","id","sleep"))
Pmle(c("and","id","eat"))
Pmle(c("and","id","give"))
Pmle(c("and","id","die"))

Pmle(c("and","i", "would","sleep"),3)
Pmle(c("and","i", "would","eat"),3)
Pmle(c("and","i", "would","give"))
Pmle(c("and","i", "would","die"))

Pmle(c("live", "and","id", "sleep"))
Pmle(c("live", "and","id", "eat"))
Pmle(c("live", "and","id", "give"))
Pmle(c("live", "and","id", "die"))

Pmle(c("live", "and", "i", "would", "sleep"))
Pmle(c("live", "and", "i", "would", "eat"))
Pmle(c("live", "and", "i", "would", "give"))
Pmle(c("live", "and", "i", "would", "die"))
Pmle(c("live", "and", "i", "would", "die"),3)
Pmle(c("live", "and", "i", "would", "die"),4)

Pmle(c("live", "and", "id", "sleep"))
Pmle(c("live", "and", "id", "eat"))
Pmle(c("live", "and", "id", "give"))
Pmle(c("live", "and", "id", "die"))

Pmle(c("id", "live", "and", "id"))
Pmle(c("id", "live", "and", "id", "die"))


### Operation Span Processing Script ###
### Author: James stone ###
### Version: 1.0 ###
### For use with the operation span task available at http://www.cognitivetools.uk/ ###

#set the working directory to the folder that is holding the data files from the operation span task

###function that takes the output file for a participant and returns summary information for that person###

operation_span_processing <- function(data.frame) {

	#seperate processing trials from digit span trials

	df.recall <- subset(data.frame, !is.na(trial.digit_span.trialNo))
	df.operations <- subset(data.frame, is.na(trial.digit_span.trialNo))

	#standard output form digit span has each element of a trial as a row,
	#also need to collate these into success/failure for whole trials.
	num.trials <- max(df.recall$trial.digit_span.trialNo)
	#set these vectors up now, to be filled later.
	trial.load <- numeric(num.trials)
	num.corr <- numeric(num.trials)
	prop.corr <- numeric(num.trials)
	trial.success <- numeric(num.trials)

	for (i in 1:num.trials) {
		indi_trial <- df.recall$trial.digit_span.result[df.recall$trial.digit_span.trialNo == i]
		numDigits <- length(indi_trial)
		numCorr <- sum(indi_trial == "success")
		trial.success[i] <- numDigits == numCorr
		trial.load[i] <- numDigits
		num.corr[i] <- numCorr
		prop.corr[i] <- numCorr / numDigits
	}

	df.recall.wholeTrial <- as.data.frame(cbind(trial.load, num.corr, prop.corr, trial.success))
	df.recall.wholeTrial <- transform(df.recall.wholeTrial, score = trial.load * trial.success)

	#highest load with a fully correct response
	if (length(df.recall.wholeTrial$trial.load[df.recall.wholeTrial$trial.success == 1]) == 0) {
		#no successes
		max.span <- NA
	} else {
		max.span <- max(df.recall.wholeTrial$trial.load[df.recall.wholeTrial$trial.success == 1])
	}

	#total number of words correctly recalled in correct serial position throughout
	number.successes <- sum(data.frame$trial.digit_span.result == "success")
	#span two trials correct
	if (nrow(subset(df.recall.wholeTrial, trial.load == 2)) == 0) {
		#then there were no span size 2 trials, therefore
		span.2.corr <- NA
	} else {
		span.2.corr <- sum(df.recall.wholeTrial$trial.success[df.recall.wholeTrial$trial.load == 2])
	}
	#span three trials correct
	if (nrow(subset(df.recall.wholeTrial, trial.load == 3)) == 0) {
		#then there were no span size 3 trials, therefore
		span.3.corr <- NA
	} else {
		span.3.corr <- sum(df.recall.wholeTrial$trial.success[df.recall.wholeTrial$trial.load == 3])
	}
	#span four trials correct
	if (nrow(subset(df.recall.wholeTrial, trial.load == 4)) == 0) {
		#then there were no span size 4 trials, therefore
		span.4.corr <- NA
	} else {
		span.4.corr <- sum(df.recall.wholeTrial$trial.success[df.recall.wholeTrial$trial.load == 4])
	}
	#span five trials correct
	if (nrow(subset(df.recall.wholeTrial, trial.load == 5)) == 0) {
		#then there were no span size 5 trials, therefore
		span.5.corr <- NA
	} else {
		span.5.corr <- sum(df.recall.wholeTrial$trial.success[df.recall.wholeTrial$trial.load == 5])
	}
	#span six trials correct
	if (nrow(subset(df.recall.wholeTrial, trial.load == 6)) == 0) {
		#then there were no span size 6 trials, therefore
		span.6.corr <- NA
	} else {
		span.6.corr <- sum(df.recall.wholeTrial$trial.success[df.recall.wholeTrial$trial.load == 6])
	}
	#span seven trials correct
	if (nrow(subset(df.recall.wholeTrial, trial.load == 7)) == 0) {
		#then there were no span size 7 trials, therefore
		span.7.corr <- NA
	} else {
		span.7.corr <- sum(df.recall.wholeTrial$trial.success[df.recall.wholeTrial$trial.load == 7])
	}
	#span eight trials correct
	if (nrow(subset(df.recall.wholeTrial, trial.load == 8)) == 0) {
		#then there were no span size 8 trials, therefore
		span.8.corr <- NA
	} else {
		span.8.corr <- sum(df.recall.wholeTrial$trial.success[df.recall.wholeTrial$trial.load == 8])
	}
	#span nine trials correct
	if (nrow(subset(df.recall.wholeTrial, trial.load == 9)) == 0) {
		#then there were no span size 9 trials, therefore
		span.9.corr <- NA
	} else {
		span.9.corr <- sum(df.recall.wholeTrial$trial.success[df.recall.wholeTrial$trial.load == 9])
	}

	fta.score <- sum(df.recall.wholeTrial$score)
	prop.score <- mean(df.recall.wholeTrial$prop.corr)
	number.successes <- sum(df.recall$trial.digit_span.result == "success")

	processing.accuracy <- sum(df.operations$trial.operation_processing.result == "success") / nrow(df.operations)
	processing.median.rt <- median(df.operations$trial.operation_processing.durationTime)

	p.summary <- c(fta.score, prop.score, number.successes, processing.accuracy, processing.median.rt,
	max.span, span.2.corr, span.3.corr, span.4.corr, span.5.corr, span.6.corr, span.7.corr, span.8.corr,
	span.9.corr)

	return(p.summary)
}

##now can use that function on all our data files for operation span
#put all operation span files into one folder and set that folder as working directory

compile_operation_span_data <- function() {

	multiple.sessions <- character()
	filenames <- list.files()
	operation.span.data <- matrix(nrow=length(filenames), ncol=14) #ncol needs to be number of values in p.summary above
	user <- character()

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

		tmp.df <- read.csv(filenames[i])
		user[i] <- toString(tmp.df$user.name[1])

		if (length(unique(tmp.df$session.id)) > 1) {
			multiple.sessions[length(multiple.sessions) + 1] <- filenames[i]
		}

		tmp.os.summary <- operation_span_processing(tmp.df)

		operation.span.data[i, ] <- tmp.os.summary

	}

	operation.span.data <- as.data.frame(operation.span.data)
	operation.span.data$user <- user

	os.names <- c("fta.score", "prop.score", "number.successes", "processing.accuracy", "processing.median.rt",
	"max.span", "span.2.corr", "span.3.corr", "span.4.corr", "span.5.corr", "span.6.corr", "span.7.corr", "span.8.corr",
	"span.9.corr", "user")

	names(operation.span.data) <- os.names

	if (length(multiple.sessions > 0)) {
		cat("The following files contained trials with more than one session id: \n", multiple.sessions)
	}

	return(operation.span.data)

}

operation.span.data <- compile_operation_span_data()

rm(compile_operation_span_data, operation_span_processing)


library(randomForest)
library(caret)
library(doMC)
library(mmadsenr)
library(futile.logger)
library(dplyr)
library(ggthemes)

# Train and tune random forest classifiers for the ta sampled data set, which is really 8 levels of TA and
# sample size combinations.
#

get_tassize_subset_ssize_tadur <- function(df, ssize, tadur) {
  df_tassize_subset <- dplyr::filter(df, sample_size == ssize, ta_duration == tadur)
  df_tassize_subset
}

# Set up logging
log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "tasampled-classification.log")
flog.appender(appender.file(log_file), name='cl')

clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-ta-sampled-data.rda")
} else {
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-ta-sampled-data.rda", args = clargs)
}

load(ta_sampled_data_file)
flog.info("Loaded data file: %s", ta_sampled_data_file, name='cl')

flog.info("Beginning classification analysis of TA sampled equifinality-3 data sets", name='cl')

# set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
num_cores <- get_parallel_cores_given_os(dev=TRUE)
flog.info("Number of cores used in analysis: %s", num_cores, name='cl')
registerDoMC(cores = num_cores)

########### Training and Tuning Variables ##############

#
# Common training and tuning parameters for ctmixtures analysis
#
gbm_grid <- expand.grid(.interaction.depth = (1:6)*2,
                        .n.trees = (1:10)*25,
                        .shrinkage = 0.05)

training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)

# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

# # tuning grid of parameters and tuning cross-validation parameters
# mtry_seq <- seq(from=2, to=20, by=4)
# flog.info("Tuning random forest parameter mtry using vals: %s", mtry_seq, name='cl')
# fit_grid <- expand.grid(mtry=mtry_seq)
#
# cv_num <- 10
# #cv_repeats <- 10
#
# flog.info("Tuning performed by CV, %s folds ", cv_num, name='cl')
#
# fit_control <- trainControl(method="cv",
#                             number=cv_num,
#                             #repeats=cv_repeats,
#                             allowParallel = TRUE,
#                             ## Estimate class probabilities
#                             classProbs = TRUE)

# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes
eq3_ta_sampled_df$two_class_label <- factor(ifelse(eq3_ta_sampled_df$model_class_label == 'allneutral', 'neutral', 'biased'))

############# Process each combination of TA and sample size ###########

# get grid of the sample size and TA duration combinations, to tassize_subset the data set
sample_sizes <- unique(eq3_ta_sampled_df$sample_size)
ta_durations <- unique(eq3_ta_sampled_df$ta_dur)

tassize_subsets <- expand.grid(sample_size = sample_sizes, ta_duration = ta_durations)

exclude_columns <- c("simulation_run_id", "innovation_rate", "model_class_label", "sample_size", "ta_duration")

experiment_names <- character(nrow(tassize_subsets))

# Add experiment names to the tassize_subsets since I didn't do this in the original analysis
for( i in 1:nrow(tassize_subsets)) {
  experiment_names[i] <- paste("Sample Size: ", tassize_subsets[i, "sample_size"], " Duration: ", tassize_subsets[i, "ta_duration"])
}

tassize_subsets_results <- data.frame()
tassize_subset_roc <- NULL
tassize_subset_roc_ssize_20 <- NULL
tassize_subset_roc_ssize_10 <- NULL
tassize_subset_model <- NULL
tassize_subset_cm <- NULL

# To create a smaller test dataset:
# test_tasampled_indices <- createDataPartition(eq3_ta_sampled_df$two_class_label, p = 0.05, list=FALSE)
# test_tasampled_df <- eq3_ta_sampled_df[test_tasampled_indices,]
# switch the DF input to get_tassize_subset_ssize_tadur() back to eq3_ta_sampled_df for production

for( i in 1:nrow(tassize_subsets)) {
  exp_name <- experiment_names[i]
  df <- get_tassize_subset_ssize_tadur(eq3_ta_sampled_df,
                              tassize_subsets[i, "sample_size"],
                              tassize_subsets[i, "ta_duration"])
  print(sprintf("row %d:  sample size: %d  ta duration: %d numrows: %d", i, tassize_subsets[i, "sample_size"], tassize_subsets[i, "ta_duration"], nrow(df)))

  #model <- train_randomforest(df, training_set_fraction, fit_grid, fit_control, exclude_columns)
  model <- train_gbm_classifier(df, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

  tassize_subset_model[[exp_name]] <- model$tunedmodel

  # use the test data split by the train_randomforest function and calculate tuned model predictions
  # and then get the confusion matrix and fitting metrics
  predictions <- predict(model$tunedmodel, newdata=model$test_data)
  cm <- confusionMatrix(predictions, model$test_data$two_class_label)
  results <- get_parsed_binary_confusion_matrix_stats(cm)
  results$experiments <- experiment_names[i]
  results$elapsed <- model$elapsed
  results$sample_size <- tassize_subsets[i, "sample_size"]
  results$ta_duration <- tassize_subsets[i, "ta_duration"]
  results$experiments <- exp_name
  tassize_subset_cm[[exp_name]] <- cm

  roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", experiment_names[i])
  tassize_subset_roc[[exp_name]] <- roc
  results$auc <- unlist(roc$auc@y.values)

  if(tassize_subsets[i, "sample_size"] == 20) {
    tassize_subset_roc_ssize_20[[exp_name]] <- roc
  }
  if(tassize_subsets[i, "sample_size"] == 10) {
    tassize_subset_roc_ssize_10[[exp_name]] <- roc
  }

  tassize_subsets_results <- rbind(tassize_subsets_results, results)

}

# sigh, now we have to remove NULL objects from lists that are tassize_subset of the whole analysis
tassize_subset_roc_ssize_20 <- tassize_subset_roc_ssize_20[-(which(sapply(tassize_subset_roc_ssize_20,is.null),arr.ind=TRUE))]
tassize_subset_roc_ssize_10 <- tassize_subset_roc_ssize_10[-(which(sapply(tassize_subset_roc_ssize_10,is.null),arr.ind=TRUE))]

# we can now use plot_multiple_roc() to plot all the ROC curves on the same plot, etc.
# as well as graph various of the metrics as they vary across sample size and TA duratio
#plot_multiple_roc_from_list(tassize_subset_roc)

############## Complete Processing and Save Results ##########3

#save objects from the environment

if(length(clargs) == 0) {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                              filename = "classification-ta-sampled-results-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                                      filename = "classification-ta-sampled-results-gbm-dfonly.RData")

} else {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                              filename = "classification-ta-sampled-results-gbm.RData", args = clargs)
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                                      filename = "classification-ta-sampled-results-gbm-dfonly.RData", args = clargs)
}

flog.info("Saving results of analysis to R environment snapshot: %s", image_file, name='cl')
save(tassize_subsets_results, tassize_subset_cm, tassize_subset_model,
     tassize_subset_roc, tassize_subset_roc_ssize_10, tassize_subset_roc_ssize_20, file=image_file)
flog.info("Saving just data frame of results of analysis to R environment snapshot: %s", image_file_results, name='cl')
save(tassize_subsets_results, file=image_file_results)

# End
flog.info("Analysis complete", name='cl')


model_updateleafflag <- function (cumulTT = 741.510096671757,
         leafNumber = 8.919453833361189,
         calendarMoments = c('Sowing'),
         calendarDates = c('2007/3/21'),
         calendarCumuls = c(0.0),
         currentdate = '2007/4/29',
         finalLeafNumber = 8.797582013199484,
         hasFlagLeafLiguleAppeared_t1 = 1,
         phase = 1.0){
    #'- Name: UpdateLeafFlag -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: UpdateLeafFlag Model
    #'            * Author: Pierre MARTRE
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: tells if flag leaf has appeared and update the calendar if so
    #'
    #'- inputs:
    #'            * name: cumulTT
    #'                          ** description : cumul thermal times at current date
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -200
    #'                          ** max : 10000
    #'                          ** default : 741.510096671757
    #'                          ** unit : °C d
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'            * name: leafNumber
    #'                          ** description : Actual number of phytomers
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 25
    #'                          ** default : 8.919453833361189
    #'                          ** unit : leaf
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'            * name: calendarMoments
    #'                          ** description : List containing apparition of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** default : ['Sowing']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarDates
    #'                          ** description : List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** default : ['2007/3/21']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarCumuls
    #'                          ** description : list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** default : [0.0]
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: currentdate
    #'                          ** description :  current date
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DATE
    #'                          ** default : 2007/4/29
    #'                          ** unit :
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'            * name: finalLeafNumber
    #'                          ** description : final leaf number
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** default : 8.797582013199484
    #'                          ** unit : leaf
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'            * name: hasFlagLeafLiguleAppeared_t1
    #'                          ** description : true if flag leaf has appeared (leafnumber reached finalLeafNumber)
    #'                          ** variablecategory : state
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'            * name: phase
    #'                          ** description :  the name of the phase
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 7
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** uri : some url
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: hasFlagLeafLiguleAppeared
    #'                          ** description : true if flag leaf has appeared (leafnumber reached finalLeafNumber)
    #'                          ** variablecategory : state
    #'                          ** datatype : INT
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : some url
    #'            * name: calendarMoments
    #'                          ** description :  List containing apparition of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** unit :
    #'            * name: calendarDates
    #'                          ** description :  List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** unit :
    #'            * name: calendarCumuls
    #'                          ** description :  list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** unit : °C d
    hasFlagLeafLiguleAppeared <- 0
    if (phase >= 1.0 && phase < 4.0)
    {
        if (leafNumber > 0.0)
        {
            if (hasFlagLeafLiguleAppeared == 0 && (finalLeafNumber > 0.0 && leafNumber >= finalLeafNumber))
            {
                hasFlagLeafLiguleAppeared <- 1
                if (!('FlagLeafLiguleJustVisible' %in% calendarMoments))
                {
                    calendarMoments <- c(calendarMoments, 'FlagLeafLiguleJustVisible')
                    calendarCumuls <- c(calendarCumuls, cumulTT)
                    calendarDates <- c(calendarDates, currentdate)
                }
            }
        }
    }
    return (list ("hasFlagLeafLiguleAppeared" = hasFlagLeafLiguleAppeared,"calendarMoments" = calendarMoments,"calendarDates" = calendarDates,"calendarCumuls" = calendarCumuls))
}


#################################################
#
# make_figures.r    16 FEB 2017
#
# Generates figures 2-5 in "Priority for the
# worse off and the Social Cost of Carbon".
#
#################################################

# Directories
scriptdir <- "."
datadir <- "../../results"
plotdir <- "../../plots"

# Libraries
library(RColorBrewer)
library(lattice)
library(fields)
source(paste(scriptdir, "/put_fig_letter.r", sep=""))
source(paste(scriptdir, "/oat_plot_functions.r", sep=""))
source(paste(scriptdir, "/contour_plot_functions.r", sep=""))

# Load the data
infile <- paste(datadir, "/output-scc.csv", sep="")
my.data <- read.csv(infile, header=T)

# List of the normalization regions of interest
norm.regions <- c("Africa", "US", "Global", "World-Fair")

# Generate the figures
source(paste(scriptdir, "/make_figure_2.r", sep=""))
source(paste(scriptdir, "/make_figure_3.r", sep=""))
source(paste(scriptdir, "/make_figure_4.r", sep=""))
source(paste(scriptdir, "/make_figure_5.r", sep=""))

# Done!


library(stm)
library(lubridate)

md <- data.frame( timestamp = ymd_hms( timestamps ), source = sources, author = authors, text = texts )

processed <- textProcessor( documents, metadata = md, stem = FALSE, striphtml = TRUE, language = NA, customstopwords = stopwords )

## todo: set upper and lower thresholds
out <- prepDocuments(processed$documents, processed$vocab, processed$meta, lower.thresh= 20, verbose = FALSE )

## upper.thresh = 100

stm <- stm( documents = out$documents, vocab = out$vocab, K = k, data = out$meta,
  max.em.its = 75, init.type = "Spectral",  seed = 1, verbose = FALSE )

save( stm, out, file = paste( saveto, '/stm.rdata', sep = '' ) )

print( plot( stm, "summary" ) )


#  James Rekow

#  mdr = Mean Diss Ratio
#  mmd = mean mean dissimilarity (i.e. of subsets of a cohort with a given size)
#  ^^ didn't show any slope. No useful ratios apparent

#  SRSSE = scaled residual sse

computeMMD = function(abdList){

  source("DOCProcedure.r")
  source("computeUnivWithinSSTEST.r")

  subgroupSizeVec = floor(length(abdList) / {c(10, 8, 6, 4, 2)})

  computeSubgroupMMD = function(subgroupSize){

    computeSubgroupSampleMMD = function(zz = NULL){

      subgroupAbdList = sample(abdList, subgroupSize)
      subgroupSRSSE = computeUnivWithinSSTEST(abdList = subgroupAbdList)

      return(subgroupSRSSE)

    } #  end computeSubgroupSampleMMD

    sampleMMDVec = replicate(10, computeSubgroupSampleMMD())

    subgroupMMD = mean(sampleMMDVec)

    return(subgroupMMD)

  } #  end computeSubgroupMMD function

  mmd = sapply(subgroupSizeVec, computeSubgroupMMD)

  return(mmd)

} #  end computeMMD function


# script to make the KM graphs for the MIDCAB paper.
# graphs made for mets, dm, obese ...
# maybe other graphs needed.
# prepare splines for bmi and then decide to

library(easypackages)
libraries(c("survival","tidyverse",
	"rms","Hmisc","survminer","haven", "readxl"))

df <- read_stata("D:/MIDCAB_DM/dataset2.dta")

glimpse(df)

# now to create the KM curves for the paper.

# overall survival.

s <- survfit(Surv(fupyears, died_total) ~ 1, data = df)

tiff("D:/MIDCAB_DM/graphs/overall.tiff",
	height = 6, width = 8, units = "in",
	res = 900)

ggsurvplot(s,
	xlim = c(0,20),
	surv.scale = "percent",
	break.x.by = 5,
	censor.size = 0,
	risk.table = T)

dev.off()

# plot according to metabolic syndrome.

ms <- survfit(Surv(fupyears, died_total) ~ factor(mets),
	data = df)

tiff("D:/MIDCAB_DM/graphs/km_mets.tiff",
	height = 6, width = 8, units = "in",
	res = 900)

ggsurvplot(ms,
	xlim = c(0,20),
	surv.scale = "percent",
	break.x.by = 5,
	censor.size = 0,
	risk.table = T,
	legend.labs = c("MET-ve","MET+ve"),
	conf.int = T)

dev.off()

# according to diabetes.

sd <- survfit(Surv(fupyears, died_total) ~ diabetes,
	data = df)

tiff("D:/MIDCAB_DM/graphs/km_dm.tiff",
	height = 6, width = 8, units = "in",
	res = 900)

ggsurvplot(sd,
	xlim = c(0,20),
	surv.scale = "percent",
	break.x.by = 5,
	censor.size = 0,
	risk.table = T,
	legend.labs = c("DM-ve","DM+ve"),
	conf.int = T)

dev.off()

# according to obesity

so <- survfit(Surv(fupyears, died_total) ~ obese,
	data = df)

tiff("D:/MIDCAB_DM/graphs/km_obese.tiff",
	height = 6, width = 8, units = "in",
	res = 900)

ggsurvplot(so,
	xlim = c(0,20),
	surv.scale = "percent",
	break.x.by = 5,
	censor.size = 0,
	risk.table = T,
	legend.labs = c("Not Obese","Obese"),
	conf.int = T)

dev.off()

# for now these graphs are good.
# will make more graphs depending upon the plan.

# get the dataset for plotting bmi as a spline.

d <- read_excel("D:/MIDCAB_DM/bmi_plot.xlsx", sheet = 1)

glimpse(d)

plot(x = d$bmi, y = d$hr, type = "l", col = "red")
lines(x = d$bmi, y = d$lb, lty = 2, col = "blue")
lines(x = d$bmi, y = d$ub, lty = 2, col = "blue")


## initialise_BASGRA_xxx.R ##

## 1. GENERAL INITIALISATION ##
source("scripts/initialise_BASGRA_general.R")

## 2. SITE CONDITIONS ##

# run model for this period
# Scott weather data is 2010-1 to 2017-318 (14 Nov)
year_start     <- as.integer(2011)
# doy_start      <- as.integer(244) # 1 Sept
doy_start      <- as.integer(121) # 1 May
year_stop      <- as.integer(2017)
# doy_stop       <- as.integer(151) # 31 May
doy_stop       <- as.integer(120) # 30 April

# calculate sim length --- WARNING this needs to fit within weather data!
# NDAYS          <- as.integer(1460)
NDAYS          <- as.integer(difftime(
  as.Date(doy_stop -1, origin=paste(year_stop ,1,1,sep="-")),
  as.Date(doy_start-1, origin=paste(year_start,1,1,sep="-")),
  units="days")) + 1L

# use data in this period (replaced by data weights)
# year_start_data     <- as.integer(2012)
# doy_start_data      <- as.integer(1) # 1 Jan
# year_stop_data      <- as.integer(2017)
# doy_stop_data       <- as.integer(151) # 31 May

file_weather   <- paste(scenario, "/weather_Lincoln.txt", sep="")

file_params    <- paste(parameter_location, "/parameters_All.txt", sep="") # can contain multiple columns
parcol       <- 3 # which one are we going to use? (row names are ignored)

# read harvest days (Simon) which are set up in make_weather1.r
file_harvest   <- paste(scenario, "/harvest_Lincoln_0.txt", sep="")
days_harvest   <- as.matrix(read.table(file=file_harvest, sep="\t"))

## 3. CREATE HARVEST CALENDAR AND WEATHER INPUT ##
days_harvest   <- as.integer(days_harvest)
matrix_weather <- read_weather_WG(year_start,doy_start,NDAYS,file_weather) # function in initialise_BASGRA_general.R

## 4. CREATE VECTOR "PARAMS" ##
df_params      <- read.table(file_params,header=T,sep="\t",row.names=1)
params         <- df_params[,parcol]

## 5. CREATE EMPTY MATRIX y ##
y              <- matrix(0,NDAYS,NOUT)


#!/usr/bin/env Rscript
# Reduce dimensions for a SCE
#  Combiz Khozoie <c.khozoie@imperial.ac.uk>

#   ____________________________________________________________________________
#   Initialization                                                          ####

options(mc.cores = future::availableCores())

##  ............................................................................
##  Load packages                                                           ####
library(argparse)
library(scFlow)
library(parallel)
library(SingleCellExperiment) # due to monocle3 missing namespace::

##  ............................................................................
##  Parse command-line arguments                                            ####

# create parser object
parser <- ArgumentParser()

# specify options
required <- parser$add_argument_group("Required", "required arguments")
optional <- parser$add_argument_group("Optional", "required arguments")

required$add_argument(
  "--sce_path",
  help = "-path to the SingleCellExperiment",
  metavar = "dir",
  required = TRUE
)

required$add_argument(
  "--input_reduced_dim",
  help = "input reducedDim to use for further dim reds",
  metavar = "PCA,Liger",
  required = TRUE
)

required$add_argument(
  "--reduction_methods",
  help = "methods to use for dimensionality reduction",
  metavar = "PCA,tSNE,UMAP,UMAP3D",
  required = TRUE
)

required$add_argument(
  "--vars_to_regress_out",
  help = "variables to regress out before finding singlets",
  metavar = "nCount_RNA,pc_mito",
  required = TRUE
)

required$add_argument(
  "--pca_dims",
  type = "integer",
  default = 20,
  help = "the number of PCA dimensions used",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--n_neighbors",
  type = "integer",
  default = 30,
  help = "the number of nearest neighbors",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--n_components",
  type = "integer",
  default = 2,
  help = "the number of UMAP dimensions (2 or 3)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--init",
  help = "type of initialization for UMAP coordinates (uwot)",
  metavar = "pca",
  required = TRUE
)

required$add_argument(
  "--metric",
  help = "type of distance metric for nearest neighbours (uwot)",
  metavar = "euclidean",
  required = TRUE
)

required$add_argument(
  "--n_epochs",
  type = "integer",
  default = 500,
  help = "number of epochs for optimization of embeddings (uwot)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--learning_rate",
  type = "double",
  default = 1.0,
  help = "initial learning rate used in optimization (uwot)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--min_dist",
  type = "double",
  default = 0.3,
  help = "effective minimum distance between embedded points (uwot)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--spread",
  type = "double",
  default = 1.0,
  help = "effective scale of embedded points (uwot)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--set_op_mix_ratio",
  type = "double",
  default = 1.0,
  help = "interpolation between fuzzy union and intersection set operation (uwot)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--local_connectivity",
  type = "integer",
  default = 1,
  help = "number of nearest neighbours assumed connected locally (uwot)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--repulsion_strength",
  type = "double",
  default = 1.0,
  help = "weighting applied to negative samples in optimization (uwot)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--negative_sample_rate",
  type = "double",
  default = 5.0,
  help = "number of negative edge samples per positive edge (uwot)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--fast_sgd",
  help = "faster but less reproducible UMAP (uwot) (lgl)",
  metavar = "FALSE",
  required = TRUE
)

required$add_argument(
  "--dims",
  type = "integer",
  default = 30,
  help = "the number of dimensions to output (rtsne)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--initial_dims",
  type = "integer",
  default = 50,
  help = "the number of dimensions retained in the PCA init (rtsne)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--perplexity",
  type = "integer",
  default = 30,
  help = "perplexity parameter (rtsne)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--theta",
  type = "double",
  default = 0.5,
  help = "speed / accuracy trade-off (increase for less accuracy) (rtsne)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--max_iter",
  type = "integer",
  default = 1000,
  help = "number of iterations (rtsne)",
  metavar = "N",
  required = TRUE
)
required$add_argument(
  "--pca_center",
  help = "should data be centered before pca (rtsne) (lgl)",
  metavar = "TRUE",
  required = TRUE
)

required$add_argument(
  "--pca_scale",
  help = "should data be scaled before pca (rtsne) (lgl)",
  metavar = "FALSE",
  required = TRUE
)

required$add_argument(
  "--normalize",
  help = "should data be normalized before distance calculations (rtsne) (lgl)",
  metavar = "TRUE",
  required = TRUE
)

required$add_argument(
  "--stop_lying_iter",
  type = "integer",
  default = 250,
  help = "iteration after which perplexities are no longer exaggerated (rtsne)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--mom_switch_iter",
  type = "integer",
  default = 250,
  help = "iteration after which final momentum is used (rtsne)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--momentum",
  type = "double",
  default = 0.5,
  help = "momentum used in the first part of the optimization (rtsne)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--final_momentum",
  type = "double",
  default = 0.8,
  help = "momentum used in the final part of the optimization (rtsne)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--eta",
  type = "double",
  default = 200.0,
  help = "learning rate (rtsne)",
  metavar = "N",
  required = TRUE
)

required$add_argument(
  "--exaggeration_factor",
  type = "double",
  default = 12.0,
  help = "Exaggeration factor used in the first part of the optimization (rtsne)",
  metavar = "N",
  required = TRUE
)

### . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ..
### Pre-process args                                                        ####

args <- parser$parse_args()
args$fast_sgd <- as.logical(args$fast_sgd)
args$input_reduced_dim <- strsplit(args$input_reduced_dim, ",")[[1]]
args$reduction_methods <- strsplit(args$reduction_methods, ",")[[1]]
args$vars_to_regress_out <- strsplit(args$vars_to_regress_out, ",")[[1]]
args <- purrr::map(args, function(x) {
  if (length(x) == 1) {
    if (toupper(x) == "TRUE") return(TRUE)
    if (toupper(x) == "FALSE") return(FALSE)
    if (toupper(x) == "NULL") return(NULL)
  }
  return(x)
})

##  ............................................................................
##  Start                                                                   ####

sce <- read_sce(args$sce_path, read_metadata = TRUE)

sce <- reduce_dims_sce(
  sce,
  input_reduced_dim = args$input_reduced_dim,
  reduction_methods = args$reduction_methods,
  vars_to_regress_out = args$vars_to_regress_out,
  pca_dims = args$pca_dims,
  n_neighbors = args$n_neighbors,
  n_components = args$n_components,
  init = args$init,
  metric = args$metric,
  n_epochs = args$n_epochs,
  learning_rate = args$learning_rate,
  min_dist = args$min_dist,
  spread = args$spread,
  set_op_mix_ratio = args$set_op_mix_ratio,
  local_connectivity = args$local_connectivity,
  repulsion_strength = args$repulsion_strength,
  negative_sample_rate = args$negative_sample_rate,
  fast_sgd = args$fast_sgd,
  dims = args$dims,
  initial_dims = args$initial_dims,
  perplexity = args$perplexity,
  theta = args$theta,
  stop_lying_iter = args$stop_lying_iter,
  mom_switch_iter = args$mom_switch_iter,
  max_iter = args$max_iter,
  pca_center = args$pca_center,
  pca_scale = args$pca_scale,
  pca_normalize = args$pca_normalize,
  momentum = args$momentum,
  final_momentum = args$final_momentum,
  eta = args$eta,
  exaggeration_factor = args$exaggeration_factor
  )

##  ............................................................................
##  Save Outputs                                                            ####

# Save SingleCellExperiment
write_sce(
  sce = sce,
  folder_path = file.path(getwd(), "reddim_sce"),
  write_metadata = TRUE
)

##  ............................................................................
##  Clean up                                                                ####

# Clear biomart cache


<!—topic_detection_module.R -->
input_folder = "<path to folder here or folder name>"

library(tm)
corp = VCorpus(DirSource(input_folder, encoding = "UTF-8", mode = "text"))
dtm1 = DocumentTermMatrix(corp, control=list(bounds = list(global = c(20,Inf))))
dtm1_forLDA = DocumentTermMatrix(corp, control=list(bounds = list(global = c(3,Inf))))
rowTotals = apply(dtm1_forLDA , 1, sum)
dtm1_forLDA = dtm1_forLDA[rowTotals> 0, ]
dtm1_forDBSCAN = as.matrix(dtm1)

# l1 normalization
for(j in 1:dim(dtm1_forDBSCAN)[2]) dtm1_forDBSCAN[,j] = dtm1_forDBSCAN[,j]/sum(dtm1_forDBSCAN[,j])

### DBSCAN-Martingale
library(dbscan)
minpts = 5
T = 5

### generate 10 random numbers from the uniform distribution in [0, 0.1]
random.epsilon = runif(T, min=0, max = 0.1)
random.epsilon = sort(random.epsilon, decreasing = FALSE)
dbscan.results.all = matrix(0, nrow = dim(dtm1)[1], ncol=T)

for(j in 1:T) dbscan.results.all[,j] = dbscan(dtm1_forDBSCAN, random.epsilon[j], minpts)$cluster
# giant cluster removal
for(j in 1:T) {
  for(i in 1:length(dbscan.results.all[,j])) dbscan.results.all[i,j]= dbscan.results.all[i,j] - 1
  for(i in 1:length(dbscan.results.all[,j])) if(dbscan.results.all[i,j]==-1) dbscan.results.all[i,j]=0
}
principal.clustering = dbscan.results.all[,1]
for(j in 1:T) {
  if((principal.clustering%*%dbscan.results.all[,j])[1,1]==0) {
    b = max(principal.clustering)
    for(i in 1:length(dbscan.results.all[,j])) if(dbscan.results.all[i,j]!=0) dbscan.results.all[i,j] = dbscan.results.all[i,j] + b
    principal.clustering = principal.clustering + dbscan.results.all[,j]
  } else {
    h = c()
    clh = c()
    for(i in 1:length(principal.clustering)) {
      h = c(h,0)
      clh = c(clh,0)
    }
    for(i in 1:length(principal.clustering)) if(principal.clustering[i]==0 && dbscan.results.all[i,j] != 0) h[i]=dbscan.results.all[i,j]
    b = max(principal.clustering)
    u = 0
    if(max(h)>0) {
      for(j in 1:max(h)) if(sum(h==j)>=minpts) {
        u = u + 1
        clh[which(h==j)]= u
      }
      for(i in 1:length(principal.clustering)) if(clh[i]!=0) clh[i] = clh[i] + b
      principal.clustering = principal.clustering + clh
    }
  }
}
num_of_topics = max(principal.clustering)

### LDA using the num_of_topics
library(topicmodels)

k = if(num_of_topics<2) 2 else num_of_topics
LDA.results = LDA(dtm1_forLDA, k)
LDA.clustering.vector = rep(0, dtm1_forLDA$nrow)
for(i in 1:dtm1_forLDA$nrow) LDA.clustering.vector[i] = which.max(LDA.results@gamma[i,])

### assign the documents in each topic
topics.list.IDs = vector("list", k+1)
names(topics.list.IDs) = as.character(0:k)

for(i in 1:k) {
  topics.list.IDs[[i+1]] = vector("list", 3)
  names(topics.list.IDs[[i+1]]) = c("labels", "scores", "articles")
  topics.list.IDs[[i+1]][[1]] = paste(LDA.results@terms[sort(LDA.results@beta[i,], decreasing = TRUE, index.return = TRUE)$ix[1:8]], collapse = " ")
  topics.list.IDs[[i+1]][[2]] = abs(sort(LDA.results@beta[i,], decreasing = TRUE)[1:8])
  topics.list.IDs[[i+1]][[3]] = dtm1_forLDA$dimnames$Docs[which(LDA.clustering.vector==i)]
}

### create a collection of "noise"-empty documents
if(length(which(rowTotals==0))>0) {
  topics.list.IDs[[1]] = vector("list", 2)
  names(topics.list.IDs[[1]]) = c("labels", "articles")
  topics.list.IDs[[1]][[1]] = "noise"
  topics.list.IDs[[1]][[2]] = dtm1$dimnames$Docs[which(rowTotals==0)]
} else topics.list.IDs = topics.list.IDs[-1]

### write the results to a JSON file
library(rjson)
exportJSON = toJSON(topics.list.IDs)

write(exportJSON, file = "topics.json")


#!/usr/bin/Rscript
source("../common.r")

#######################################################
#
#                  Proposal parameters
#
#######################################################

proposeParameters <- list(
                          Theta=0.0003,
                          Rho=0.001,
                          DeltaD=0.001,
                          DeltaS=0.009,
                          Lambda=0.008,
                          LambdaRight=0.008,
                          LambdaDisp=0.015
                          )

#######################################################
#
#                  Initial values
#
#######################################################

start_vals <- list(
                   ptrans = 0.00396/3,
                   rho = 1,
                   deltad = 0.0285,
                   deltas = 0.269,
                   lambda = 0.27,
                   lambda_right = 0.27,
                   lambda_disp = 1,
                   len = 60,
                   nu = 0.0645
                   )

#######################################################
#
#                   Various parameters
#
#######################################################

# Number of random starting points for the grid search
grid_iter <- getArgument("GRID_ITER", as.integer)
# Burn in period
burn_in <- getArgument("BURN_IN", as.integer)
# Adjust proposal variance parameters iterations
adjust_iter <- getArgument("ADJUST_ITER", as.integer)
# Iterations
iterations <- getArgument("ITERATIONS", as.integer)

# Taking the 5p, 3p, or both ends of the seqs
termini <- getArgument("TERMINI")
# Geom instead of neg Bin
fix_disp <- getArgument("FIX_DISP", as.logical)
# The overhangs are the same on both sides
same_overhangs <- getArgument("SAME_OVERHANGS", as.logical)

# Set 1 at 5' end and 0 at 3' end or else estimates it with GAM
fix_nu <- getArgument("FIX_NU", as.logical)
# Single stranded protocol C>T at both sides
ds_protocol <- getArgument("DS_PROTOCOL", as.logical)
# How long sequence to use from each side
sub_length <- getArgument("SUB_LENGTH", as.integer)

# Absolute path to the dataset
path_to_dat <- getArgument("PATH_TO_DAT")
# These options control the volume of the output
verbose <- getArgument("VERBOSE", as.logical)
quiet <- getArgument("QUIET", as.logical)

# Fix the transition and transversion ratio and acgt frequencies are equal
jukes_cantor <- getArgument("JUKES_CANTOR", as.logical)
use_raw_nick_freq <- getArgument("USE_RAW_NICK_FREQ", as.logical)
use_bw_theme <- getArgument("USE_BW_THEME", as.logical)

#######################################################
#
#                   Run the program
#
#######################################################

source("main.r")


#' Graph rewiring algorithms
#'
#' Changes the structure of a graph by altering ties.
#'
#' @inheritParams rgraph_ws
#' @templateVar undirected TRUE
#' @template graph_template
#' @param p Either a [0,1] vector with rewiring probabilities (\code{algorithm="endpoints"}),
#' or an integer vector with number of iterations (\code{algorithm="swap"}).
#' @param copy.first Logical scalar. When \code{TRUE} and \code{graph} is dynamic uses
#' the first slice as a baseline for the rest of slices (see details).
#' @param pr.change Numeric scalar. Probability ([0,1]) of doing a rewire (see details).
#' @param algorithm Character scalar. Either \code{"swap"}, \code{"endpoints"}, or \code{"qap"}
#' (see \code{\link{rewire_qap}}).
#' @param althexagons Logical scalar. When \code{TRUE} uses the compact alternating
#' hexagons algorithm (currently ignored [on development]).
#' @details
#' The algorithm \code{"qap"} is described in \code{\link{rewire_qap}}, and only
#' uses \code{graph} from the arguments (since it is simply relabelling the graph).
#'
#'
#' In the case of "swap" and "endpoints", both algorithms are implemented
#' sequentially, this is, edge-wise checking self edges and multiple edges over
#' the changing graph; in other words, at step
#' \eqn{m} (in which either a new endpoint or edge is chosen, depending on the algorithm),
#' the algorithms verify whether the proposed change creates either multiple edges
#' or self edges using the resulting graph at step \eqn{m-1}.
#'
#' The main difference between the two algorithms is that the \code{"swap"} algorithm
#' preserves the degree sequence of the graph and \code{"endpoints"} does not.
#' The \code{"swap"} algorithm is specially useful to asses the non-randomness of
#' a graph's structural properties, furthermore it is this algorithm the one used
#' in the \code{\link{struct_test}} routine implemented in \pkg{netdiffuseR}.
#'
#' Rewiring assumes a weighted network, hence \eqn{G(i,j) = k = G(i',j')},
#' where \eqn{i',j'} are the new end points of the edge and \eqn{k} may not be equal
#' to one.
#'
#' In the case of dynamic graphs, when \code{copy.first=TRUE}, after rewiring the
#' first slice--\eqn{t=1}--the rest of slices are generated by rewiring the rewired
#' version of the first slice. Formally:
#'
#' \deqn{%
#' G(t)' = \left\{\begin{array}{ll}
#' R(G(t)) & \mbox{if }t=1 \\
#' R(G(1)') & \mbox{otherwise}
#' \end{array}
#' \right.
#' }{%
#' G(t)' = R(G(t))  if t=1,
#'         R(G(1)') otherwise
#' }
#'
#' Where \eqn{G(t)} is the t-th slice, \eqn{G(t)'} is the t-th rewired slice, and
#' \eqn{R} is the rewiring function. Otherwise, \code{copy.first=FALSE} (default),
#' The rewiring function is simply \eqn{G(t)' = R(G(t))}.
#'
#' The following sections describe the way both algorithms were implemented.
#'
#' @section \emph{Swap} algorithm:
#' The \code{"swap"} algorithm chooses randomly two edges \eqn{(a,b)} and
#' \eqn{(c,d)} and swaps the 'right' endpoint of boths such that we get
#' \eqn{(a,d)} and \eqn{(c,b)} (considering self and multiple edges).
#'
#' Following Milo et al. (2004) testing procedure, the algorithm shows to be
#' well behaved in terms of been unbiased, so after each iteration each possible
#' structure of the graph has the same probability of been generated. The algorithm
#' has been implemented as follows:
#'
#' Let \eqn{E} be the set of edges of the graph \eqn{G}. For \eqn{i=1} to \eqn{p}, do:
#' \enumerate{
#'  \item With probability \code{1-pr.change} got to the last step.
#'  \item Choose \eqn{e0=(a, b)} from \eqn{E}. If \code{!self & a == b} then go to the last step.
#'  \item Choose \eqn{e1=(c, d)} from \eqn{E}. If \code{!self & c == d } then go to the last step.
#'  \item Define \eqn{e0'=(a, d)} and \eqn{e1' = (c, b)}. If \code{!multiple & [G[e0']!= 0 | G[e1'] != 0]} then go to the last step.(*)
#'  \item Define \eqn{v0 = G[e0]} and \eqn{v1 = G[e1]}, set \eqn{G[e0]=0} and \eqn{G[e1]=0}
#'  (and the same to the diagonally opposed coordinates in the case of undirected graphs)
#'  \item Set \eqn{G[e0'] = v0} and \eqn{G[e1'] = v1} (and so with the diagonally opposed coordinates
#'  in the case of undirected graphs).
#'  \item Next i.
#' }
#'
#' (*) When \code{althexagons=TRUE}, the algorithm changes and applies what Rao et al.
#' (1996) describe as Compact Alternating Hexagons. This modification assures the
#' algorithm to be able to achieve any structure. The algorithm consists on doing
#' the following swapping: \eqn{(i1i2,i1i3,i2i3,i2i1,i3i1,i3i2)} with values
#' \eqn{(1,0,1,0,1,0)} respectively with \eqn{i1!=i2!=i3}. See the examples and
#' references.
#'
#' In Milo et al. (2004) is suggested that in order for the rewired graph to be independent
#' from the original one researchers usually iterate around \code{nlinks(graph)*100}
#' times, so \code{p=nlinks(graph)*100}. On the other hand in Ray et al (2012)
#' it is shown that in order to achive such it is needed to perform
#' \code{nlinks(graph)*log(1/eps)}, where \code{eps}\eqn{\sim}1e-7, in other words,
#' around \code{nlinks(graph)*16}. We set the default to be 20.
#'
#' In the case of Markov chains, the variable \code{pr.change} allows making the
#' algorithm aperiodic. This is relevant only if the
#' probability self-loop to a particular state is null, for example, if
#' we set \code{self=TRUE} and \code{muliple=TRUE}, then in every step the
#' algorithm will be able to change the state. For more details see
#' Stanton and Pinar (2012) [p. 3.5:9].
#'
#'
#' @section \emph{Endpoints} algorithm:
#'
#' This reconnect either one or both of the endpoints of the edge randomly. As a big
#' difference with the swap algorithm is that this does not preserves the degree
#' sequence of the graph (at most the outgoing degree sequence). The algorithm is
#' implemented as follows:
#'
#' Let \eqn{G} be the baseline graph and \eqn{G'} be a copy of it. Then, For \eqn{l=1} to \eqn{|E|} do:
#'
#' \enumerate{
#'  \item Pick the \eqn{l}-th edge from \eqn{E}, define it as \eqn{e = (i,j)}.
#'  \item Draw \eqn{r} from \eqn{U(0,1)}, if \eqn{r > p} go to the last step.
#'  \item If \code{!undirected & i < j} go to the last step.
#'  \item Randomly select a vertex \eqn{j'} (and \eqn{i'} if \code{both_ends==TRUE}).
#'        And define \eqn{e'=(i, j')} (or \eqn{e'=(i', j')} if \code{both_ends==TRUE}).
#'  \item If \code{!self &} \code{i==j}' (or if \code{both_ends==TRUE & i'==j'}) go to the last step.
#'  \item If \code{!multiple & G'[e']!= 0} then go to the last step.
#'  \item Define \eqn{v = G[e]}, set \eqn{G'[e] = 0} and \eqn{G'[e'] = v} (and the
#'        same to the diagonally opposed coordinates in the case of undirected graphs).
#'  \item Next \eqn{l}.
#' }
#'
#' The endpoints algorithm is used by default in \code{\link{rdiffnet}} and used
#' to be the default in \code{\link{struct_test}} (now \code{swap} is the default).
#'
#' @references
#' Watts, D. J., & Strogatz, S. H. (1998). Collectivedynamics of "small-world" networks.
#' Nature, 393(6684), 440–442. \doi{10.1038/30918}
#'
#' Milo, R., Kashtan, N., Itzkovitz, S., Newman, M. E. J., & Alon, U.
#' (2004). On the uniform generation of random graphs with prescribed degree sequences.
#' Arxiv Preprint condmat0312028, cond-mat/0, 1–4. Retrieved from
#' \url{https://arxiv.org/abs/cond-mat/0312028}
#'
#' Ray, J., Pinar, A., and Seshadhri, C. (2012).
#' Are we there yet? When to stop a Markov chain while generating random graphs.
#' pages 1–21.
#'
#' Ray, J., Pinar, A., & Seshadhri, C. (2012). Are We There Yet? When to Stop a
#' Markov Chain while Generating Random Graphs. In A. Bonato & J. Janssen (Eds.),
#' Algorithms and Models for the Web Graph (Vol. 7323, pp. 153–164).
#' Berlin, Heidelberg: Springer Berlin Heidelberg.
#' \doi{10.1007/978-3-642-30541-2}
#'
#' A . Ramachandra Rao, R. J. and S. B. (1996). A Markov Chain Monte Carlo Method
#' for Generating Random ( 0 , 1 ) -Matrices with Given Marginals. The Indian
#' Journal of Statistics, 58, 225–242.
#'
#' Stanton, I., & Pinar, A. (2012). Constructing and sampling graphs with a
#' prescribed joint degree distribution. Journal of Experimental Algorithmics,
#' 17(1), 3.1. \doi{10.1145/2133803.2330086}
#'
#' @family simulation functions
#' @export
#' @author George G. Vega Yon
#' @examples
#' # Checking the consistency of the "swap" ------------------------------------
#'
#' # A graph with known structure (see Milo 2004)
#' n <- 5
#' x <- matrix(0, ncol=n, nrow=n)
#' x <- as(x, "dgCMatrix")
#' x[1,c(-1,-n)] <- 1
#' x[c(-1,-n),n] <- 1
#'
#' x
#'
#' # Simulations (increase the number for more precision)
#' set.seed(8612)
#' nsim <- 1e4
#' w <- sapply(seq_len(nsim), function(y) {
#'  # Creating the new graph
#'  g <- rewire_graph(x,p=nlinks(x)*100, algorithm = "swap")
#'
#'  # Categorizing (tag of the generated structure)
#'  paste0(as.vector(g), collapse="")
#' })
#'
#' # Counting
#' coded <- as.integer(as.factor(w))
#'
#' plot(table(coded)/nsim*100, type="p", ylab="Frequency %", xlab="Class of graph", pch=3,
#'  main="Distribution of classes generated by rewiring")
#'
#' # Marking the original structure
#' baseline <- paste0(as.vector(x), collapse="")
#' points(x=7,y=table(as.factor(w))[baseline]/nsim*100, pch=3, col="red")
#'
# ' # Compact Alternating Hexagons ----------------------------------------------
# ' x <- matrix(c(0,0,1,1,0,0,0,1,0), ncol=3, nrow=3)
# '
# ' set.seed(123)
# ' nsim <- 1e4
# ' w <- sapply(seq_len(nsim), function(y) {
# '  g <- rewire_graph(x,p=nlinks(x)*20, algorithm = "swap", althexagons=TRUE)
# '  paste0(as.vector(g), collapse="")
# ' })
# '
# ' # Counting
# ' coded <- as.integer(as.factor(w))
# '
# ' plot(table(coded)/nsim*100, type="p", ylab="Frequency %", xlab="Class of graph", pch=3,
# ' main="Distribution of classes generated by rewiring")
# '
# ' # Marking the original structure
# ' baseline <- paste0(as.vector(x), collapse="")
# ' points(x=7,y=table(as.factor(w))[baseline]/nsim*100, pch=3, col="red")
rewire_graph <- function(graph, p,
                         algorithm="endpoints",
                         both.ends=FALSE, self=FALSE, multiple=FALSE,
                         undirected=getOption("diffnet.undirected"),
                         pr.change= ifelse(self, 0.5, 1),
                         copy.first=TRUE, althexagons=FALSE) {

  # Checking undirected (if exists)
  checkingUndirected(graph)

  # althexagons is still on development
  if (althexagons) {
    althexagons <- FALSE
    warning("The option -althexagons- is still on development. So it has been set to FALSE.")
  }

  # Checking copy.first
  # if (missing(copy.first)) copy.first <- FALSE

  cls <- class(graph)
  out <- if ("dgCMatrix" %in% cls) {
    rewire_graph.dgCMatrix(graph, p, algorithm, both.ends, self, multiple, undirected, pr.change, althexagons)
  } else if ("list" %in% cls) {
    rewire_graph.list(graph, p, algorithm, both.ends, self, multiple, undirected, pr.change, copy.first, althexagons)
  } else if ("matrix" %in% cls) {
    rewire_graph.dgCMatrix(
      methods::as(graph, "dgCMatrix"), p, algorithm, both.ends, self, multiple, undirected, pr.change, althexagons)
  } else if ("diffnet" %in% cls) {
    rewire_graph.list(graph$graph, p, algorithm, both.ends, self, multiple,
                      graph$meta$undirected, pr.change, copy.first, althexagons)
  } else if ("array" %in% cls) {
    rewire_graph.array(graph, p, algorithm, both.ends, self, multiple, undirected, pr.change, copy.first, althexagons)
  } else stopifnot_graph(graph)

  # If diffnet, then it must return the same object but rewired, and change
  # the attribute of directed or not
  if (inherits(graph, "diffnet")) {
    graph$meta$undirected <- undirected
    graph$graph <- out
    return(graph)
  }

  attr(out, "undirected") <- FALSE

  return(out)
}

# @rdname rewire_graph
rewire_graph.list <- function(graph, p, algorithm, both.ends, self, multiple, undirected,
                              pr.change, copy.first, althexagons) {
  t   <- length(graph)
  out <- graph

  # Names
  tn <- names(graph)
  if (!length(tn)) tn <- 1:t
  names(out) <- tn

  # Checking p
  if (length(p)==1)
    p <- rep(p, t)

  for (i in 1:t) {

    # Copy replaces the first from 2 to T with 1
    j <- ifelse(copy.first, 1, i)

    out[[i]] <- if (algorithm == "endpoints")
      rewire_endpoints(out[[j]], p[i], both.ends, self, multiple, undirected)
    else if (algorithm == "swap")
      rewire_swap(out[[j]], p[i], self, multiple, undirected, pr.change) #, althexagons)
    else if (algorithm == "qap")
      rewire_qap(out[[j]])
    else stop("No such rewiring algorithm: ", algorithm)

    # Names
    rn <- rownames(graph[[i]])
    if (!length(rn)) rn <- 1:nrow(graph[[i]])
    dimnames(out[[i]]) <- list(rn, rn)
  }

  out
}

# @rdname rewire_graph
rewire_graph.dgCMatrix <- function(graph, p, algorithm, both.ends, self, multiple, undirected, pr.change, althexagons) {
  out <- if (algorithm == "endpoints")
    rewire_endpoints(graph, p, both.ends, self, multiple, undirected)
  else if (algorithm == "swap")
    rewire_swap(graph, p, self, multiple, undirected, pr.change) #, althexagons)
  else if (algorithm == "qap")
    rewire_qap(graph)
  else stop("No such rewiring algorithm: ", algorithm)

  rn <- rownames(out)
  if (!length(rn)) rn <- 1:nrow(out)
  dimnames(out) <- list(rn, rn)
  out
}

# @rdname rewire_graph
rewire_graph.array <-function(graph, p, algorithm, both.ends, self, multiple, undirected,
                              pr.change, copy.first, althexagons) {
  n   <- dim(graph)[1]
  t   <- dim(graph)[3]
  out <- apply(graph, 3, methods::as, Class="dgCMatrix")

  # Checking time names
  tn <- dimnames(graph)[[3]]
  if (!length(tn)) tn <- 1:t
  names(out) <- tn

  return(rewire_graph.list(out, p, algorithm, both.ends, self, multiple, undirected,
                    pr.change, copy.first, althexagons))
}

#' Permute the values of a matrix
#'
#' \code{permute_graph} Shuffles the values of a matrix either considering
#' \emph{loops} and \emph{multiple} links (which are processed as cell values
#' different than 1/0). \code{rewire_qap} generates a new graph \code{graph}\eqn{'}
#' that is isomorphic to \code{graph}.
#' @templateVar self TRUE
#' @templateVar multiple TRUE
#' @template graph_template
#' @author George G. Vega Yon
#' @return A permuted version of \code{graph}.
#' @examples
#' # Simple example ------------------------------------------------------------
#' set.seed(1231)
#' g <- rgraph_ba(t=9)
#' g
#'
#' # These preserve the density
#' permute_graph(g)
#' permute_graph(g)
#'
#' # These are isomorphic to g
#' rewire_qap(g)
#' rewire_qap(g)
#'
#' @references
#'
#' Anderson, B. S., Butts, C., & Carley, K. (1999). The interaction of size and
#' density with graph-level indices. Social Networks, 21(3), 239–267.
#' \doi{10.1016/S0378-8733(99)00011-8}
#'
#' Mantel, N. (1967). The detection of disease clustering and a generalized
#' regression approach. Cancer Research, 27(2), 209–20.
#' \url{https://cancerres.aacrjournals.org/content/27/2_Part_1/209}
#'
#' @seealso This function can be used as null distribution in \code{struct_test}
#' @family simulation functions
#' @export
#' @aliases CUG QAP
permute_graph <- function(graph, self=FALSE, multiple=FALSE) {

  # Changing class
  cls <- class(graph)
  x <- if ("matrix" %in% cls) methods::as(graph, "dgCMatrix")
  else if ("list" %in% cls) lapply(graph, methods::as, Class="dgCMatrix")
  else if ("diffnet" %in% cls) graph$graph
  else if ("array" %in% cls) apply(graph, 3, methods::as, Class="dgCMatrix")
  else if ("dgCMatrix" %in% cls) graph
  else stopifnot_graph(graph)

  if (any(c("list", "array") %in% cls) & !("matrix" %in% cls)) {

    ans <- lapply(x, permute_graph_cpp, self=self, multiple=multiple)

  } else if ("diffnet" %in% cls) {
    ans <- graph
    ans$graph <- lapply(x, permute_graph_cpp, self=self, multiple=multiple)
  } else {
    ans <- permute_graph_cpp(x, self, multiple)
  }

  return(ans)

}

#' @export
#' @rdname permute_graph
rewire_permute <- permute_graph

#' @export
#' @rdname permute_graph
rewire_qap <- function(graph) {

  neword <- order(runif(nnodes(graph)))
  rewirefun <- function(graph) {
    graph[neword, neword]
  }

  # Changing class
  cls <- class(graph)
  x <- if ("matrix" %in% cls) methods::as(graph, "dgCMatrix")
  else if ("list" %in% cls) lapply(graph, methods::as, Class="dgCMatrix")
  else if ("diffnet" %in% cls) graph$graph
  else if ("array" %in% cls) apply(graph, 3, methods::as, Class="dgCMatrix")
  else if ("dgCMatrix" %in% cls) graph
  else
    stopifnot_graph(graph)

  if (any(c("diffnet", "list") %in% cls) | (("array" %in% cls) & length(dim(graph)) == 3L )) {

    ans <- lapply(x, rewirefun)

    if (inherits(graph, "diffnet")) {
      # Naming
      neword <- match(neword, nodes(graph))

      graph$graph <- ans
      graph$graph <- lapply(graph$graph, Matrix::unname)
      graph$meta$ids <- graph$meta$ids[neword]

      # Attributes
      if (nrow(graph$vertex.static.attrs)) {
        graph$vertex.static.attrs <- graph$vertex.static.attrs[neword,,drop=FALSE]
      }
      if (nrow(graph$vertex.dyn.attrs[[1]])) {
        graph$vertex.dyn.attrs <- lapply(graph$vertex.dyn.attrs, function(y) {
          y[neword,,drop=FALSE]
        })
      }

      # Adoptions
      graph$cumadopt <- graph$cumadopt[neword,,drop=FALSE]
      graph$adopt    <- graph$adopt[neword,,drop=FALSE]
      graph$toa      <- graph$toa[neword]

      return(graph)
    }

  } else {
    ans <- rewirefun(x)
  }

  return(ans)
}


  figure.timeseries.snowcrab.habitat = function(p ) {

    td = bio.snowcrab::interpolation.db( p=p, DS="fishable.biomass.timeseries" )

    areas = c("cfa4x", "cfasouth", "cfanorth" )
    regions = c("4X", "S-ENS", "N-ENS")
    td$region = factor(td$region, levels=areas, labels=regions)
    td$sa = td$sa.region

    td = td[is.finite(td$sa) ,]
    td$sa = td$sa / 1000
    td = td[order(td$region, td$yr),]
    xlim=range(td$yr); xlim[1]=xlim[1]-0.5; xlim[2]=xlim[2]+0.5

    fn = file.path( p$annual.results, "timeseries",  "interpolated", "snowcrab.habitat.sa" )
    outdir = dirname( fn )
    dir.create( outdir, recursive=T, showWarnings=F )
    png( filename=paste(fn, "png", sep="."), width=3072, height=2304, pointsize=40, res=300 )

    setup.lattice.options()
    pl = xyplot( sa~yr|region, data=td,
        layout=c(1,3), xlim=xlim, scales = list(y = "free"),
            main="Potential snow crab habitat", xlab="Year", ylab=expression("Surface area; X 10^3 km^2"),
            panel = function(x, y, subscripts, ...) {
            panel.abline(h=mean(y, na.rm=T), col="gray40", lwd=1.5,...)
            panel.xyplot(x, y, type="b", pch=19, lwd=1.5, lty="11", col="black", ...)
#            panel.loess(x,y, span=0.15, lwd=2.5, col="darkblue", ... )
       }
    )
    print(pl)
    dev.off()

    means = tapply(td$sa, td$region, mean, na.rm=T)

    print("mean annual SA X 1000 km^2")
    print(means)
    print("SD:")
    print( tapply(td$sa, td$region, sd, na.rm=T))
    print( "latest year:" )
    print( td$sa[ td$yr==p$year.assessment ])
   # table.view( td )

    return( fn )
  }