## Copyright (c) Facebook, Inc. and its affiliates.
%% id intro.iocost: iocost Parameters and Benchmark
%% graph IoUtil

*The cgroup2 IO cost model based controller*\n
*==========================================*

___*Overview*___

The iocost controller uses an IO cost model to estimate the cost of each IO,
and implements work-conserving proportional control based on the estimated
cost. Each IO is classified as sequential or random and given a base cost
accordingly. On top of that, a size cost proportional to the length of the
IO is added. While simple, this model sufficiently captures the operational
characteristics of a wide variety of devices.

For more high-level explanations of IO control and the io.cost controller,
see the following page.

%% jump comp.cgroup.io           : [ IO Control ]

___*The parameters*___

While the kernel comes with a few sets of default parameters, to achieve a
reasonable level of control, the IO cost model should be configured in
`/sys/fs/cgroup/io.cost.model` according to the specific device, with the
following parameters:

* rbps      - Maximum sequential read BPS\n
* rseqiops  - Maximum 4k sequential read IOPS\n
* rrandiops - Maximum 4k random read IOPS\n
* wbps      - Maximum sequential write BPS\n
* wseqiops  - Maximum 4k sequential write IOPS\n
* wrandiops - Maximum 4k random write IOPS

The cost model is of course an approximation of reality and can't exactly
predict how the hardware is going to behave, especially as the devices
themselves show dynamic performance deviations over time. The controller
adapts to the situation by scaling the total command issue rate according to
the Quality-of-Service parameters - the latency targets and vrate bounds.
The following parameters are configured in `/sys/fs/cgroup/io.cost.qos`.

* rpct      - Read latency percentile to use\n
* rlat      - Read target latency\n
* wpct      - Writ elatency percentile to use\n
* wlat      - Write target latency\n
* min       - vrate bound minimum\n
* max       - vrate bound maximum

The latency targets determine when the controller considers the device fully
saturated. For example, "rpct=95 rlat=5000" means that if the 95th
percentile of read completion latency is above 5ms, the device is at
capacity and command issuing should be throttled.

The QoS vrate bounds express the percentage range of how much the device may
be throttled up and down to meet the latency targets. For example, a range
of 50% - 125% tells the controller to adjust maximum command issue rate
between half and 1.25x of what would add up to 100% according to the cost
model parameters. If `rbps` is 400MBps and the workload is only doing
sequential read, depending on the completion latency, the iocost controller
will allow issuing between 200MBps and 500MBps.

The QoS parameters are affected by both the device itself and, to a lesser
extent, the requirements of the workloads. In most cases, a device's latency
response graph has a point where latency takes off. The device is already
saturated, and adding more concurrent commands simply increases the latency.
Setting target latencies around that point is one way to configure the QoS
parameters.

Another interesting aspect is that vrate range can play a guiding role for
the underlying device. For example, some SSDs can complete a lot of writes
at a very high speed for a short time and then go into a semi-comatose
state, failing to complete other commands for hundreds or even thousands of
milliseconds. While such bursts might look good on simple short benchmarks,
they don't bring a lot of practical benefits and are detrimental to any
latency-sensitive workloads, which may end getting hit by the following
stalls. iocost can avoid such irregularities by limiting vrate max close to
100% so that no matter how quickly the device signals write completion, the
system never issues more than it can sustain.

There are also SSDs that show significantly raised latencies for a while no
matter how few IOs are thrown at it, likely during a certain phase of
garbage collection. In such cases, scaling down command issue rate further
and further doesn't gain anything while losing the total amount of work. The
vrate min bound can protect against such temporary extreme cases.

These are a lot of numbers to configure but they're for the most part device
model specific. In the future, we're hoping to build a database with known
devices and their parameters so they can be configured automatically.

___*The benchmark*___

`/var/lib/resctl-demo/misc-bin/iocost_coef_gen.py` runs as
`rd-bench-iocost.service` and determines both the cost model and QoS
parameters.

The QoS parameters are calculated as 4 times the random IO completion
latency at 90% load and the vrate range is between 25% and 90%. The formulas
are derived empirically to achieve reliable demo behavior across a wide
variety of devices and may not be optimal for other use cases.

Once the benchmarks are complete, the results will be recorded in
`/var/lib/resctl-demo/bench.json` and propagated to
`/sys/fs/cgroup/io.cost.model` and `/sys/fs/cgroup/io.cost.qos`. If you edit
the file, the kernel configurations will be updated accordingly.

You can re-run and cancel hashd benchmark with the following.

%% toggle bench-hashd            : Toggle iocost benchmark

___*Read on*___

%% jump intro.hashd              : [ Next: The rd-hashd Workload Simulator ]


#rm(list=ls())
outFile='PH_scRNA'
parSampleFile1='fileList1.txt'
parSampleFile2='fileList2.txt'
parSampleFile3=''
parFile1='C:/projects/scratch/cqs/shengq2/paula_hurley_projects/20210303_scRNA_human/seurat_sct/result/PH_scRNA.final.rds'
parFile2='C:/projects/scratch/cqs/shengq2/paula_hurley_projects/20210303_scRNA_human/seurat_sct_celltype_rename/result/PH_scRNA.rename_cluster.csv'
parFile3=''
pvalue=0.05;useRawPvalue=0;foldChange=1.5;DE_by_cell=1;filter_minTPM=1;filter_cellPercentage=0.2;bBetweenCluster=1;cluster_name='seurat_renamed_cellactivity_clusters'

setwd('C:/projects/scratch/cqs/shengq2/paula_hurley_projects/20210303_scRNA_human/seurat_sct_celltype_rename_edgeR_betweenCluster_byCell/result')

library(edgeR)
library(ggplot2)
library(ggpubr)
library(Seurat)
library(statmod)

sumcount<-function(ct_count, names, sample_df){
  result<-lapply(names, function(x){
    res<-ct_count[,sample_df$Cell[sample_df$Sample ==x],drop=F]
    apply(res, 1, sum)
  })
  rescount<-do.call(cbind, result)
  colnames(rescount)<-names
  return(rescount)
}

if(!exists('obj')){
  finalList<-readRDS(parFile1)
  obj<-finalList$obj
}

clusterDf<-read.csv(parFile2, stringsAsFactors = F, row.names=1)
clusterDf<-clusterDf[colnames(obj),]
clusterDf$sample<-obj$orig.ident[rownames(clusterDf)]

obj[[cluster_name]]<-clusterDf[names(obj$orig.ident), cluster_name]

sampleGroups<-read.table(parSampleFile1, stringsAsFactors = F)
colnames(sampleGroups)<-c("Sample","Group")

comparisons<-data.frame(Cluster=c("12", "5", "12", "6", "12", "11", "21", "5", "21", "6", "21", "11"),
                                Group=c("Benign", "Tumor", "Benign", "Tumor", "Benign", "Tumor", "Benign", "Tumor", "Benign", "Tumor", "Benign", "Tumor"),
                                Comparison=c("Tumor_5_vs_Benign_12", "Tumor_5_vs_Benign_12",
                                             "Tumor_6_vs_Benign_12", "Tumor_6_vs_Benign_12",
                                             "Tumor_11_vs_Benign_12", "Tumor_11_vs_Benign_12",
                                             "Tumor_5_vs_Benign_21", "Tumor_5_vs_Benign_21",
                                             "Tumor_6_vs_Benign_21", "Tumor_6_vs_Benign_21",
                                             "Tumor_11_vs_Benign_21", "Tumor_11_vs_Benign_21"))
comparisonNames<-unique(comparisons$Comparison)

comp <-comparisonNames[1]

designMatrix<-NULL
for (comp in comparisonNames){
  comp_groups<-comparisons[comparisons$Comparison==comp,]

  cur_groups=unique(comp_groups$Group)

  controlGroup<-cur_groups[1]
  sampleGroup<-cur_groups[2]

  control_names<-sampleGroups$Sample[sampleGroups$Group==controlGroup]
  sample_names<-sampleGroups$Sample[sampleGroups$Group==sampleGroup]

  control_clusters<-comp_groups$Cluster[comp_groups$Group==controlGroup]
  sample_clusters<-comp_groups$Cluster[comp_groups$Group==sampleGroup]

  control_name=paste0(controlGroup, ".", paste(control_clusters, collapse = "."))
  sample_name=paste0(sampleGroup, ".", paste(sample_clusters, collapse = "."))

  prefix<-paste0(outFile, ".", comp, ".edgeR")

  control_cells<-rownames(clusterDf)[clusterDf$seurat_clusters %in% control_clusters & clusterDf$sample %in% control_names]
  sample_cells<-rownames(clusterDf)[clusterDf$seurat_clusters %in% sample_clusters & clusterDf$sample %in% sample_names]

  all_cells<-c(control_cells, sample_cells)

  de_obj<-subset(obj, cells=all_cells)
  de_obj$Group<-c(rep("control", length(control_cells)), rep("sample", length(sample_cells)))
  de_obj$DisplayGroup<-c(rep(control_name, length(control_cells)), rep(sample_name, length(sample_cells)))

  designdata<-data.frame("Group"=de_obj$Group, "Cell"=colnames(de_obj), "Sample"=de_obj$orig.ident, "DisplayGroup"=de_obj$DisplayGroup)
  rm(de_obj)

  designdata$Sample=gsub("_Benign|_Tumor","",designdata$Sample)

  designfile<-paste0(prefix, ".design")
  write.csv(designdata, file=designfile, row.names=F, quote=F)

  curdf<-data.frame(prefix=prefix, cellType="", comparison=comp, sample_in_formula=1, design=designfile, stringsAsFactors = F)
  if (is.null(designMatrix)){
    designMatrix = curdf
  }else{
    designMatrix = rbind(designMatrix, curdf)
  }
}

result<-NULL
idx<-1
for(idx in c(1:nrow(designMatrix))){
  prefix=designMatrix[idx, "prefix"]
  cat(prefix, "\n")

  designfile=designMatrix[idx, "design"]
  cellType=designMatrix[idx, "cellType"]
  comp=designMatrix[idx, "comparison"]
  sample_in_formula=designMatrix[idx, "sample_in_formula"]

  dge_filename <-paste0(prefix, ".csv")
  sigFile<-paste0(prefix, ".sig.csv")
  sigGenenameFile<-paste0(prefix, ".sig_genename.txt")
  gseaFile<-paste0(prefix, "_GSEA.rnk")

  curDF<-data.frame("prefix"=prefix, "cellType"=cellType, "comparison"=comp, "betweenCluster"=bBetweenCluster, "sample_in_formula"=sample_in_formula, "deFile"=dge_filename, "sigFile"=sigFile, "sigGenenameFile"=sigGenenameFile, "gseaFile"=gseaFile, "designFile"=designfile)
  if(is.null(result)){
    result<-curDF
  }else{
    result<-rbind(result, curDF)
  }

  #if(file.exists(gseaFile)){
  #  next
  #}

  designdata<-read.csv(designfile, stringsAsFactors = F)
  groups<-designdata$Group

  de_obj<-subset(obj, cells=designdata$Cell)
  cells<-as.matrix(de_obj[["RNA"]]@counts)

  #filter genes with zero count
  cells<-cells[rowSums(cells)>0,]

  #filter genes by tpm
  tpm = sweep(cells, 2, colSums(cells)/1e6, "/")
  min_sample<-filter_cellPercentage * ncol(cells)
  valid_genes=rowSums(tpm > filter_minTPM)
  keep_rows <- valid_genes >= min_sample
  rm(tpm)

  cat("get GSEA rank file using most detected genes\n")
  if(length(valid_genes) > 10000){
    valid_genes<-valid_genes[order(valid_genes, decreasing = T)]
    gsea_cells<-cells[names(valid_genes[1:10000]),]
  }else{
    gsea_cells<-cells
  }

  cdr <- scale(colMeans(gsea_cells > 0))

  if(sample_in_formula){
    samples<-designdata$Sample
    design <- model.matrix(~ cdr + samples + groups)
    gs<-table(designdata$Group, designdata$Sample)
    notpaired_samples<-colnames(gs)[colSums(gs> 0)==1]
    design<-design[, !(colnames(design) %in% paste0("samples", notpaired_samples))]
  }else{
    design <- model.matrix(~ cdr + groups)
  }

  rownames(design)<-colnames(gsea_cells)
  dge<-DGEList(gsea_cells, group=groups)
  cat("  calcNormFactors", "\n")
  dge<-calcNormFactors(dge)

  cat("  estimateDisp", "\n")
  dge<-estimateDisp(dge,design=design)

  cat("  glmQLFit", "\n")
  fitqlf<-glmQLFit(dge,design=design,robust=TRUE)
  qlf<-glmQLFTest(fitqlf)
  out<-topTags(qlf, n=Inf)
  rankout<-data.frame(gene=rownames(out), sigfvalue=sign(out$table$logFC) * out$table$F)
  write.table(rankout, file=gseaFile, row.names=F, col.names=F, sep="\t", quote=F)

  cat("now perform DE with filtered genes, filter genes by tpm\n")

  cells<-cells[keep_rows,]
  cdr <- scale(colMeans(cells > 0))

  if(sample_in_formula){
    samples<-designdata$Sample
    design <- model.matrix(~ cdr + samples + groups)
    gs<-table(designdata$Group, designdata$Sample)
    notpaired_samples<-colnames(gs)[colSums(gs> 0)==1]
    design<-design[, !(colnames(design) %in% paste0("samples", notpaired_samples))]
  }else{
    design <- model.matrix(~ cdr + groups)
  }

  rownames(design)<-colnames(cells)
  write.csv(design, file=paste0(prefix, ".design_matrix.csv"), quote=F)

  dge<-DGEList(cells, group=groups)
  cat("  calcNormFactors", "\n")
  dge<-calcNormFactors(dge)

  cat("  estimateDisp", "\n")
  dge<-estimateDisp(dge,design=design)

  cat("  glmQLFit", "\n")
  fitqlf<-glmQLFit(dge,design=design,robust=TRUE)
  qlf<-glmQLFTest(fitqlf)
  out<-topTags(qlf, n=Inf)
  dge_filename <-paste0(prefix, ".csv")
  write.csv(out$table, file=dge_filename, quote=F)

  if(useRawPvalue){
    sigout<-out$table[(out$table$PValue<=pvalue) & (abs(out$table$logFC)>=log2(foldChange)),]
  }else{
    sigout<-out$table[(out$table$FDR<=pvalue) & (abs(out$table$logFC)>=log2(foldChange)),]
  }
  sigFile<-paste0(prefix, ".sig.csv")
  write.csv(sigout, file=sigFile, quote=F)

  siggenes<-data.frame(gene=rownames(sigout), stringsAsFactors = F)
  write.table(siggenes, file=sigGenenameFile, row.names=F, col.names=F, sep="\t", quote=F)
}

write.csv(result, file=paste0(outFile, ".edgeR.files.csv"), quote=F)


#+---------------------------------------------------------------------------------------------------------------------+
#| 1.a. FIX.EVIDENCE: (v. 1)                                                                                |
#|                                                                                |
#| This function fixes the evidence.txt as follows:                                                                    |
#| If we have similar peptides, this function takes the sequence i and:                                                |
#| Sets PEP as min(PEP(i)),                                                                                |
#| and RT as median(Retention.times(i)).                                                                               |
#| Also evidence.txt will be shrinked and filtered to PEP<0.05 to occupy less memory.                                  |
#| The output ev.ed.txt will be used for making the library and selecting the reference experiment.                    |
#|                                                                                |
#| Example: fix.evidence(path.in = 'C:/../evidence.txt',                                                               |
#|                      path.out = 'C:/../ev.ed.txt')                                                                  |
#|                                                                                |
#+---------------------------------------------------------------------------------------------------------------------+

fix.evidence.elite <- function(path.in, path.out){
  # load data ---------------------------------------------------------------

  # load tab-delimited files, with only the columns specified below
  ev <- read_tsv(path.in,
                 col_types=cols_only(
                   Sequence=col_character(),
                   `Raw file`=col_character(),
                   `Retention time`=col_number(),
                   PEP=col_number()
                 ))
  # change column names
  colnames(ev) <- c('Sequence','Raw.file','Retention.time','PEP')
  # only take peptides with PEP < 0.05
  ev <- ev[ev$PEP<0.05,]

  # get the list of all experiments (raw files) in the input file
  exps <- unique(ev$Raw.file)

  # exclude some experiments here??
  exps <- exps[grep('[0-9]{6}?A', exps)]

  # create output table
  all.exps <- data.frame(Raw.file=character(),
                         Sequence=character(),
                         PEP=numeric(),
                         Retention.time=numeric())

  # Consolidate Peptides ----------------------------------------------------

  # loop thru experiments
  counter <- 0
  for (i in exps) {
    # get current experiment
    exp <- subset(ev, ev$Raw.file==i)

    counter <- counter + 1
    cat('\r', 'Processing ', counter, '/', length(exps), ' ', i,  '                                          ')
    flush.console()

    # count # of "scans"/IDs for each peptide
    # some of these will come from consolidated PSMs, and will not be further consolidated because
    # of different charges, i.e., +1, +2
    pep.frqs <- as.data.frame(table(exp$Sequence))

    # get peptides where we have more than one "scan"
    red.peps.list <- as.character(pep.frqs[pep.frqs$Freq>1, 'Var1'])
    # for these peptides, take the smallest PEP and the median RT
    red.peps <- data.frame(Raw.file=as.character(rep(i, length(red.peps.list))),
                           Sequence=as.character(rep(NA, length(red.peps.list))),
                           PEP=as.numeric(rep(NA, length(red.peps.list))),
                           Retention.time=as.numeric(rep(NA, length(red.peps.list))),
                           stringsAsFactors=FALSE)
    if(length(red.peps.list) > 0) {
      for (j in 1:length(red.peps.list)) {
        red.peps$Sequence[j] <- red.peps.list[j]
        # smallest PEP
        red.peps$PEP[j] <- min(unlist(
          exp[exp$Sequence==red.peps.list[j], 'PEP']
        ))
        # median retention time
        red.peps$Retention.time[j] <- median(unlist(
          exp[exp$Sequence==red.peps.list[j], 'Retention.time']
        ))
      }
    }

    # consolidate list so that all peptides have a unique PEP and RT
    exp <- rbind(red.peps, exp[!(exp$Sequence %in% red.peps.list), ])
    # add to output table
    all.exps <- rbind(all.exps, exp)
  }

  # Write Output ------------------------------------------------------------

  # scrub row names
  row.names(all.exps) <- NULL
  # write to output file - ev.ed.txt
  write.table(all.exps, path.out, sep = '\t', row.names = FALSE, quote = FALSE)
}


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

## Author: Zach Rivers, @riverspharmd, zrivers@fredhutch.org
## Contributors:

## Purpose: This file runs the logistic regression model for bivariate logreg.

## Depends on:
## 07PredictorExploration.r
## 10COSTTidyJoin.r
## tidyverse
## gtsummary
## flextable

## Input:
## IntData/dat_wide.csv
## IntData/cost.csv

## Output:
## OutData/uv_lr_*.docx

## NOTE: This scoring system is inverse of COST scoring, where 0 is no FT and 1
## is FT.

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

# Packages______________________________________________________________________
library(tidyverse)
library(gtsummary)
library(flextable)

# Functions_____________________________________________________________________
source("00Functions.r")

bounded_style_ratio <- function(x, min = -Inf, max = Inf, ...) {
    purrr::map_chr(
        x,
        function(x) {
            if (isTRUE(x < min)) {
                return(paste0("<", gtsummary::style_ratio(min, ...)))
            }
            if (isTRUE(x > max)) {
                return(paste0(">", gtsummary::style_ratio(max, ...)))
            }
            gtsummary::style_ratio(x, ...)
        }
    )
}
# Data In_______________________________________________________________________

## Predictors

pred_wide <- read_csv(
    "IntData/dat_wide.csv"
)

## COST

cost <- read_csv("IntData/cost.csv",
    col_types = "ccccn"
)

# Data Prep_____________________________________________________________________

## Clean COST

cost <- cost %>%
    dplyr::filter(observation == "con_dich") %>%
    select(-survey) %>%
    rename("con" = score) %>%
    mutate(con = as_factor(if_else(con > 0, 1, con))) %>%
    select(-observation)

## Split COST by timepoint
cost_list <- cost %>%
    group_by(redcap_event_name) %>%
    group_split()

## Clean Predictors

### Factor

pred_wide <- label_factors(dat = pred_wide)

### caregiver
#### Split out data
care_wide <- pred_wide %>%
    filter(source == "Caregiver")

#### Select columns that are caregiver specific
care_wide <- care_wide %>%
    select(partid,
        "age_c" = age,
        "gender_c" = gender,
        "ethnicity_c" = ethnicity,
        "race_c" = race,
        "education_c" = education,
        "comorbid_sum_c" = comorbid_sum
    )

### Patient

#### Pull out data
pat_wide <- pred_wide %>%
    filter(source == "Patient")

#### Rename columns

pat_wide <- pat_wide %>%
    select(partid,
        "age_p" = age,
        "gender_p" = gender,
        "ethnicity_p" = ethnicity,
        "race_p" = race,
        "education_p" = education,
        "comorbid_sum_p" = comorbid_sum,
        everything()
    ) %>%
    select(-source)

### Rejoin predictors

pred_wide <- pat_wide %>%
    left_join(care_wide) %>%
    mutate(partid = as.character(partid))

### pull out factor predictor names

pred_names <- pred_wide %>%
    select(-partid) %>%
    select(where(is.factor)) %>%
    names()

## Join with outcomes

cost_list <- cost_list %>%
    map(~ left_join(
        x = .,
        y = pred_wide,
        by = "partid"
    ))

# Run Models____________________________________________________________________
## Logistic Regression----------------------------------------------------------
### Build empty list
lr_list <- list()

### loop over timepoints
for (i in 1:4) {
    lr_list[[i]] <- cost_list[[i]] %>%
        select(-c(redcap_event_name, partid)) %>%
        filter(is.na(age_p) == FALSE) %>%
        tbl_uvregression(
            y = con,
            method = glm,
            method.args = list(family = binomial),
            exponentiate = TRUE,
            estimate_fun = purrr::partial(bounded_style_ratio, min = 0.001, max = 10)
        ) %>%
        modify_footnote(c(estimate, ci) ~ "ORs <0.001 or larger than 10 shown as '<0.001' and '>10.00'") %>%
        as_flex_table()
}

## Crosstables------------------------------------------------------------------
### Build empty list
ct_list <- list()
tp_list <- list()

### loop over timepoints
for (i in 1:4) {
    dat_in <- cost_list[[i]] %>%
        select(-c(redcap_event_name, partid)) %>%
        filter(is.na(age_p) == FALSE)

    for (z in seq_along(pred_names)) {
        row_var <- pred_names[[z]]
        tp_list[[z]] <- tbl_cross(
            data = dat_in,
            row = row_var,
            col = con
        ) %>%
            add_p()
    }
    dat <- tbl_stack(
        tbls = tp_list
    ) %>%
        as_flex_table()

    ct_list[[i]] <- dat
}

# Data Out _____________________________________________________________________
## Path-------------------------------------------------------------------------
start <- "OutData/"
end <- ".docx"

## Loop over print function-----------------------------------------------------
for (i in 1:4) {

    ### Logistic Regression
    fn <- "uv_lr_"
    save_as_docx(
        lr_list[[i]],
        path = paste0(
            start,
            fn,
            i,
            end
        )
    )
    ### Crosstables
    fn <- "crosstab_"
    save_as_docx(
        ct_list[[i]],
        path = paste0(
            start,
            fn,
            i,
            end
        )
    )
}


################### DESCRIPTION v 3 marzo 2020 ##################
# This code performs the correction on minION reads of amplicons
# described in Espada et al. 2020.
# Please include your inputs in the "INPUTS" section before running it
# Take into account that several intermediate files will be stored during the process.

# Input should be sequences aligned with LAST to the wild type reference
# Output will be table of Q scores observed in each library (corrected and not). Columns are:
# "position" "nucleotide" "counts" "qualityQ" "p_error_minION" "wt.base" "isWT" "p_right_priors_model" "p_right_null_model"

# INPUTS
# working_path:            It should have the output of LAST alignments. Several auxiliary files and final results will be saved in it.
# filename_wildtype:       .maf file that will be used for training the model
# filename_to_evaluate:    It should be a vector with the names of all the files that you want to be evaluated
# LAST_reference_label:    When you align using LAST, the rows with the reference sequence (wild type here) is tagged with some name you've chosen. Indicate this tag in LAST_reference_label, that will be used for parsing LAST files
# length_sequencing:       Length of the reference sequence you used in LAST
# ORF_ini and ORF_end:     If the reference sequence is longer than the ORF or the interesting fragment you want to analyse, indicate inital and last positions of the ORF in the reference sequence
# reference_sequence:     Wildtype or reference sequence. Use on string as in the example.
# For priors of mutations you should provide either:
#    I. mutationratePCR (a matrix 4x4 with the mutation rate of the PCR, in the order a c g t, provided by the kit you used), and
#    mean.n.mut the mean number of mutations indtroduced. This depends on your experimental characteristics.
#    II. Or the file (file_prior_mutations) where the prior values are stored in the form of a table of 3 columns:
#    from (nucleotide) | to (nucleotide) | value
#    If file_prior_mutations is provided, it will be preferred.

#################### INPUTS ####################
working_path         =  #filename/character
filename_wildtype    =  #filename/character
filename_to_evaluate =  #filename/character
LAST_reference_label =  #character
length_sequencing    =  #integer
ORF_ini              =  #integer
ORF_end              =  #integer
reference_sequence   =  #character: sequence DNA quoted
mutationratePCR      =  matrix(c(   NA,  14.1,  25.5,  28.5,
                                   4.7,    NA,   4.1,  17.5,
                                   17.5,   4.1,    NA,   4.7,
                                   28.5,  25.5,  14.1,    NA,
                                   1.2, 1.2, 1.2, 1.2), ncol=5,nrow=4)/100
mean.n.mut           =  #integer

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

require(minIONLogReg)
setwd(working_path)
reference_sequence <- strsplit(reference_sequence, "")[[1]]
colnames(mutationratePCR) <-bases; rownames(mutationratePCR) <- bases[-c(5)]

LRminion_train_model(filename_wildtype, LAST_reference_label, length_sequencing, ORF_ini,ORF_end, auxiliary_files=NULL)
LRminion_evaluate_model(filename_to_evaluate, filename_wildtype,LAST_reference_label, length_sequencing, ORF_ini,ORF_end,reference_sequence, auxiliary_files=NULL)


## This script calculates polygenic scores for handedness
## based on a recent handedness GWAS (with LD adjustments using LDpred)
## and calculates DNA methylation scores for handedness
## in ALSPAC using EWAS summary statistics calculated in the NTR study
## in children and parents.
## It then tests associations between these scores and handedness.
## The results are saved to output.dir/scoring-stats.csv.

source("settings.r")

## directory for all data as well as output files
data.dir <- file.path(project.dir, "working", "data")

## directory for ALSPAC data
alspac.dir <- "~/work/alspac/data"

## directory for ALSPAC genotype data
geno.dir <- file.path(data.dir, "alspac")

## intermediate files directory
dir.create(object.dir <- file.path(data.dir, "objects"))

## directory for output files
dir.create(output.dir <- file.path(data.dir, "output"))

## directory for files needed to calculate polygenic scores
dir.create(pgs.dir <- file.path(data.dir, "pgs-files"))

## contains coefficients for GWAS and EWAS models of
## handedness generated in NTR
ntr.dir <- file.path(data.dir, "ntr")

## https://github.com/explodecomputer/alspac
library(alspac)
alspac::setDataDir(alspac.dir)

## https://github.com/perishky/eval.save
library(eval.save)
eval.save.dir(object.dir)

source("load-list-function.r")
## out: load.list()

source("load-aries-function.r")
## out: load.aries()

source("my-load-aries-function.r")
## out: my.load.aries()

## load/install R packages
source("load-packages-function.r")
## out: load.packages()

source("scatterplot-function.r")
## out: scatterplot()

## load microarray annotation
source("load-annotation.r")
## out: annotation

## load alspac data
source("load-alspac.r")
## out: alspac.table

## https://github.com/perishky/ewaff
library(ewaff)
## https://github.com/perishky/dmrff
library(dmrff)

## extract genotype data for ALSPAC
## (includes script to be run on bluecrystalp3, takes ~6 hours)
source("extract-genotypes.r")
## out: geno.dir/genotype/children.{bed,fam,bim}
##      geno.dir/genotype/mother.{bed,fam,bim}
##      geno.dir/genotype/snps.bim.gz

## prep gwas summary statistics file for LDpred
source("prep-gwas-summary-statistics.r") ## 10 minutes
## in: ntr.dir/data/Meta_RvL_no23andMe_noALSPAC_noNTR1.txt.sorted.tsv
##     geno.dir/genotype/snps.bim.gz
## out: pgs.dir/handedness-gwas-summary-stats-STANDARD.txt

## calculate handedness PGS in mothers and children
## (includes script to be run on bluecrystalp3, takes ~26 hours per score)
source("load-pgs.r")
## in: pgs.dir
## out: alspac.table$pgs.mom/pgs.child

alspac.table$pgs.mom <- -scale(alspac.table$pgs.mom)
alspac.table$pgs.child <- -scale(alspac.table$pgs.child)

## see how handedness relates to pgs
source("check-pgs.r")
## in: alspac.table$pgs.mom/child
##     and alspac.table$handed/handed.mom/handed.partner

library(foreign)
library(readstata13)
## Add ALSPAC ancestry PCs to alspac.table
source("load-alspac-ancestry.r")
## in: data.dir/alspac/ancestry-pca/
## out: alspac.table$ancestry.child/mom.pc1-10

## Get lists of unrelated children and mothers
source("load-unrelated.r")
## in: data.dir/alspac/unrelated/
## out: unrelated.children, unrelated.mothers
unrelated.mothers <- sub("M", "", unrelated.mothers)

## thresholds for building methylation scores
thresholds <- c(1e-1, 1e-3, 1e-5)

## load R package for calculating methylation scores
## https://github.com/perishky/meffonym
library(meffonym)

## add NTR meth score models to meffonym
## so that scores can be calculated using
## meffonym.score(methylation,modelname)
source("load-pms-models.r")
## in: ntr.dir/data/NTR_ewas_hand01_.*
## out: models "child.handedness0.1/0.001/1e-5"
##         and "adult.handedness0.1/0.001/1e-5"
##      added to meffonym

adult.time.points <- c("antenatal","FOM")#,"FOF","parents")
child.time.points <- c("cord","F7","15up","F24")
time.points <- c(child.time.points,adult.time.points)

## calculate handedness methylation scores in mothers and children
source("load-pms.r")
## in: time.points, meffonym.models(), meffonym.score(),
##     aries.dir, my.load.aries()
## out: alspac.table$[time.points]x[ms.models]

## prep datasets for PGS models
source("prep-pgs-model-datasets.r")
## in: alspac.table, time.points, child.time.points, adult.time.points
## out: pgs.dat

## extract covariate data used for EWAS models
## (will be used to construct datasets for PMS models)
source("extract-ewas-covariate-datasets.r")
## in: aries.dir (to load aries samplesheets),
##     eval.ret() (to load saved EWAS R data files)
## out: ewas.dat

## construct datasets for PGS models
## (but restricted to samples with methylation)
sub.dat <- sapply(time.points, function(time) {
    pgs.dat[[time]][match(ewas.dat[[time]]$id, pgs.dat[[time]]$id),]
}, simplify=F)

## prep datasets for PMS models
source("prep-pms-model-datasets.r")
## in: sub.dat, ewas.dat, time.points, child.time.points, adult.time.points
##     alspac.table (with PMS variables)
## out: pms.dat

## remove related individuals from the ALSPAC dataset with genetic data (pgs.dat)
for (time in c("cord","F7","15up","F24"))
    pgs.dat[[time]] <- pgs.dat[[time]][which(pgs.dat[[time]]$id %in% unrelated.children),]

for (time in c("antenatal","FOM"))
    pgs.dat[[time]] <- pgs.dat[[time]][which(pgs.dat[[time]]$id %in% unrelated.mothers),]

## check datasets
sapply(pgs.dat, dim)
sapply(sub.dat, dim)
sapply(pms.dat, function(dats) sapply(dats, nrow))
sapply(pms.dat, function(dats) sapply(dats, ncol))
sapply(pgs.dat, function(dat) "id" %in% colnames(dat))
sapply(sub.dat, function(dat) "id" %in% colnames(dat))
sapply(pms.dat, function(dats) sapply(dats, function(dat) "id" %in% colnames(dat)))
## > sapply(pgs.dat, dim)
##      cord   F7 15up  F24 antenatal  FOM
## [1,] 7873 7873 7873 7873      7848 7848
## [2,]   14   14   14   14        13   13
## > sapply(sub.dat, dim)
##      cord  F7 15up F24 antenatal FOM
## [1,]  688 742  641 430       792 707
## [2,]   14  14   14  14        13  13
## > sapply(pms.dat, function(dats) sapply(dats, nrow))
##                       cord  F7 15up F24 antenatal FOM
## child.handedness0.001  688 742  641 430       792 707
## child.handedness0.1    688 742  641 430       792 707
## child.handedness1e-05  688 742  641 430       792 707
## > sapply(pms.dat, function(dats) sapply(dats, ncol))
##                       cord F7 15up F24 antenatal FOM
## child.handedness0.001   45 45   44  44        43  43
## child.handedness0.1     45 45   44  44        43  43
## child.handedness1e-05   45 45   44  44        43  43
## > sapply(pgs.dat, function(dat) "id" %in% colnames(dat))
##      cord        F7      15up       F24 antenatal       FOM
##      TRUE      TRUE      TRUE      TRUE      TRUE      TRUE
## > sapply(sub.dat, function(dat) "id" %in% colnames(dat))
##      cord        F7      15up       F24 antenatal       FOM
##      TRUE      TRUE      TRUE      TRUE      TRUE      TRUE
## > sapply(pms.dat, function(dats) sapply(dats, function(dat) "id" %in% colnames(dat)))
##                       cord   F7 15up  F24 antenatal  FOM
## child.handedness0.001 TRUE TRUE TRUE TRUE      TRUE TRUE
## child.handedness0.1   TRUE TRUE TRUE TRUE      TRUE TRUE
## child.handedness1e-05 TRUE TRUE TRUE TRUE      TRUE TRUE

sapply(pgs.dat, dim)
##      cord   F7 15up  F24 antenatal  FOM
## [1,] 7873 7873 7873 7873      7848 7848
## [2,]   14   14   14   14        13   13

## function to fit logistic regression models for PGS/PMS
## dat: dataset
## var: variable(s) of interest, either "pgs" or "pms" or both
fit.handed.model <- function(dat, var, show=var) {
    dat$id <- NULL
    dat <- na.omit(dat)
    null <- dat
    null[[var]] <- NULL
    full <- glm(handed ~ ., dat, family=binomial(link="logit"))
    base <- glm(handed ~ ., null, family=binomial(link="logit"))
    n <- length(residuals(full))
    stats <- coef(summary(full))
    colnames(stats) <- c("estimate","se","z","p")
    stats <- stats[which(rownames(stats)==show),]
    c(stats,
      n=n,
      var.full=var(predict(full)),
      var.base=var(predict(base)))
}

## fit PGS models
stats.pgs <- t(sapply(pgs.dat, fit.handed.model, var="pgs"))
stats.pgs <- data.frame(time=rownames(stats.pgs),
                       model="handedness ~ pgs + pgs covs",
                       pms="",
                       score="pgs",
                       stats.pgs)

## fit PGS models restricted to samples with methylation
stats.sub <- t(sapply(sub.dat, fit.handed.model, var="pgs"))
stats.sub <- data.frame(time=rownames(stats.sub),
                       model="handedness ~ pgs + pgs covs",
                       pms="",
                       score="pgs",
                       stats.sub)

## fit PMS+PGS models, report PMS
stats.pms <- do.call(rbind, lapply(names(pms.dat), function(time) {
    stats <- t(sapply(pms.dat[[time]], fit.handed.model, var="pms"))
    data.frame(time=time,
               model="handedness ~ pms + pgs + pms covs + ewas covs",
               pms=names(pms.dat[[time]]),
               score="pms",
               stats)
}))
stats.pms$pms <- sub(".handedness", " p<", stats.pms$pms)

## fit PGS+PMS models, report PGS
stats.pgss <- do.call(rbind, lapply(names(pms.dat), function(time) {
    stats <- t(sapply(pms.dat[[time]], fit.handed.model, var="pgs"))
    data.frame(time=time,
               model="handedness ~ pms + pgs + pms covs + ewas covs",
               pms=names(pms.dat[[time]]),
               score="pgs",
               stats)
}))
stats.pgss$pms <- sub(".handedness", " p<", stats.pgss$pms)

## Calculate variance explained according to:
##  > Sang Hong Lee, Michael E Goddard, Naomi R Wray, and Peter M Visscher
##  > A Better Coefficient of Determination for Genetic Profile Analysis
##  > Genetic Epidemiology 36 : 214–224 (2012)
stats <- rbind(stats.pgs, stats.sub, stats.pms, stats.pgss)
rownames(stats) <- NULL
stats$r2.full <- stats$var.full/(stats$var.full + pi^2/3)
stats$r2.base <- stats$var.base/(stats$var.base + pi^2/3)
stats$r2.diff <- stats$r2.full-stats$r2.base

## save results
write.csv(stats, file=file.path(output.dir, "scoring-stats.csv"),
          row.names=F)


  get.move = function( redo=F ) {
    move = NULL
    tags.datadir= file.path( project.datadirectory("bio.snowcrab"), "data", "tagging" )

    fn =file.path( tags.datadir, paste("move", "rdata", sep="." ) )

    if ( !redo ) {
      load( fn )
      return (move)
    }

    recaps = get.recaps (DS="file")
    marked = get.marked (DS="file")
    marked2 =  read.table( file.path(tags.datadir, "tags_summary1993_2005.csv" ), sep=";", header=T, as.is=T)

    v0 = c("tagID", "timestamp", "lon", "lat", "cw", "ch", "cc", "z.fm", "area" )
    v1 = c("tagID", "timestamp", "lon", "lat", "cw", "ch", "cc", "fisherman", "z.fm", "duro", "Comments")
    move = merge(x=recaps[,v1], y=marked[,v0], by="tagID" , sort=F, all.x=T, all.y=F, suffixes=c("1","0") )

    strange = NULL
    strange = which(move$lon1 < -66)
    strange = c(strange, which(move$lon1 < -62 & move$lat1 > 45 & move$lat0 < 45) )

    move = move[ -strange, ]
    dim(move)

    # fix data with no starting positions
    no.data = which( is.na(move$lon0 + move$lat0) )
    for (i in no.data) {
      studyid = determine.origin(move[i,"tagID"])
      if (!is.null(studyid)){
          s = marked2[studyid, c("lon", "lat", "yr")]
          move$lon0[i] = s$lon
          move$lat0[i] = s$lat
          if ( is.na(move$timestamp0[i])) move$timestamp0[i] = lubridate::ymd( paste(s$yr, 12, 1, sep="-") )
        }
    }
    move$dt = difftime( move$timestamp1, move$timestamp0, units="days" )
    r = which(move$dt > -365 & move$dt < 0)
    move[r, "dt"] = 4*31  # caught in same season .. assume length of fishing season ~ 4 months

    move$dx = geosphere::distGeo( move[, c("lon0", "lat0")], move[, c("lon1", "lat1")])/1000 # m -> km

    save(move,  file=fn, compress=T)
    return (move)
  }


# ------------------------------------------------
# Create unerlying areal units for modelling of bathymetry, etc using lattice methods via carstm

for ( areal_units_resolution_km in c(10, 20, 25) ) {
  # for ( spatial_domain in c("snowcrab", "SSE")) {
   for ( spatial_domain in c("snowcrab", "SSE")) {
    areal_units_overlay = "snowcrab_managementareas"
    if ( spatial_domain=="SSE") areal_units_overlay = "groundfish_strata"
    p = carstm::bathymetry_carstm(
      DS = "parameters",
      project_class = "carstm", # defines which parameter set to load
      inputdata_spatial_discretization_planar_km = 1,  # 1 km .. requires 32 GB RAM and limit of speed -- controls resolution of data prior to modelling to reduce data set and speed up modelling
      spatial_domain = spatial_domain,  # defines spatial area
      areal_units_resolution_km = areal_units_resolution_km, # km dim of lattice
      areal_units_proj4string_planar_km = projection_proj4string("utm20"),  # coord system to use for areal estimation and gridding for carstm
      # areal_units_proj4string_planar_km = "+proj=omerc +lat_0=44.0 +lonc=-63.0 +gamma=0.0 +k=1 +alpha=325 +x_0=0 +y_0=0 +ellps=WGS84 +units=km",  # oblique mercator, centred on Scotian Shelf rotated by 325 degrees
      areal_units_source = "lattice", # "stmv_fields" to use ageis fields instead of carstm fields ... note variables are not the same
      areal_units_overlay = areal_units_overlay, # additional polygon layers for subsequent analysis such as management area: "snowcrab" or "groundfish"  # for now ..
      areal_units_constraint="none", # set[, c("lon", "lat")],  # to limit to sppoly to only those with data that fall into them
      libs = RLibrary ( "sp", "rgeos", "INLA", "raster", "aegis",  "aegis.polygons", "aegis.bathymetry", "carstm" )
    )

    sppoly = areal_units( p=p, redo=TRUE )

  }

}

# Roll your own polygon via mouse interaction

# Example

  # load helper functions
  project.library( "aegis" )
  Rlibrary( "rgdal", "sp", "raster", "maps", "mapdata")

  p = list() # start parameter list

  # define "extents" or "bounding box" in lon/lat
  p$xlim = c(-72, -56 ) # longitudes
  p$ylim = c(42, 49) # latitudes
  p$regions = c("Canada", "USA") # library "map" polygon designations
  p$output.directory = project.datadirectory("aegis", "data","Science")
  p$output.filename = "test.dat"   # must have an "extention" like dat or txt etc,

  # plot background map and using mouse interaction define region:
  # left mouse click to register, right mouse click to finish (or [Esc] is using Rstudio)
  polygon.db( DS="create", p=p )

  # Access method 1: low level
  # read the data with read.table or read.csv
  polygon.db( DS="map.background", p=p )
  scotianshelf = read.table( aegis.polygons::polygon_file( "test"  ) )
  lines( scotianshelf, col="green" )  # plot to confirm we have the right data

  # Access method 2: medium
  polygon.db ( DS="map.background", p=p )
  scotianshelf = polygon.db( polyid="test" )
  lines( scotianshelf, col="orange" )

  # Access method 3: one step .. just the data (projected or not)
  scotianshelf = polygon.db( polyid="test", crs="+proj=utm +ellps=WGS84 +zone=20 +units=km" )

  # Access method 4: one step data and plot it too
  scotianshelf = polygon.db( polyid="test", crs="+proj=utm +ellps=WGS84 +zone=20 +units=km", p=p, plotmap=TRUE ) # p contains the extent


#' Module that best explains the patient similarity assigned between a set of patients.
#'
#' @param patientSim - A similarity matrix, where row and columns are patient identifiers.
#' @param data_mx - The matrix that gives the perturbation strength (z-scores) for all variables (columns) for each patient (rows).
#' @param ptIDs - The identifier associated with patient 1's sample.
#' @param ig_pruned - The list of igraph objects associated with the integrated, pruned disease+reference differential interaction networks.
#' @param kmx - The maximum metabolite set size probed when assessing patient similarity.
#' @return ptsim_blowout - An igraph object showing the module blowout describing the similarity between patients in ptIDs.
#' @export mle.blowoutSim
#' @examples
#' require(CTD)
#' data(Thistlethwaite2019)
#' data_mx = as.matrix(data_mx)
#' data_mx = suppressWarnings(apply(data_mx, c(1,2), as.numeric))
#' data_mx = data_mx[,-c(1,2,3,4,5,6,7,8)]
#' # Load your background network, ig_pruned and your computed patientSim matrix
#' kmns.clust = kmeans(patientSim, centers=4)
#' table(kmns.clust$cluster)
#' ptIDs = names(kmns.clust$cluster[which(kmns.clust$cluster==1)])
#' ptsim_blowout = mle.blowoutSim(patientSim, data_mx, ptIDs, ig_pruned, kmx=15)
#' plot.igraph(ptsim_blowout, layout=layout.circle, edge.width=50*abs(E(ptsim_blowout)$weight))
mle.blowoutSim = function(patientSim, data_mx, ptIDs, ig_pruned, kmx) {
  allmets = unique(unlist(lapply(ig_pruned, function(i) V(i)$name)))
  data_mx = data_mx[which(rownames(data_mx) %in% allmets),]
  # Get all metabolites in top kmx perturbations for all patients in ptIDs.
  # Score node based on how many patient perturbation sets it occurs
  pt_mets = sort(table(as.vector(sapply(ptIDs, function(i) rownames(data_mx)[order(abs(data_mx[,i]), decreasing = TRUE)][1:kmx]))), decreasing = TRUE)
  # Select nodes and edges based on being ranked in top 10% of each scoring.
  selected_nodes = names(pt_mets[which(pt_mets>quantile(pt_mets, 0.50))])
  if (length(grep("x -", selected_nodes)>0)) {
    selected_nodes = selected_nodes[-grep("x -", selected_nodes)]
  }

  ptsim_blowout = make_empty_graph(directed=FALSE)
  if (length(selected_nodes)>1) {
    # Rank edges between metabolite nodes by order of strength (absolute value) across all networks in ig_pruned.
    # Keep adding until all nodes are included in a tree
    for (i in 1:length(ig_pruned)) {
      ig = ig_pruned[[i]]
      selected_nodes_ig = selected_nodes[which(selected_nodes %in% V(ig)$name)]
      e_ids = sort(unique(apply(combn(selected_nodes_ig, 2), 2, function(i) get.edge.ids(ig, i))))
      if (any(e_ids==0)) { e_ids= e_ids[-which(e_ids==0)]}
      if (length(e_ids)>0) {
        e_list = get.edgelist(ig)
        e_list2 = e_list[e_ids,]
        if (class(e_list2)=="matrix") {
          rank_edges = e_list2[order(abs(E(ig)$weight[e_ids]), decreasing = TRUE),]
          rank_edgeweights = E(ig)$weight[e_ids][order(abs(E(ig)$weight[e_ids]), decreasing = TRUE)]
          # Rank nodes, display ranked nodes. Node size in blowout is rank of node.
          ind = which(abs(rank_edgeweights)>quantile(abs(E(ig)$weight), 0.95))
          if (length(ind)>1) {
            rank_edges = rank_edges[ind,]
            rank_edges = rank_edges[which(apply(rank_edges, 1, function(i) any(i %in% selected_nodes_ig))),]
          }
          e_ids2 = sort(apply(rank_edges, 1, function(i) get.edge.ids(ig, i)))
        } else {
          e_ids2 = get.edge.ids(ig, e_list2)
        }
        ig_blowout = subgraph.edges(ig, E(ig)[e_ids2], delete.vertices = TRUE)

        vv = V(ig_blowout)$name[which(!(V(ig_blowout)$name %in% V(ptsim_blowout)$name))]
        ptsim_blowout = add.vertices(ptsim_blowout, nv = length(vv), attr=list(name=vv))
        ee = get.edgelist(ig_blowout)
        for (e in 1:nrow(ee)) {
          ptsim_e_id = get.edge.ids(ptsim_blowout, vp=ee[e,])
          if (ptsim_e_id==0) {
            # Edge isn't in ptsim_blowout, add it.
            ptsim_blowout = add.edges(ptsim_blowout, edges = ee[e,], attr=list(weight=E(ig_blowout)$weight[e]))
          } else {
            mx_w = which.max(c(abs(E(ptsim_blowout)$weight[ptsim_e_id]), abs(E(ig_blowout)$weight[e])))
            direction = ifelse(c(E(ptsim_blowout)$weight[ptsim_e_id], E(ig_blowout)$weight[e])[mx_w] <0, -1, 1)
            E(ptsim_blowout)$weight[ptsim_e_id] = direction*max(abs(E(ptsim_blowout)$weight[ptsim_e_id]), abs(E(ig_blowout)$weight[e]))
          }
        }
      }
    }
  } else {
    ptsim_blowout = add.vertices(ptsim_blowout, nv = 1, attr=list(name=selected_nodes))
  }
  #plot.igraph(ptsim_blowout, layout=layout.circle, edge.width=50*abs(E(ptsim_blowout)$weight))

  return(ptsim_blowout)
}


#!/usr/bin/Rscript

##############################################################################
# Script for running genome-wide models
# Built under R version 3.3.2
##############################################################################

##############################################################################
# Setup: load functions, packages, and arguments
##############################################################################
cat("Loading packages...\n")
# source("./R/get_functions.r")
# source("./R/palettes.r")

# load yaml package to parse args
install.packages("yaml", quiet=TRUE)
require(yaml)

# parse args
args <- yaml.load_file("./_config.yaml")
attach(args)

# add user libpath, if it exists (useful if running on a different node)
.libPaths(c(.libPaths(), libpath))

# install/load devtools packages
require(devtools)
install_github('carjed/smaug', quiet=TRUE)
install_github('slowkow/ggrepel', quiet=TRUE)
gh_packages <- c("smaug", "ggrepel")
invisible(sapply(gh_packages, function(x)
	suppressMessages(require(x, character.only=TRUE))))

# install/load CRAN packages
packages <- c("tidyverse", "broom", "RColorBrewer", "MASS", "boot", "speedglm",
	"psych", "lmtest", "fmsb", "hexbin", "cowplot", "grid", "gtable", "gridExtra",
	"yaml", "openxlsx", "Biostrings", "svglite", "NMF", "emdbook")
invisible(sapply(packages, function(x)
	suppressMessages(usePackage(x))))

# load Bioconductor packages
# suppressMessages(usePackage(ggbio))

cat("Script will run with the following parameters:\n")
print(data.frame(ARGLIST = paste0(names(args), ": ", unlist(args))), right=F)

# Define additional variables for cleaner strings, etc.
bink <- binw/1000
nbp <- adj*2+1

datadir <- paste0(parentdir,
	"/output/", nbp, "bp_", bink, "k_singletons_", data)

summfile <- paste0(parentdir, "/summaries/", mac, ".", data, ".summary")
singfile <- paste0(parentdir, "/singletons/full.singletons")
bindir <- paste0(parentdir, "/motif_counts/", nbp, "-mers/full")

# Read and preprocess data
full_data <- getData(summfile, singfile, bindir)
gc()

##############################################################################
# Drop singletons in individuals with abnormal mutation signatures
##############################################################################
cat("Analyzing sample mutation signatures...\n")
timefun("./R/ind_sigs.r")

full_data$sites <- full_data$sites %>%
	filter(ID %in% ped$ID)
dim(full_data$sites)

full_data$sites <- full_data$sites %>%
	filter(ID %in% keep_ids$ID)
dim(full_data$sites)

##############################################################################
# Get relative mutation rates per subtype; plot as heatmap
##############################################################################
cat("Analyzing K-mer mutation rates...\n")
cat("Calculating K-mer rates...\n")
full_data$aggseq <- get_aggseq(full_data$sites, full_data$mct)
timefun("./R/kmer_analysis.r")

##############################################################################
# Compare full data to strict ancestral data
##############################################################################
cat("Comparing full data with high-confidence ancestral data...\n")
timefun("./R/ancestral.r")

# Choose to drop ERVs with mispolarized/unknown ancestral state?
# Recalculates rates
if(drop_mispolarized){
	full_data$sites <- sites_c_hc
	full_data$aggseq <- get_aggseq(full_data$sites, full_data$mct)
	timefun("./R/kmer_analysis.r")
}

##############################################################################
# Compare full data to masked data
##############################################################################
cat("Comparing full data with strict mask...\n")
timefun("./R/full_vs_mask.r")

# Additional filtering?

##############################################################################
# Compare 7-mer rates between ERVs and Aggarwala & Voight rates
##############################################################################
cat("Comparing with AV model...\n")
timefun("./R/av_comp.r")

##############################################################################
# Prepare singleton input for logit model
##############################################################################
if(build_logit){
	cat("Preparing data for logistic regression model...\n")

	i<-3
	for(chr in 1:22){
		posfile <- paste0(parentdir,
			"/output/logmod_data/chr", chr, "_sites.txt")
		dat <- full_data$sites %>%
		# summfile1 <- sites %>%
			# filter(Category==categ) %>%
			filter(CHR==chr) %>%
			mutate(Type=gsub("cpg_", "", Category2),
				SEQA=substr(Motif, cbp-i, cbp+i),
				SEQB=substr(Motif, cbp*3-i, cbp*3+i),
				Sequence=paste0(SEQA, "(", SEQB, ")")) %>%
			dplyr::select(CHR, POS, Sequence, Type) %>%
			mutate(mut=1) %>%
			spread(Type, mut, fill=0)

		write.table(dat, posfile, col.names=F, row.names=F, quote=F, sep="\t")
	}
}

##############################################################################
# Scripts below assume 7-mers+features model is already complete
##############################################################################
sitefile <- paste0(parentdir, "/output/predicted/validation_sites.txt")
if(file.exists(sitefile)){

	# Validation model
	# -must have parentdir/output/rocdat.7bp.2.txt containing list of sites output
	# from this model and pre-annotated with 7-mer rates from
	# 	-MAC10+ (MU_C)
	# 	-ERVs (MU_S)
	# 	-AV (MU_A)

	cat("Validating models on de novo mutations...\n")
	timefun("./R/validation.r")

	# Analyze effects of genomic features
	cat("Analyzing genomic features...\n")
	timefun("./R/coef_summary.r")

	# Run region-based models
	if(negbin_model){
		cat("Initializing negbin regression model...\n")
		timefun("./R/negbin_mod.r")
	}
} else {
	cat("Looks like you haven't run the logit models yet.
	Refer to the following README files for instructions:

	-data_mgmt/per-site_dp/README.md
	-data_mgmt/logit_scripts/README.md
	-data_mgmt/process_predicted/README.md \n")
}


library(ggplot2)
library(reshape2)
library(rtracklayer)
library(ggpubr)
library(purrr)
library(GenomicRanges)
library(pheatmap)

source('./code/bwutils.r')
source('./code/heatmap_utils.r')

bw.dir <- './data/bw/'
out.dir <- './final_figures/06_ext/'

repmasker.file <- './data/bed/RepMasker_lt200bp_all.bed'

# Panel 1: ESC H3.3 SNAP time log2 fold change normalized to input replicate 1
files <- paste0(bw.dir, c(
  'Deaton_2016/ES_H33_00h_rep1.bw',
  'Deaton_2016/ES_H33_03h_rep1.bw',
  'Deaton_2016/ES_H33_06h_rep1.bw',
  'Deaton_2016/ES_H33_12h_rep1.bw'
))

files.inp <- paste0(bw.dir, c(
  'Deaton_2016/ES_H33_inp_rep1.bw'
))

summaries <- map(files, summarize.by.bed, bed.file <- repmasker.file, drop.name.col=F)
df.fg <- Reduce(function(...) merge(..., all=TRUE), summaries)
rownames(df.fg) <- df.fg$name
df.fg$name <- NULL

input <- summarize.by.bed(files.inp[[1]], repmasker.file)
df.logfc <- log2(sweep(df.fg, 1, input$ES_H33_inp_rep1.bw, `/`))

out.file <- paste0(out.dir, 'ES_SNAP_logfc_cov_enrichment_repmasker.pdf')
colnames(df.logfc) <- c('0h','3h','6h','12h')
summarized.heatmap(t(df.logfc), out.file, "ESC H3.3-SNAP Time-ChIP")

# Panel 2: HP1alpha, beta, gamma
files <- paste0(bw.dir, c(
  'Ostapcuk_2018/ESC_HP1a_R1.bw',
  'Ostapcuk_2018/ESC_HP1b_R1.bw',
  'Ostapcuk_2018/ESC_HP1g_R1.bw'
))

summaries <- map(files, summarize.by.bed, bed.file <- repmasker.file, drop.name.col=F)
df.fg <- Reduce(function(...) merge(..., all=TRUE), summaries)
rownames(df.fg) <- df.fg$name
df.fg$name <- NULL

out.file <- paste0(out.dir, 'Hp1_cov_enrichment_repmasker.pdf')
colnames(df.fg) <- c('HP1a', 'HP1b', 'HP1g')
summarized.heatmap(t(df.fg), out.file, "")

# Panel 3: H3K9me3
files <- paste0(bw.dir, c(
  'Shi_2019/2019_Shi_ESC1_WT_H3K9me3.bw'
))

summaries <- map(files, summarize.by.bed, bed.file <- repmasker.file, drop.name.col=F)
df.fg <- Reduce(function(...) merge(..., all=TRUE), summaries)
rownames(df.fg) <- df.fg$name
df.fg$name <- NULL

out.file <- paste0(out.dir, 'H3K9me3_cov_enrichment_repmasker.pdf')
colnames(df.fg) <- c('H3K9me3')
summarized.heatmap(t(df.fg), out.file, "")


library(Biostrings)
seqs<-readLines("/Users/ferninfm/Desktop/ANTONIA/All_Reads_fer.fasta")
sigma <- nucleotideSubstitutionMatrix(match = 2, mismatch = -1, baseOnly = TRUE)
rownames(sigma)<-c("a","c","g","t")
colnames(sigma)<-c("a","c","g","t")
pairwiseAlignment(seqs[2],seqs[88], type="global",substitutionMatrix=sigma, fuzzyMatrix=NULL, gapOpening=-10, gapExtension=-4, scoreOnly=TRUE)
out<-mat.or.vec(length(seqs)/2,length(seqs)/2)
#Calculate distance matrix Watch out, takes 5 days
for(i in seq(2,length(seqs),2))
{
	for (j in seq(2,length(seqs),2))
	{
	out[i/2,j/2]<-pairwiseAlignment(seqs[i],seqs[j], type="global",substitutionMatrix=sigma, fuzzyMatrix=NULL, gapOpening=-1, gapExtension=-1, scoreOnly=TRUE)
	}
}
#Normalize distance matrix in % of the shortest sequence NOPE
#out.norm<-mat.or.vec(dim(out)[1],dim(out)[2])
#for(i in 1:dim(out)[1])
#{
#	for (j in i:dim(out)[1])
#	{
#	normalizing.size<-min(c(out[i,i],out[j,j]))
#	out.norm[i,j]<-(2*(out[i,j]+normalizing.size)/(3*normalizing.size))
#	out.norm[j,i]<-out.norm[i,j]
#	}
#}
seqs<-read.dna("/Users/ferninfm/Desktop/ANTONIA/All_Reads_fer.fasta",format="fasta")
locs<-unlist(strsplit(names(seqs),"_"))
dim(locs)<-c(2,dim(out)[1])
locs<-locs[1,]
locs<-table(names(seqs),locs)
colnames(out)<-names(seqs)
rownames(out)<-names(seqs)
upgma.tree<-hclust(dist(out),method="centroid") #watch out changed it
locs<-locs[upgma.tree$labels[upgma.tree$order],]
#Plot things
pdf("~/Desktop/ANTONIA/FINAL_heatmap.pdf",paper="a4")
heatmap(out)
dev.off()
#pdf("~/Desktop/ANTONIA/first_hclust.pdf",width=150,height=40)
#layout(matrix(c(1,2), 2, 1, byrow = TRUE), heights=c(5,1))
#par(mai=c(0.5,0.5,0.5,0.5))
#plot(upgma.tree)
#par(mai=c(0.5,0.5,0.5,0.5))
#plot(c(1,2,3,4),xlim=c(1,dim(locs)[1]),ylim=c(1,dim(locs)[2]),type="n",xaxt="n",yaxt="n",xlab="",ylab="",bty="n")
#for (i in 1:dim(locs)[1])
#	{for (j in 1:dim(locs)[2])
#		{points(i,j,type="p",pch=21,bg=locs[i,j])
#		}
#	}
#dev.off()
#
#
# Input a distance based alignment
# NOT USED
#
#pairwise.identity.alignment<-read.table(file = "/Users/ferninfm/Desktop/ANTONIA/alignment_pairwise_similarity.csv", header = TRUE, row.names=1,sep=",",)
#
#
#Prepare stuff for Megan
for (i in 1:dim(locs)[2])
{
write.dna(seqs[rownames(locs)[locs[,i]==1]],paste("/Users/ferninfm/Desktop/ANTONIA/Splidata_",colnames(locs)[i],".fas",sep=""),format="fasta",nbcol=-1,colsep="")
}

#
# 2. INPUT MEGAN TAXONOMY
#
# 2.1. In the Shell I concatenated all text files using 'cat Taxonomy*.txt>All_Tax_FINAL.txt'
#
taxonomy.megan<-readLines("/Users/ferninfm/Desktop/ANTONIA/1_Collapsed/2_Meganv2/All_Tax_FINAL.txt")
taxonomy.megan<-unlist(strsplit(taxonomy.megan,"; ; "))
dim(taxonomy.megan)<-c(2,length(taxonomy.megan)/2)
taxonomy.megan<-t(taxonomy.megan)
rownames(taxonomy.megan)<-taxonomy.megan[,1]
taxonomy.megan<-taxonomy.megan[,2]
#taxonomy.megan<-gsub("Not assigned; 100;","Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100; Not assigned; 100;",taxonomy.megan)
#
# 2.2. Plot Annotated tree
#
pdf("~/Desktop/ANTONIA/Megan_hclust.pdf",width=30,height=180)
foo<-strsplit(taxonomy.megan,";")
foo.labels<-mat.or.vec(1,length(foo))
for (i in 1:length(foo))
{
	if (length(foo[[i]])==2)
	{
		foo.labels[i]<-foo[[i]][1]
	}
	if (length(foo[[i]])>3&length(foo[[i]])<15)
	{
		foo.labels[i]<-foo[[i]][length(foo[[i]])-1]
	}
	else if (length(foo[[i]])>15)
	{
		foo.labels[i]<-paste(foo[[i]][length(foo[[i]])-5],foo[[i]][length(foo[[i]])-3],foo[[i]][length(foo[[i]])-1],sep="_")
	}
}
rm(foo)
names(foo.labels)<-names(taxonomy.megan)
upgma.tree.2<-upgma.tree
upgma.tree.2$labels<-paste(upgma.tree.2$labels,foo.labels[upgma.tree.2$labels],sep="_")
par(mai=c(0.5,0.5,0.5,0.5))
library(ape)
plot(as.phylo(upgma.tree.2))
write.tree(as.phylo(upgma.tree.2),"~/Desktop/ANTONIA/Megan_hclust.tre")
dev.off()
#
# 3. INPUT UNITE TAXONOMY
# I prepared a file in the terminal
#cat *.txt>All_UNITE_FINAL.txt
#cat All_UNITE_FINAL.txt| sed 's/##/E/g'|sed 's/|/;/g'|sed 's/s__;/s__/g'>All_UNITE_FILT.txt
#
blast.unite<-read.table("/Users/ferninfm/Desktop/ANTONIA/1_Collapsed/3_UNITE_Blast/All_UNITE_FILT.txt",sep=",")
#par(mfcol=c(2,2))
pdf("/Users/ferninfm/Desktop/ANTONIA/1_Collapsed/3_UNITE_Blast/boxplots.pdf")
#
# Function category.exclude
#
category.exclude<-function(category)
{
cat.list<-c("c__unidentified","p__unidentified","c__unidentified","o__unidentified","f__unidentified","g__unidentified","s__unidentified")
return(c(cat.list[category],"0"))
}
#
# DEFINE OUTPUT MATRIX
#
unite.classes<-mat.or.vec(length(names(taxonomy.megan)),7) #PREPARE DATASET
rownames(unite.classes)<-names(taxonomy.megan)
#
# PARSE TAXONOMY
#
for (i in names(taxonomy.megan))
		{
			foo<-blast.unite[blast.unite[,1]==i,]
			if (dim(foo)[1]>0)
				{
				foo2<-strsplit(as.character(foo[,2]),";")
				fool<-length(foo2)
				for (j in 1:fool)
				{
					if (length(foo2[[j]])<8)
					{
						foo2[[j]]<-c(foo2[[j]],mat.or.vec(8-length(foo2[[j]]),1))
					}
					if (length(foo2[[j]])>8)
					{
						foo2[[j]]<-c(foo2[[j]][c(1:7)],paste(foo2[[j]][8],foo2[[j]][9]))
					}
				}
				foo2<-unlist(foo2)
				dim(foo2)<-c(8,fool)
				foo2<-t(foo2)
				#
				# Down to here is the same for every Taxonomic category
				#
				#
				for (rank in 2:7)
					{
						boxplot(log(foo[,11])~foo2[,rank+1],main=paste("Sequence",i))#FIRST USE OF RANK
						groups.class<-foo2[!duplicated(foo2[,rank+1]),rank+1]
						if (dim(foo)[1]==0)
							{
							print (paste(i,"has no matches or was not blasted"))
							}
						if (length(groups.class)==1)
							{
								unite.classes[i,rank]<-groups.class
							}
						if (length(groups.class)>1)
							{
								a<-mat.or.vec(1,length(groups.class))
								for (k in 1:length(a))
									{
										a[k]<-mean(log(foo[foo2[,rank+1]==groups.class[k],11]))
									}
								c.e<-category.exclude(rank)
								if (length (groups.class[a==min(a[groups.class%in%c.e==FALSE])])==1)
								{
									unite.classes[i,rank]<-groups.class[a==min(a[groups.class%in%c.e==FALSE])]
								}
								if (length (groups.class[a==min(a[groups.class%in%c.e==FALSE])])>1)
								{
									unite.classes[i,rank]<-paste(groups.class[a==min(a[groups.class%in%c.e==FALSE])],collapse="_")
								}
							}
					}
				}
			}
dev.off()

#unite.classes<-mat.or.vec(length(names(taxonomy.megan)),7)
#names(unite.classes)<-names(taxonomy.megan)
#for (rank in 1:7)
#for (i in names(taxonomy.megan))
#	{
#		foo<-blast.unite[blast.unite[,1]==i,]
#		if (dim(foo)[1]>0)
#			{
#			foo2<-strsplit(as.character(foo[,2]),";")
#			fool<-length(foo2)
#			for (j in 1:fool)
#			{
#				if (length(foo2[[j]])<8)
#				{
#					foo2[[j]]<-c(foo2[[j]],mat.or.vec(8-length(foo2[[j]]),1))
#				}
#				if (length(foo2[[j]])>8)
#				{
#					foo2[[j]]<-c(foo2[[j]][c(1:7)],paste(foo2[[j]][8],foo2[[j]][9]))
#				}
#			}
#			foo2<-unlist(foo2)
#			dim(foo2)<-c(8,fool)
#			foo2<-t(foo2)
#			boxplot(log(foo[,11])~foo2[,4],main=paste("Sequence",i))
#			groups.class<-foo2[!duplicated(foo2[,4]),4]
#			if (length(groups.class)==1)
#			{
#				unite.classes[i]<-groups.class
#				}
#			if (length(groups.class)>1)
#				{
#					a<-mat.or.vec(1,length(groups.class))
#					for (k in 1:length(a))
#						{
#							a[k]<-mean(log(foo[foo2[,4]==groups.class[k],11]))
#						}
#					unite.classes[i]<-(groups.class[a==min(a[groups.class!="c__unidentified"])])
#					}
#			}
#			if (dim(foo)[1]==0)
#			{
#				print (paste(i,"has no matches or was not blasted"))
#			}
#	}
#


REBOL [
	Title: "Xfl-combine-bmps"
	Date: 9-Feb-2012/19:13:06+1:00
	Author: "David 'Oldes' Oliva"
	require: [
		rs-project 'xfl-core
		rs-project 'rectangle-pack
	]
	usage: [
		;xfl-combine-bmps %/d/test/XFL/merge-one/   %/d/test/XFL/merge-one-result/
		;xfl-combine-bmps %/d/test/XFL/merge-multi2/ %/d/test/XFL/merge-multi2-result/
		xfl-combine-bmps %/d/test/XFL/duplicated-bmps2/ %/d/test/XFL/duplicated-bmps2-result/
	]
	preprocess: true
]
dir_imagemagick: %"/x/UTILS/ImageMagick-6.8.8-Q16"

unless value? 'useSquareOnlyBitmaps? [useSquareOnlyBitmaps?: false]

with ctx-XFL [
	verbose: 1
	unwrap?: true
	current-shapeMatrix: none
	current-shapeIMatrix: none

	#include %rules_combine.r

	get-comp-size: func[data /local maxpair maxi][
		maxpair:  0x0
		foreach [size id] data [
			maxpair: max maxpair size
		]

		;maxi: max maxpair/x maxpair/y
		;print ["MAXI:" maxi]
		maxpair/x: to-integer round-to-pow2 maxpair/x
		maxpair/y: to-integer round-to-pow2 maxpair/y
		;print ["MAXPAIR:" maxpair] ;ask "[ENTER]"
		maxpair
	]

	get-best-pow2-result: func[images /local result minArea minResult][
		minArea: 9999999999
		minResult: none
		repeat i 4 [
			result: either useSquareOnlyBitmaps? [
				pow2-box-pack/method images i
			][
				pow2-rectangle-pack/method images i
			]
			if verbose > 1 [print ["possible result size:" result/1 "for method:" i]]
			if any [
				none? minResult
				result/2/3 < minArea
			][
				minArea:   result/2/3
				minResult: result
			]

		]
		if verbose > 1 [print ["POW2-RESULT:" mold minResult]]
		minResult
	]

	combine-files: func[files size into /local tmp png? *wand2 *pixel][
		if verbose > 0 [print ["COMBINE to size:" size "INTO:" mold to-local-file into]]
		with ctx-imagick [
			start
					*pixel: NewPixelWand
					PixelSetAlpha *pixel 0
					MagickNewImage *wand size/x size/y *pixel
					*wand2: NewMagickWand

					foreach [pos size file] files [
						if verbose > 1 [print [tab pos size file]]

						if block? file [parse file [to file! set file 1 skip]]

						unless all [
							not zero? MagickReadImage *wand2 utf8/encode to-local-file file
							tmp:  make image! size
							not zero? MagickExportImagePixels *wand2 0 0 size/x size/y "RGBO" 1 address? tmp
							not zero? MagickImportImagePixels *wand pos/x pos/y size/x size/y "RGBO" 1 address? tmp
						][
							errmsg: reform [
								Exception/Severity "="
								ptr-to-string tmp:  MagickGetException *wand2 Exception
							]
							MagickRelinquishMemory tmp
							if *wand2 [
								ClearMagickWand   *wand2
								DestroyMagickWand *wand2
								*wand2: none
							]
							if *pixel [
								ClearPixelWand    *pixel
								DestroyPixelWand  *pixel
								*pixel: none
							]
							end
							make error! errmsg
						]
						ClearMagickWand   *wand2
					]
				not zero? MagickWriteImages *wand to-local-file into
				if *wand2 [
					ClearMagickWand   *wand2
					DestroyMagickWand *wand2
					*wand2: none
				]
				if *pixel [
					ClearPixelWand    *pixel
					DestroyPixelWand  *pixel
					*pixel: none
				]
			end
		]
	]

	combine-edges-bb: func[x y w h  a b c d /local xw yh x1 y1 x2 y2 fs s][
		xt1: 0
		xt2: w
		yt1: 0
		yt2: h

		;print ["combine-edges-bb:" x y w h "M:" a b c d]
		x1: to-integer 20 * round/to ((xt1  * a) + (yt1  * c) + x) 0.05
		y1: to-integer 20 * round/to ((xt1  * b) + (yt1  * d) + y) 0.05

		x2: to-integer 20 * round/to ((xt2  * a) + (yt1  * c) + x) 0.05
		y2: to-integer 20 * round/to ((xt2  * b) + (yt1  * d) + y) 0.05

		x3: to-integer 20 * round/to ((xt2 * a) + (yt2 * c) + x) 0.05
		y3: to-integer 20 * round/to ((xt2 * b) + (yt2 * d) + y) 0.05

		x4: to-integer 20 * round/to ((xt1 * a) + (yt2 * c) + x) 0.05
		y4: to-integer 20 * round/to ((xt1 * b) + (yt2 * d) + y) 0.05

		either a < 0 [
			fs: 0 s: 1
		][	fs: 1 s: 2]

		rejoin [
			{<Edge fillStyle} fs {="1" edges="}
			"!" x2 " " y2 "S" s "|" x3 " " y3
			"!" x3 " " y3   "|" x4 " " y4
			"!" x4 " " y4   "|" x1 " " y1
			"!" x1 " " y1   "|" x2 " " y2
			{"/>}
		]
	]
	remove-wrapped-transform: func[m [block!] sx sy ][
		;remove twips
		a: a / 20
		b: b / 20
		c: c / 20
		d: d / 20
		;create inverse values
		adbc:(a * d)-(b * c)
		ia:   d / adbc
		ib: - b / adbc
		ic: - c / adbc
		id:   a / adbc
		itx:  ((c * ty) - (d * tx)) / adbc
		ity: -((a * ty) - (b * tx)) / adbc
		;
		reduce [ia * 20 ib * 20 ic * 20 id * 20 itx ity]
	]
	get-matrix: func[matrixNode /twips /local m v][
		m: matrixNode/2
		r: reduce [
			any [all [v: select m "a" to-decimal v] 20]
			any [all [v: select m "b" to-decimal v]  0]
			any [all [v: select m "c" to-decimal v]  0]
			any [all [v: select m "d" to-decimal v] 20]
			any [all [v: select m "tx" to-decimal v] 0]
			any [all [v: select m "ty" to-decimal v] 0]
		]
		unless twips [
			r/1: r/1 / 20
			r/2: r/2 / 20
			r/3: r/3 / 20
			r/4: r/4 / 20
		]
		r
	]
	form-matrix: func[matrixNode matrix /local r][
		r: copy []
		repend r ["a" matrix/1 * 20]
		if matrix/2 <> 0 [repend r ["b" matrix/2 * 20]]
		if matrix/3 <> 0 [repend r ["c" matrix/3 * 20]]
		repend r ["d" matrix/4 * 20]
		if matrix/5 <> 0 [repend r ["tx" round/to matrix/5 0.05]]
		if matrix/6 <> 0 [repend r ["ty" round/to matrix/6 0.05]]

		matrixNode/2: r
	]
	matrix-inverse: func[m [block!] /local a b c d tx ty adbc ia ib ic id itx ity][
		set [a b c d tx ty] m
		adbc:(a * d)-(b * c)
		ia:   d / adbc
		ib: - b / adbc
		ic: - c / adbc
		id:   a / adbc
		itx:  ((c * ty) - (d * tx)) / adbc
		ity: -((a * ty) - (b * tx)) / adbc
		reduce [ia ib ic id itx ity]
	]
	matrix-apply: func[p [block!] m [block!] /local a b c d tx ty][
		set [a b c d tx ty] m
		px: p/1
		py: p/2
		npx: (px * a) + (py * c) + tx
		npy: (px * b) + (py * d) + ty
		reduce [npx npy]
	]
	matrix-concat: func[
		m1 [block!]
		m2 [block!]
		/local
			a1 b1 c1 d1 tx1 ty1
			a2 b2 c2 d2 tx2 ty2
	][
		set [a1 b1 c1 d1 tx1 ty1] m1
		set [a2 b2 c2 d2 tx2 ty2] m2
		reduce [
			(a1 * a2) + (b1 * c2)
			(a1 * b2) + (b1 * d2)
			(c1 * a2) + (d1 * c2)
			(c1 * b2) + (d1 * d2)
			(tx1 * a2) + (ty1 * c2) + tx2
			(tx1 * b2) + (ty1 * d2) + ty2
		]
	]
	combine-BitmapFill: func[node /local v atts matrix matrix2 nx ny tx ty trans dupName][
		atts: node/2
		if dupName: select bitmap-duplicates atts/("bitmapPath") [
			if verbose > 0 [print ["replacing DOMBitmapInstance:" mold atts/("bitmapPath") "->" mold dupName]]
			atts/("bitmapPath"): to-string dupName
		]
		if all [
			block? atts
			imgspec: select images-to-replace atts/("bitmapPath")
		][
			if verbose > 2 [
				print ["combine-BitmapFill:" mold atts/("bitmapPath") "-->" imgspec/3]
			]
			atts/("bitmapPath"): rejoin ["combined_" imgspec/3]
			if none? node/3 [
				node/3: to-DOM {<matrix><Matrix tx="0" ty="0"/></matrix>}
			]
			;get fill matrix:
			matrix: get-matrix matrixNode: get-node reduce [node] %BitmapFill/matrix/Matrix
			if current-shapeMatrix [
				;print ["current-shapeMatrix:" mold current-shapeMatrix]
				;create inverse shape matrix if does not exists
				unless current-shapeIMatrix [
					current-shapeIMatrix: matrix-inverse current-shapeMatrix
				]
				;get matrix in the shape context
				matrix: matrix-concat matrix current-shapeMatrix
			]
			;remove translation wrap:
			matrix2: copy matrix
			matrix2/5: matrix2/6: 0
			trans: matrix-apply reduce [matrix/5 matrix/6] matrix-inverse matrix2
			if unwrap? [
			;THIS IS NOT SAFE:/ so I remove it again
				ask reform ["??????" mold trans mold imgspec]
				trans/1: trans/1 // imgspec/2/x
				trans/2: trans/2 // imgspec/2/y
			]
			trans: matrix-apply trans matrix2
			matrix/5: trans/1
			matrix/6: trans/2

			;revert the shapeMatrix if exists
			if current-shapeMatrix [
				matrix: matrix-concat matrix current-shapeIMatrix
			]
			;use new bitmap position:
			nx: imgspec/1/x
			ny: imgspec/1/y
			matrix/5: matrix/5 - ((nx * matrix/1) + (ny * matrix/3))
			matrix/6: matrix/6 - ((nx * matrix/2) + (ny * matrix/4))

			form-matrix matrixNode matrix
		]
	]
	combine-DOMBitmapInstance: func[node /local atts imgspec tx ty w h v a b c d dom matrix][
		atts: node/2
		if dupName: select bitmap-duplicates atts/("libraryItemName") [
			if verbose > 0 [print ["replacing DOMBitmapInstance:" mold atts/("libraryItemName") "->" mold dupName]]
			atts/("libraryItemName"): to-string dupName
		]
		if all [
			block? atts
			imgspec: select images-to-replace atts/("libraryItemName")
		][
			if verbose > 0 [print ["REPLACING:" atts/("libraryItemName")]]
			if verbose > 1 [probe imgspec]
			if none? node/3 [
				node/3: to-DOM {<matrix><Matrix tx="0" ty="0"/></matrix>}
			]
			matrix: get-node reduce [node] %DOMBitmapInstance/matrix/Matrix

			unless find matrix/2 "tx" [repend matrix/2 ["tx" 0]]
			unless find matrix/2 "ty" [repend matrix/2 ["ty" 0]]

			tx: to-decimal matrix/2/("tx")
			ty: to-decimal matrix/2/("ty")

			w: imgspec/2/x
			h: imgspec/2/y

			either v: select matrix/2 "a" [matrix/2/("a"): 20 * a: to-decimal v][ a: 1 insert matrix/2 ["a" "20"]]
			either v: select matrix/2 "d" [matrix/2/("d"): 20 * d: to-decimal v][ d: 1 insert matrix/2 ["d" "20"]]
			either v: select matrix/2 "b" [matrix/2/("b"): 20 * b: to-decimal v][ b: 0 ]
			either v: select matrix/2 "c" [matrix/2/("c"): 20 * c: to-decimal v][ c: 0 ]

			;matrix/2/("tx"): tx - imgspec/1/x
			;matrix/2/("ty"): ty - imgspec/1/y
			nx: imgspec/1/x
			ny: imgspec/1/y
			matrix/2/("tx"): round/to (tx - ((nx * a) + (ny * c))) 0.05
			matrix/2/("ty"): round/to (ty - ((nx * b) + (ny * d))) 0.05
			dom: to-DOM [
	{       <DOMGroup>
			  <members>
				<DOMShape>
				  <fills>
					<FillStyle index="1">
					  <BitmapFill bitmapPath="combined_} imgspec/3 {" bitmapIsClipped="false">
}                       form-xfl reduce [get-node reduce [node] %DOMBitmapInstance/matrix ]{
					  </BitmapFill>
					</FillStyle>
				  </fills>
				  <edges>
					} combine-edges-bb tx ty w h a b c d {
				  </edges>
				</DOMShape>
			  </members>
			</DOMGroup>
	}]
			clear node
			insert node dom/1
		]
	]

	bitmap-hashes: make hash! 1000
	bitmap-duplicates: make hash! 100
	store-bitmap-hash: func[node /local hash file bmpNode name][
		name: node/2/("name")
		if verbose > 2 [print ["store-bitmap-hash -->" mold name]]
		hash: checksum/secure read/binary file: rejoin [xfl-target-dir %bin/ select node/2 "bitmapDataHRef"]
		either bmpNode: select bitmap-hashes hash [
			if verbose > 0 [print ["BITMAP DUPLICATE FOUND" mold name]]
			repend bitmap-duplicates [name to-file bmpNode/2/("name")]
			clear node
			delete file
		][
			repend bitmap-hashes [hash node]
		]

	]
	set 'xfl-combine-bmps func[src trg /local node item name mediaItems tmp][
		if verbose > 0 [
			print "^/=================================================="
			print   "=== COMBINE BMPs in XFL =========================="
			print  ["=== source:" src]
			print  ["=== target:" trg lf lf]
		]

		init/into-dir src trg

		ctx-iMagick/init-routines

		images-to-combine: copy []
		images-to-replace: copy []

		clear bitmap-hashes
		clear bitmap-duplicates

		mediaItems: Media-content: get-node-content xmldom %DOMDocument/media
		either mediaItems [
			while [not tail? mediaItems] [
				if all [
					block? item: mediaItems/1
					item/1 = "DOMBitmapItem"
				][
					store-bitmap-hash item
					unless empty? item [
						item-file: copy any [
							select item/2 "sourceExternalFilepath"
							join "./LIBRARY/" item/2/("href")
						]
						name: item/2/("name")
						if parse name ["_MERGE_" copy groupName to "/" to end][
							unless images: select images-to-combine groupName [
								append/only append images-to-combine groupName images: copy []
							]
							if imgFile: export-media-item/overwrite/into-file item/2 (
								rejoin [%./LIBRARY/ to-file (enbase/base checksum/secure item/2/("name") 16) %.png]
							) [
								repend/only append images get-image-size imgFile [name imgFile]
								new-line images true
							]
						]
					]
				]
				mediaItems: next mediaItems
			]
			mediaItems: head mediaItems
		][	mediaItems: copy [] ]

		remove-each item mediaItems [all [block? item empty? item]]

		foreach [group images] images-to-combine [
			new-line/skip images true 2

			if verbose > 1 [probe reduce [group images]]
			if verbose > 0 [print ["FINDING POW2 for group:" mold group]]

			set [size result] get-best-pow2-result images

			if verbose > 0 [print  ["FINAL POW2 SIZE :" size "for:" group]]

			combine-files result/1 size combinedImg: rejoin [xfl-target-dir %Library/combined_ encode-filename/as-utf8 group %.png]
			foreach [p1 p2 file] result/1 [
				repend/only append images-to-replace file/1 [p1 p2 group]
				;attempt [delete file/2]
			]
			if node: import-media-img/dom/smoothing combinedImg true [
				;use JPG compression for the combined bitmap:
				if tmp: find node/2 "useImportedJPEGData" [remove/part tmp 2]
				if tmp: find node/2 "compressionType" [remove/part tmp 2]
			]
			mediaItems
		]

		;probe images-to-replace

		while [not tail? mediaItems] [
			mediaItems: either all [
				block? item: mediaItems/1
				find images-to-replace item/2/("name")
			][
				remove mediaItems
			][  next   mediaItems ]
		]
		mediaItems: head mediaItems

		files-to-parse: either block? files-to-parse [
			clear head files-to-parse
		][  copy [] ]

		parse-xfl/act xmldom 'DOMDocument-combine

		files-to-parse: head files-to-parse
		while [not tail? files-to-parse] [
			file: files-to-parse/1
			files-to-parse: next files-to-parse
			recycle
			current-symbol: either file? file [
				current-symbol: form last split-path file
				copy/part current-symbol find/last current-symbol "."
			][  copy/part file find/last file "." ]
			if verbose > 0 [print ["UPDATING:" mold to-file file]]

			either file? file [
				dom: to-DOM as-string read/binary file
				new-file: file
			][
				dom: to-DOM as-string read/binary xfl-source-dir/LIBRARY/(encode-filename file)
				new-file: join xfl-target-dir ["LIBRARY/" encode-filename file]
			]
			parse-xfl/act dom 'DOMSymbolItem-combine
			write/binary new-file form-xfl dom
		]

		;--- remove empty folders...
		folders-to-check: get-node-content xmldom %DOMDocument/folders
		mediaItems: head mediaItems
		while [not tail? mediaItems] [
			if block? item: mediaItems/1 [
				tmp: any [
					select item/2 "name"
					select item/2 "href"
				]
				forall folders-to-check [
					if block? folders-to-check/1 [
						if parse tmp compose[(folders-to-check/1/2/("name")) #"/" to end][
							remove folders-to-check
						]
					]
				]
				folders-to-check: head folders-to-check
			]
			mediaItems: next mediaItems
		]
		forall folders-to-check [
			if block? folders-to-check/1 [
				print ["REMOVING FOLDER:" folders-to-check/1/2/("name")]
				clear folders-to-check/1
			]
		]
		;--- removing folders finished ---

		write/binary xfl-target-dir/DOMDocument.xml form-xfl xmldom
		if verbose > 0 [print "^/--------------------------------------------------^/"]
		images-to-combine
	]

]


contactmap=function(cadistance,proteininput, molfile=NULL,xltable=NULL,
					pdbx=FALSE,cm.offset=0,sites.only=FALSE,which.chain=NULL,
					save.cm.plot=TRUE, ...) {
	#scripttime=proc.time()		#to test runtime
	if(is.numeric(cadistance)==FALSE){
		return("Error: Contact map distances must be numeric.")
	}else if(is.character(proteininput)==FALSE){
		return("Error: Protein input must be character, add quote marks around protein name/accession.")
	}else{
		#Nullify
		x=NULL
		pdbfile=NULL
		xatoms=NULL
		xmolecule=NULL
		pdbx.atoms=NULL
		xchaina=NULL
		xalpha=NULL
		aamin=NULL
		xlstart=NULL
		xlend=NULL
		xdistmatrix=NULL
		distcon=NULL
		colfunc1=NULL
		colfunc2=NULL
		hmcols=NULL
		xlcontactfile=NULL
		uniprotsitetable=NULL
		upaccs1=NULL
		upaccs2=NULL
		upinputselect1=NULL
		upinputselect2=NULL
		reciprocalust=NULL
		crosslinkmap=NULL
		xdistmax=NULL
		xfill=NULL
		xalphafilled=NULL
		xdistmatadj=NULL

		recname=chainid=elename=NULL

		if(is.null(which.chain)) {
			which.chain="A"
		} else {
			which.chain=which.chain
		}

		#libraries
			#library(zoo)
			#library(Rpdb)
			#library(lattice)
			#library(latticeExtra)
			#library(tcltk)

		#import pdb or pdbx file
		if(pdbx==FALSE) {
			if(is.null(molfile)){
				pdbfile=read.pdb(tk_choose.files(caption="Choose a .pdb file to create a contact map."))
			} else {
				pdbfile=read.pdb(molfile)
			}
			#first identify atoms
			xatoms=pdbfile$atoms
			#as.data.frame important for maintaining values in eleid and resid columns
			xmolecule=subset(as.data.frame(xatoms),recname=="ATOM")
		} else {
			if(is.null(molfile)){
				pdbx.atoms=read.pdbx.atoms(tk_choose.files(caption="Choose PDBx/mmCIF file for contact map."))
			} else {
				pdbfile=read.pdbx.atoms(molfile)
			}
			colnames(pdbx.atoms)=c(
				'recname',#'group_PDB',
				'id',
				'type_symbol',
				'elename',#'label_atom_id',
				'label_alt_id',
				'label_comp_id',
				'chainid',#'label_asym_id',
				'label_entity_id',
				'label_seq_id',
				'pdbx_PDB_ins_code',
				'x1',#'Cartn_x',
				'x2',#'Cartn_y',
				'x3',#'Cartn_z',
				'occupancy',
				'B_iso_or_equiv',
				'Cartn_x_esd',
				'Cartn_y_esd',
				'Cartn_z_esd',
				'occupancy_esd',
				'B_iso_or_equiv_esd',
				'pdbx_formal_charge',
				'resid',#'auth_seq_id',
				'auth_comp_id',
				'auth_asym_id',
				'auth_atom_id',
				'pdbx_PDB_model_num'
			)
			xmolecule=pdbx.atoms
		}

		#then identify alpha-carbons in the user defined chain
		xchaina=subset(xmolecule,chainid==which.chain)
		xalpha=subset(xchaina,elename=="CA")

		aamin=1
		xalpha.resid=xalpha[c("resid")]
		xalpha.resid[]=lapply(xalpha.resid,as.numeric)
		xlstart=min(xalpha.resid)
		xlend=max(xalpha.resid)
		#aamax=

		#create matrix including any crystal structure offset in amino acid sequence
		xfill=as.data.frame(c(1:xlend))
		colnames(xfill)=c('resid')
		xalphafilled.initial=merge(xfill,xalpha,all=TRUE)
		xalphafilled=xalphafilled.initial[1:xlend,]

		#determine distance between alpha carbons (this will create the matrix of interactions)
		xdistmatrix=as.matrix(dist(xalphafilled[c("x1","x2","x3")]))
		xdistmax=max(as.matrix(dist(xalpha[c("x1","x2","x3")])))
		if(cadistance>max(xdistmax)){
			cadistance=max(xdistmax)
			#print(cadistance)			#to ensure distance input is being read correctly
			#print(max(xdistmax))		#to ensure distance max is being read correctly
		}else{
			cadistance=cadistance
			#print(cadistance)			#to ensure distance input is being read correctly
			#print(max(xdistmax))		#to ensure distance max is being read correctly
		}
		xdistmatadj=xdistmatrix[xdistmatrix>cadistance]=50

		###
		###
		###
		#Make crosslink contact map from react2 table
		###
		###
		###

		#input is uniprot ID
		#print("Choose React2 File for Crosslink Sites")
		if(is.null(xltable)){
			xlcontactfile=read.delim(
				tk_choose.files(caption="Choose text file containing crosslinked relationships."),as.is=TRUE)
		} else {
			xlcontactfile=read.delim(xltable,as.is=TRUE)
		}

		#input as uniprot accession or as sequest output
		if(sites.only==FALSE) {
			if(grepl("|",xlcontactfile[1,c('prot1')],fixed=TRUE)){
		#Find Uniprot Accession number between pipes and and site of modification then output the results
				upaccs1=sapply(xlcontactfile[c('prot1')],function(y) {
							substring(
								y,
								first = 4,
								last = gregexpr("\\Q|\\E.",y)[[1]][c(2)]-1
							)
					}
				)

		#Find Uniprot Accession number between pipes and and site of modification then output the results
				upaccs2=sapply(xlcontactfile[c('prot2')],function(y) {
						substring(
							y,
							first = 4,
							last = gregexpr("\\Q|\\E.",y)[[1]][c(2)]-1
						)
					}
				)
			} else {
				upaccs1=xlcontactfile[c('prot1')]
				upaccs2=xlcontactfile[c('prot2')]
			}
			upaccs1=as.vector(upaccs1)
			upaccs2=as.vector(upaccs2)
		}

		#Creates intraprotein link table based on proteininput
		#
		# AND based on cm.offset
		#
		xlcontactfile[c('mod_pos1')]=xlcontactfile[c('mod_pos1')]+cm.offset
		xlcontactfile[c('mod_pos2')]=xlcontactfile[c('mod_pos2')]+cm.offset
		if(sites.only==FALSE) {
			uniprotsitetable=as.data.frame(
				cbind(upaccs1,upaccs2,xlcontactfile[c('mod_pos1')],xlcontactfile[c('mod_pos2')])
			)
			#Double the subsetting
			#print(proteininput)
			upinputselect1=subset(uniprotsitetable,upaccs1==proteininput)
			upinputselect2=subset(upinputselect1,upaccs2==proteininput)
			reciprocalust=upinputselect2[c(1,2,4,3)]
			colnames(reciprocalust)=colnames(upinputselect2)
			crosslinktable=rbind(upinputselect2,reciprocalust)
		} else {
			uniprotsitetable=as.data.frame(cbind(xlcontactfile[c('mod_pos1')],xlcontactfile[c('mod_pos2')]))
			reciprocalust=uniprotsitetable[c(2,1)]
			colnames(reciprocalust)=colnames(uniprotsitetable)
			crosslinktable=rbind(uniprotsitetable,reciprocalust)
		}

		###
		###
		###
		#PLOTTING contact values
		##
		##
		##

		colfunc1=colorRampPalette(c("lightgrey","black","darkgreen", "lightgreen"))
			colfunc2=colorRampPalette(c("white"))
			hmcols=c(colfunc1(10000*(cadistance/max(xdistmatrix,na.rm=TRUE))),
				colfunc2(10000*((max(xdistmatrix,na.rm=TRUE)-cadistance)/max(xdistmatrix,na.rm=TRUE)))
			)

		#save plot or just show it?
		if(save.cm.plot){
			question.save.plot = "YES"
		} else {
			question.save.plot = winDialog(type = c("yesno"),"Do you want to save the output file to PDF?")
		}

		if(question.save.plot=="YES") {
			pdf(paste(cadistance,"angstrom_",proteininput,".pdf",sep=""))
			print(
				levelplot(
					xdistmatrix,
					main=paste(proteininput," Cross-link and Contact Map (",cadistance,"Angstroms)",sep=""),
					at=seq(min(xdistmatrix,na.rm=TRUE),max(xdistmatrix,na.rm=TRUE),length.out=5000),
					colorkey=list(space="right"),
					col.regions=hmcols,
					cuts=dim(array(hmcols))-1,
					ylab=paste(proteininput," Residue Number",sep=""),
					xlab=paste(proteininput," Residue Number",sep=""),
					#make axes legible
					scales=list(
						y=list(
							limits=c(1,xlend),
							at=pretty(seq_len(ncol(xdistmatrix)))
						),
						x=list(
							limits=c(1,xlend),
							at=pretty(seq_len(ncol(xdistmatrix)))
						)
					)
					#Use ContactMapMaker to overlay crosslinked sites with PDB contact map

				) + xyplot(mod_pos1~mod_pos2,data=crosslinktable,
							col="black",
							pch=21,
							cex=1.5,
							lty=2,
							fill='magenta',
						)

			)
			dev.off()
			write.table(crosslinktable,
				file = paste(proteininput,"CrosslinkTable",format(Sys.time(),"%Y%m%d%H%M%S"),".txt", sep=""),
				sep="\t",
				row.names=F
			)

		} else{
			print(levelplot(
					xdistmatrix,
					main=paste(proteininput," Cross-link and Contact Map (",cadistance,"Angstroms)",sep=""),
					at=seq(min(xdistmatrix,na.rm=TRUE),max(xdistmatrix,na.rm=TRUE),length.out=5000),
					colorkey=list(space="right"),
					col.regions=hmcols,
					cuts=dim(array(hmcols))-1,
					ylab=paste(proteininput," Residue Number",sep=""),
					xlab=paste(proteininput," Residue Number",sep=""),
					#make axes legible
					scales=list(
						y=list(

							limits=c(1,xlend),
							at=pretty(seq_len(ncol(xdistmatrix)))
						),
						x=list(
							limits=c(1,xlend),
							at=pretty(seq_len(ncol(xdistmatrix)))
						)
					)
					#Use ContactMapMaker to overlay crosslinked sites with PDB contact map

				) + xyplot(mod_pos1~mod_pos2,data=crosslinktable,
							col="black",
							pch=21,
							cex=1.5,
							lty=2,
							fill='magenta',
					)
			)
			write.table(crosslinktable,
				file = paste(proteininput,"CrosslinkTable",format(Sys.time(),"%Y%m%d%H%M%S"),".txt", sep=""),
				sep="\t",
				row.names=F
			)
			}

		#print(proc.time()-scripttime) 			#to test time for running each mapping
		print("NICE MAP!")
	}
}

#contactmap(cadistance=18,proteininput='B7I4V0',pdbx=FALSE,cm.offset=0,sites.only=FALSE,which.chain="A")