library(ggplot2)
library(dplyr)

data   = read.csv('./ld14-intercom-log.csv')
#data$Timestamp = floor(data$Timestamp / (24 * 60 * 60 * 1000)) * 24 * 60 * 60 * 1000
#data   = aggregate(. ~ Timestamp + Group, data = data, max)
dates  = unique(data$Timestamp)
groups = unique(data$Group)
combinations = expand.grid(Timestamp = dates, Group = groups)

data = data %>%
	full_join(combinations, by = c("Timestamp" = "Timestamp", "Group" = "Group")) %>%
	mutate(Count = ifelse(is.na(Count), 0, Count)) %>%
	arrange(Timestamp, Group) %>%
	#mutate(Group = factor(Group, levels = c("Sole Founders (1st time)", "In a Team (1st time)", "Sole Founders (2nd time)", "In a Team (2nd time)", "Sole Founders (3rd time)", "In a Team (3rd time)", "Sole Founders (4th time)", "In a Team (4th time)", "Sole Founders (5th time)", "In a Team (5th time)")))
	mutate(Group = factor(Group, levels = c("Sole Founders", "In a Team")))

ggplot(data, aes(x = as.POSIXct(Timestamp/1000, origin="1970-01-01"), y = Count, fill = Group)) +
	geom_area() +
	geom_vline(aes(xintercept = as.POSIXct(1586131200, origin="1970-01-01")), color="purple") +
	geom_text(aes(x=as.POSIXct(1586131200, origin="1970-01-01") + 60000, label="Start of Form", y=60), color="purple", angle=90, size=4) +
	geom_vline(aes(xintercept = as.POSIXct(1584144000, origin="1970-01-01")), color="purple") +
	geom_text(aes(x=as.POSIXct(1584144000, origin="1970-01-01") + 60000, label="KOWE", y=60), color="purple", angle=90, size=4) +
	theme_bw(base_size=14) +
	scale_fill_brewer(palette = 'Paired') +
	xlab("Time") +
	ylab("Count")

ggsave('./plot.png', width = 10, height = 5)


################################################
## 2-2_Compute-metrics_scrublet.r
##  - Compute doublet scores per sample
##  - Save an txt file with doublet scores per sample [doublet-scores-sampleName]
################################################

suppressWarnings(library(Seurat))
suppressWarnings(library(scDblFinder))

message("reloading old matrices...")
scdata_list <- readRDS("/output/pre-doublet-scdata_list.rds")

message("Loading configuration...")
config <- RJSONIO::fromJSON("/input/meta.json")

# Check which samples have been selected. Otherwiser we are going to use all of them.
if (length(config$samples)>0){
    samples <- config$samples
}else{
    samples <- names(scdata_list)
}

scdata_list <- scdata_list[samples]

# compute_doublet_scores function
#' @description Save the result of doublets scores per sample.
#' @param scdata Raw sparse matrix with the counts for one sample.
#' @param sample_name Name of the sample that we are preparing.
#'
#' @return
compute_doublet_scores <- function(scdata, sample_name) {

    message("Sample --> ", sample_name, "...")

    edpath <- paste0("/output/pre-emptydrops-", sample_name, ".rds")
    if (file.exists(edpath)) {
        edout <- readRDS(edpath)
        keep <- which(edout$FDR <= 0.001)
        scdata <- scdata[, keep]
    }

    scdata_DS <- scDblFinder(scdata, dbr = NULL, trajectoryMode = FALSE)
    df_doublet_scores <- data.frame(Barcodes=rownames(scdata_DS@colData), doublet_scores=scdata_DS@colData$scDblFinder.score,
    doublet_class = scdata_DS@colData$scDblFinder.class)

    write.table(df_doublet_scores, file = paste("/output/doublet-scores-", sample_name, ".csv", sep = ""), row.names = FALSE, col.names = FALSE, quote = FALSE, sep = "\t")
}

message("calculating probability of barcodes being doublets...")
for (sample_name in names(scdata_list)) {
  compute_doublet_scores(scdata_list[[sample_name]], sample_name)
}

message("Step 2-2 completed.")


from <- dplyr::dense_rank(sample.int(1E5, replace = TRUE))
to <- dplyr::dense_rank(sample.int(1E5, replace = TRUE))

# regular R:
# 10,000 length vector ~ 0.5 sec
# 30,000 length vector ~ 4 sec
# 100,000 length vector ~ 75 secs
profvis::profvis(r <- group_edges(from, to))

# Rcpp:
# 10,000 length vector ~ 0.02 sec
# 30,000 length vector ~ 0.25 sec
# 100,000 length vector ~ 2 sec
# 300,000 length vector ~ 15 sec
profvis::profvis(r <- group_edges_rcpp(from - 1L, to - 1L))

sort(table(group_edges(from, to)), decreasing = TRUE)

start_profiler("src/profile.out")
r <- group_edges_rcpp(from - 1L, to - 1L)
stop_profiler()

# google-pprof --text src/lshr.so src/profile.out


REBOL [
  Title:   "Generates Red/System maths tests"
	Author:  "Peter W A Wood"
	File: 	 %make-maths-auto-test.r
	Version: 0.1.3
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

make-test: func [
  test-string [string!]
  /setup
    test-setup [string!]
  /local
    rule
    char
    mold-char
    new-test-string
    cs
][
  cs: complement charset [#"#"]
  mold-char: func [
    char [char!]
  ][
    join {#"^^(} [copy/part tail to-hex to integer! to char! char -2 {)"}]
  ]
  rule: [
    (new-test-string: copy "")
    any [
      copy char [{#"} thru {"}] (append new-test-string mold-char load char)
      |
      copy string [some cs] (append new-test-string string)
      |
      skip
    ]
  ]
  test-number: test-number + 1
  append tests join {  --test-- "maths-auto-} [test-number {"^(0A)}]
  if setup [append tests test-setup]
  append tests "  --assert "

  ;; convert all char! literals to hex format
  parse/all test-string rule

  ;; check if the first value is a byte!
  either byte-first? [
    append tests reform [expected "= (as integer! (" new-test-string "))^(0A)"]
  ][
    append tests reform [expected "= (" new-test-string ")^(0A)"]
  ]

]

preprocess: func [
  s [string!]
  /local
    calc
    rules
    sb
    ns
    nothing-changed
    division-sign
][

  calc: func [
    a   [char!]
    op  [word!]
    b   [char!]
    /local
      res
  ][
    ;; Ensure all typecasts are to integer! not char!
    a: to integer! a

    switch op [
      + [res: a + b]
      - [res: a - b]
      * [res: a * b]
      div-sign [res: to integer! (a / b)]
    ]

    ;; adjust the return value to emulate 8-bit arithmetic with overflow
    either res >= 0 [
      res: res // 256
    ][
      until [
        res: res + 256
        res > 0
      ]
     ]
    to char! res
  ]

  rules: [
    any [
      [set a char! set op word! set b char! (
        acc: calc a op b
        replace ns join "(" [mold a " " op " " mold b ")"] mold acc
        replace ns join "" [mold a " " op " " mold b ] mold acc
        nothing-changed: false
      )] |
      [set a integer! 'div-sign set b integer! (
        replace ns join "" [mold a " " op " " mold b ]
                   join "(to integer! divide "[mold a " " mold b ")"]
      )] |
      [set p paren! (parse to block! p rules)] |
      skip
    ]
    end
  ]

  ns: copy s
  replace/all ns " / " " div-sign "
  until [
    nothing-changed: true
    sb: to block! load ns
    parse sb rules
    nothing-changed
  ]

  ns
]

;; initialisations
tests: copy ""                          ;; string to hold generated tests
test-number: 0                          ;; number of the generated test
make-dir %auto-tests/
file-out: %auto-tests/maths-auto-test.reds

;; tests & data - test formulae, test data, test formulae, test data, etc.
tests-and-data: [
  [
    "(v * v) * v"
    "(v - v) - v"
    "(v * v) - v"
    "(v - v) * v"
    "v * v * v"
    "v - v - v"
    "v - v * v"
    "(v / v) + v"
  ]
  [
    [1 1 1]
    [2 2 2]
    [256 256 256]
    [257 257 257]
    [255 256 257]
    [-256 256 256]
    [257 -257 257]
    [255 256 -257]
    [-256 -256 -256]
    [-257 -257 -257]
    [-255 -256 -257]
    [#"^(02)" #"^(02)" #"^(02)"]
    [#"^(07)" #"^(08)" #"^(03)"]
    [1 #"^(0A)" 100]
    [2 #"^(10)" 256]
    [#"^(FD)" #"^(FE)" #"^(FF)"]
    [#"^(AA)" 34 #"^(99)"]
  ]
  [
    "(v * v) * (v * v)"
    "(v - v) - (v - v)"
    "(v * v) - (v - v)"
    "(v - v) * (v - v)"
    "(v - v) - (v * v)"
    "(v * v) * (v - v)"
    "(v - v) * (v * v)"
    "(v * v) - (v * v)"
    "v + v + v + v"
    "v / v * v / v"
  ]
  [
    [1 1 1 1]
    [2 2 2 2]
    [256 256 256 256]
    [257 257 257 257]
    [#"^(FF)" 256 257 258]
    [#"^(FC)" #"^(FD)" #"^(FE)" #"^(FF)"]
  ]
  [
    "((v * v) * (v * v)) * ((v * v) * (v * v))"
    "((v - v) * (v * v)) * ((v * v) * (v * v))"
    "((v * v) - (v * v)) * ((v * v) * (v * v))"
    "((v * v) * (v - v)) * ((v * v) * (v * v))"
    "((v * v) * (v * v)) - ((v * v) * (v * v))"
    "((v * v) * (v * v)) * ((v - v) * (v * v))"
    "((v * v) * (v * v)) * ((v * v) - (v * v))"
    "((v * v) * (v * v)) * ((v * v) * (v - v))"
    "((v - v) * (v * v)) * ((v * v) * (v * v))"
    "((v - v) * (v * v)) * ((v * v) * (v * v))"
    "((v - v) - (v * v)) * ((v * v) * (v * v))"
    "((v - v) * (v - v)) * ((v * v) * (v * v))"
    "((v - v) * (v * v)) - ((v * v) * (v * v))"
    "((v - v) * (v * v)) * ((v - v) * (v * v))"
    "((v - v) * (v * v)) * ((v * v) - (v * v))"
    "((v - v) * (v * v)) * ((v * v) * (v - v))"
    "((v * v) - (v * v)) * ((v * v) * (v * v))"
    "((v - v) - (v * v)) * ((v * v) * (v * v))"
    "((v * v) - (v * v)) * ((v * v) * (v * v))"
    "((v * v) - (v - v)) * ((v * v) * (v * v))"
    "((v * v) - (v * v)) - ((v * v) * (v * v))"
    "((v * v) - (v * v)) * ((v - v) * (v * v))"
    "((v * v) - (v * v)) * ((v * v) - (v * v))"
    "((v * v) - (v * v)) * ((v * v) * (v - v))"
    "((v * v) * (v - v)) - ((v * v) * (v * v))"
    "((v - v) * (v - v)) * ((v - v) * (v * v))"
    "((v * v) * (v - v)) * ((v * v) - (v * v))"
    "((v * v) * (v - v)) * ((v * v) * (v - v))"
    "((v * v) * (v - v)) - ((v * v) * (v * v))"
    "((v * v) * (v - v)) * ((v - v) * (v * v))"
    "((v * v) * (v - v)) * ((v * v) - (v * v))"
    "((v * v) * (v - v)) * ((v * v) * (v - v))"
    "((v - v) - (v - v)) * ((v * v) * (v * v))"
    "((v - v) - (v * v)) - ((v * v) * (v * v))"
    "((v - v) - (v * v)) * ((v - v) * (v * v))"
    "((v - v) - (v - v)) * ((v * v) - (v * v))"
    "((v - v) * (v - v)) - ((v * v) * (v - v))"
    "((v - v) * (v * v)) - ((v - v) * (v * v))"
    "((v - v) * (v * v)) - ((v * v) - (v * v))"
    "((v - v) * (v * v)) - ((v * v) * (v - v))"
    "((v - v) * (v * v)) * ((v - v) - (v * v))"
    "((v - v) * (v * v)) * ((v - v) * (v - v))"
    "((v - v) * (v * v)) * ((v * v) - (v - v))"
    "((v * v) - (v - v)) - ((v * v) * (v * v))"
    "((v * v) - (v - v)) * ((v - v) * (v * v))"
    "((v * v) - (v - v)) * ((v * v) - (v * v))"
    "((v * v) - (v - v)) * ((v * v) * (v - v))"
    "((v * v) * (v - v)) - ((v - v) * (v * v))"
    "((v * v) * (v - v)) - ((v * v) - (v * v))"
    "((v * v) * (v - v)) - ((v * v) * (v - v))"
    "((v * v) * (v - v)) * ((v - v) - (v * v))"
    "((v * v) * (v - v)) * ((v - v) * (v - v))"
    "((v * v) * (v * v)) - ((v - v) - (v * v))"
    "((v * v) * (v * v)) - ((v - v) * (v - v))"
    "((v * v) * (v * v)) - ((v * v) - (v - v))"
    "((v * v) * (v * v)) * ((v - v) - (v - v))"
    "((v - v) * (v - v)) - ((v - v) * (v * v))"
    "((v - v) * (v - v)) - ((v * v) - (v * v))"
    "((v - v) * (v - v)) - ((v * v) * (v - v))"
    "((v - v) - (v - v)) - ((v * v) * (v * v))"
    "((v - v) - (v - v)) * ((v - v) * (v * v))"
    "((v - v) - (v - v)) * ((v * v) - (v * v))"
    "((v - v) - (v - v)) * ((v * v) * (v - v))"
    "((v - v) - (v * v)) * ((v - v) - (v * v))"
    "((v - v) - (v * v)) * ((v - v) * (v - v))"
    "((v * v) - (v - v)) - ((v - v) * (v * v))"
    "((v * v) * (v - v)) - ((v * v) - (v - v))"
    "((v * v) * (v - v)) - ((v - v) - (v - v))"
    "((v * v) * (v * v)) - ((v - v) - (v - v))"
    "((v - v) * (v - v)) - ((v - v) * (v - v))"
    "((v - v) - (v - v)) - ((v - v) - (v - v))"
  ]
  [
    [1 1 1 1 1 1 1 1]
    [256 256 256 256 256 256 256 256]
    [257 257 257 257 257 257 257 257]
    [-256 -256 -256 -256 -256 -256 -256 -256]
    [-257 -257 -257 -257 -257 -257 -257 -257]
    [#"^(01)" #"^(02)" #"^(03)" #"^(01)" #"^(02)" #"^(03)" #"^(01)" #"^(02)"]
    [1 2 #"^(03)" 4 5 6 7 8]
    [#"^(F8)" #"^(F9)" #"^(FA)" #"^(FB)" #"^(FC)" #"^(FD)" #"^(FE)" #"^(FF)"]
  ]
]

;;;;;;;;;;;;;;;; start of template ;;;;;;;;;;;;;;;;;;;;;;;;;;
template: {
Red/System [
  Title:   "Red/System auto-generated maths tests"
  Author:  "Peter W A Wood"
  File:    %maths-auto-test.reds
  License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

comment {
  This file is generated by make-maths-auto-test.r
  Do not edit this file directly.
}
;;;;;;;;;;;;;;;; end of template ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;make-length:$LENGTH$

#include %../../../../../quick-test/quick-test.reds

s: declare struct! [
  a [integer!]
  b [integer!]
  c [integer!]
  d [integer!]
  e [integer!]
  f [integer!]
  g [integer!]
  h [integer!]
]

ident: func [i [integer!] return: [integer!]][i]

~~~start-file~~~ "Auto-generated tests for maths"

===start-group=== "Auto-generated tests for maths"

}
;;;;;;;;;;;;;;;; end of template;;;;;;;;;;;;;;;;;;;;;;;;;;

;; start of executable code
header: copy template
replace header "$LENGTH$" length? read %make-maths-auto-test.r

write/binary file-out header

tests: copy ""

foreach [formulae data] tests-and-data [
  foreach test-formula formulae [
    foreach test-data data [
      test-string: copy test-formula
      foreach test-value test-data [
        replace test-string "v" mold test-value
      ]

      byte-first?: either char! = type? first test-data [true] [false]

      rebol-test-string: preprocess test-string

      ;; parse the expression and perform the calculation as Red/System would
      ;; only write a test if REBOL produces a valid result
      if attempt [expected: do load rebol-test-string][

          expected: to integer! expected

          ;; test with literal values
          make-test test-string

          ;; if the data contains byte! values don't create the other tests
          if not find test-string "#" [

          ;; test using integer variables
          test-setup: copy ""
          test-string: copy test-formula
          variable-names: copy ["a" "b" "c" "d" "e" "f" "g" "h"]
          foreach test-value test-data [
            append test-setup join "    " [
              first variable-names ": " mold test-value "^(0A)"
            ]
            replace test-string "v" first variable-names
            variable-names: next variable-names
          ]
          make-test/setup test-string test-setup

          ;; test using integer/path
          test-setup: copy ""
          test-string: copy test-formula
          variable-names: copy ["a" "b" "c" "d" "e" "f" "g" "h"]
          foreach test-value test-data [
            append test-setup join "    s/" [
              first variable-names ": " mold test-value "^(0A)"
            ]
            replace test-string "v" join "s/" [first variable-names]
            variable-names: next variable-names
          ]
          make-test/setup test-string test-setup

          ;; test using function call
          test-string: copy test-formula
          foreach test-value test-data [
            replace test-string "v" join "(ident " [mold test-value ")"]
          ]
          make-test test-string
        ]
      ]
    ]
  ]
  recycle
]
write/append/binary file-out tests
tests: copy ""

;; write file epilog
append tests "^(0A)===end-group===^(0A)^(0A)"
append tests {~~~end-file~~~^(0A)^(0A)}

write/append/binary file-out tests

print ["Number of assertions generated" test-number]


#' emis_atm
#'
#' Calculate air emissivity.
#'
#' @param tk numeric Air temperature in degK.
#' @param rh numeric Relative humidity in percentage.
#' @return air emissivity
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  emis_atm
#'
#' @export
#'
#'
#'
#'

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


#' Create frescalo weights file
#'
#' Create the weights file required to run frescalo, as outlined in (Hill,
#' 2011). For more information on frescalo see \code{\link{frescalo}}. This function
#' takes a table of geographical distances between sites and a table of numeric data
#' from which to calculate similarity (for example, landcover or abiotic data)
#'
#' @param distances a dataframe giving the distance between sites in a long format with three
#'        columns. The first column give the ID of the first site, the second column gives
#'        the ID of the second site and the third column gives the distance between them.
#'        The table should include reciprocal data i.e. both rows 'A, B, 10' and 'B, A, 10'
#'        should exist.
#' @param attributes a dataframe of numeric attributes of each site. The first column must contain
#'        the site IDs and all other columns are used to calculate the similarity between
#'        sites using dist() and method 'euclidean'.
#' @param dist_sub the number of neighbours to include after ranking by distance. In Hill
#'        (2011), this is set to 200 and is the default here
#' @param sim_sub the number of neighbours to include after ranking by similarity. This is
#'        the final number of sites that will be included in a neighbourhood. In Hill (2011),
#'        this is set to 100 and is the default here.
#' @param normalise Logical. If \code{TRUE} each attribute is divided by its maximum value to
#'        produce values between 0 and 1. Default is \code{FALSE}
#' @param verbose Logical, should progress be printed to console. Defaults to TRUE
#' @return A dataframe is returned in a format that can be used directly in frescalo() or
#'         sparta(). The dataframe has three columns giving the target cell, the neighbourhood
#'         cell, and the weight.
#' @keywords trends, frescalo, weights
#' @references Hill, Mark. Local frequency as a key to interpreting species occurrence data when
#' recording effort is not known. 2011. \emph{Methods in Ecology and Evolution}, 3 (1), 195-205.
#' @import sp
#' @importFrom reshape2 melt
#' @export
#' @examples
#' \dontrun{
#'
#  # I'm going to create some made up data
#' mySites <- paste('Site_', 1:100, sep = '')
#'
#' # Build a table of distances
#' myDistances <- merge(mySites, mySites)
#'
#' # add random distances
#' myDistances$dist <- runif(n = nrow(myDistances), min = 10, max = 10000)
#'
#' # to be realistic the distance from a site to itself should be 0
#' myDistances$dist[myDistances$x == myDistances$y] <- 0
#'
#' # Build a table of attributes
#' myHabitatData <- data.frame(site = mySites,
#'                             grassland = runif(length(mySites), 0, 1),
#'                             woodland = runif(length(mySites), 0, 1),
#'                             heathland = runif(length(mySites), 0, 1),
#'                             urban = runif(length(mySites), 0, 1),
#'                             freshwater = runif(length(mySites), 0, 1))
#'
#' # This pretend data is supposed to be proportional cover so lets
#' # make sure each row sums to 1
#' multiples <- apply(myHabitatData[,2:6], 1, sum)
#
#' for(i in 1:length(mySites)){
#'   myHabitatData[i,2:6] <- myHabitatData[i,2:6]/multiples[i]
#' }
#'
#' # Create the weights file
#' weights <- createWeights(distances = myDistances,
#'                           attributes = myHabitatData,
#'                           dist_sub = 20,
#'                           sim_sub = 10)
#' }

createWeights<-function(distances,
                        attributes,
                        dist_sub=200,
                        sim_sub=100,
                        normalise=FALSE,
                        verbose=TRUE){

  # Error checks
  errorChecks(dist = distances, sim = attributes, dist_sub = dist_sub, sim_sub = sim_sub)

  # Ensure site names are characters not factors
  distances[,1] <- as.character(distances[,1])
  distances[,2] <- as.character(distances[,2])
  attributes[,1] <- as.character(attributes[,1])

  # rename the columns
  colnames(distances) <- c('site1', 'site2' ,'distance')

  # Check that sites are in both drop those that are not - give a warning
  unique_dist_sites <- unique(c(distances[,1], distances[,2]))
  unique_sim_sites <- unique(attributes[,1])
  distmiss <- unique_dist_sites[!unique_dist_sites %in% unique_sim_sites]
  simmiss <- unique_sim_sites[!unique_sim_sites %in% unique_dist_sites]
  missing <- unique(c(distmiss,simmiss))

  if(length(missing) > 0){
    warning(paste("The following sites were in only one of 'attributes' and 'distances' and so have been excluded from the weights file:",toString(missing)))
    distances <- distances[!distances[,1] %in% missing,]
    distances <- distances[!distances[,2] %in% missing,]
    attributes <- attributes[!attributes[,1] %in% missing,]
  }

  #normalise if required
  if(normalise){
    for(i in 2:length(colnames(attributes))){
      mx <- max(attributes[,i])
      attributes[,i] <- attributes[,i] / mx
    }
  }

  #convert attribute table into a long distance table
  if(verbose) cat('Creating similarity distance table...')
  row.names(attributes) <- attributes[,1]
  sim_distance <- dist(attributes[,2:length(names(attributes))], diag = TRUE, upper = TRUE)
  sim_distance <- melt(as.matrix(sim_distance))
  sim_distance$value <- (sim_distance$value/max(sim_distance$value))
  sim_distance[,1] <- as.character(sim_distance[,1])
  sim_distance[,2] <- as.character(sim_distance[,2])
  colnames(sim_distance) <- c('site1', 'site2', 'similarity')
  if(verbose) cat('Complete\n')

  if(verbose) cat('Creating weights file...\n0%\n')

  total <- length(unique(distances[,1]))
  pb <- txtProgressBar(min = 0, max = total, style = 3)

  # Taking each cell in turn calculate the weights
  weights_list <- lapply(unique(distances[,1]), function(i){

    # select for target cell
    sim_foc <- sim_distance[sim_distance$site1 == i, ]
    dist_foc <- distances[distances$site1 == i, ]

    # For this focal cell rank all others by distance
    dist_foc$rankdist <- rank(dist_foc$distance, ties.method = "first")

    # Take the top 'dist_sub' closest (dist_sub defaults to 200)
    dist_foc <- dist_foc[dist_foc$rankdist <= dist_sub, ]

    # Of these take the 'sim_sub' top by similarity distance (sim_sub defaults to 100)
    ranks <- merge(x = dist_foc, y = sim_foc, by = c('site1', 'site2'), all.x = TRUE, all.y = FALSE)
    ranks$rankflor <- rank(ranks$similarity, ties.method = "first")
    ranks <- ranks[ranks$rankflor <= sim_sub, ]

    # Calculate similarity by distance and flora
    ranks$distsim <- (1 - (((ranks$rankdist - 1)^2) / (dist_sub)^2))^4
    ranks$florsim <- (1 - (((ranks$rankflor - 1)^2) / (sim_sub)^2))^4

    # Calculate weights
    ranks$weight <- ranks$distsim*ranks$florsim

    if(verbose) setTxtProgressBar(pb, grep(paste0('^', i, '$'), unique(distances[,1])))

    # Merge back with all data
    return(data.frame(target = ranks$site1,
                      neighbour = ranks$site2,
                      weight = round(ranks$weight, 4)))

    })

  weights_master <- do.call(rbind, weights_list)
  close(pb)

  if(verbose) cat('Complete\n')

  return(weights_master)

}


# CHAPTER 7
# Backtesting with Quantstrat

library(quantmod)

#################
# Initial setup #
#################

# Suppresses warnings
options("getSymbols.warning4.0" = FALSE)

# Do some house cleaning
rm(list = ls(.blotter), envir = .blotter)

# Set the currency and the timezone
currency('USD')
Sys.setenv(TZ = "UTC")

# Define symbols of interest
symbols <- c("XLB", #SPDR Materials sector
             "XLE", #SPDR Energy sector
             "XLF", #SPDR Financial sector
             "XLP", #SPDR Consumer staples sector
             "XLI", #SPDR Industrial sector
             "XLU", #SPDR Utilities sector
             "XLV", #SPDR Healthcare sector
             "XLK", #SPDR Tech sector
             "XLY", #SPDR Consumer discretionary sector
             "RWR", #SPDR Dow Jones REIT ETF
             "EWJ", #iShares Japan
             "EWG", #iShares Germany
             "EWU", #iShares UK
             "EWC", #iShares Canada
             "EWY", #iShares South Korea
             "EWA", #iShares Australia
             "EWH", #iShares Hong Kong
             "EWS", #iShares Singapore
             "IYZ", #iShares U.S. Telecom
             "EZU", #iShares MSCI EMU ETF
             "IYR", #iShares U.S. Real Estate
             "EWT", #iShares Taiwan
             "EWZ", #iShares Brazil
             "EFA", #iShares EAFE
             "IGE", #iShares North American Natural Resources
             "EPP", #iShares Pacific Ex Japan
             "LQD", #iShares Investment Grade Corporate Bonds
             "SHY", #iShares 1-3 year TBonds
             "IEF", #iShares 3-7 year TBonds
             "TLT" #iShares 20+ year Bonds
)

# SPDR ETFs first, iShares ETFs afterwards
if(!"XLB" %in% ls()) {
  # If data is not present, get it from yahoo
  suppressMessages(getSymbols(symbols, from = from,
                              to = to,  src = "yahoo", adjust = TRUE))
}

# Define the instrument type
stock(symbols, currency = "USD", multiplier = 1)

###############################################
# The first strategy: A simple trend follower #
###############################################
"lagATR" <- function(HLC, n = 14, maType, lag = 1, ...) {
  ATR <- ATR(HLC, n = n, maType = maType, ...)
  ATR <- lag(ATR, lag)
  out <- ATR$atr
  colnames(out) <- "atr"
  return(out)
}

"osDollarATR" <- function(orderside, tradeSize, pctATR,
                          maxPctATR = pctATR,  data, timestamp,
                          symbol, prefer = "Open", portfolio, integerQty = TRUE,
                          atrMod = "", rebal = FALSE, ...) {
  if(tradeSize > 0 & orderside == "short"){
    tradeSize <- tradeSize * -1
  }

  pos <- getPosQty(portfolio, symbol, timestamp)
  atrString <- paste0("atr", atrMod)
  atrCol <- grep(atrString, colnames(mktdata))

  if(length(atrCol) == 0) {
    stop(paste("Term", atrString,
               "not found in mktdata column names."))
  }

  atrTimeStamp <- mktdata[timestamp, atrCol]
  if(is.na(atrTimeStamp) | atrTimeStamp == 0) {
    stop(paste("ATR corresponding to", atrString,
               "is invalid at this point in time.  Add a logical
    operator to account for this."))
  }

  dollarATR <- pos * atrTimeStamp

  desiredDollarATR <- pctATR * tradeSize
  remainingRiskCapacity <- tradeSize *
    maxPctATR - dollarATR

  if(orderside == "long"){
    qty <- min(tradeSize * pctATR / atrTimeStamp,
               remainingRiskCapacity / atrTimeStamp)
  } else {
    qty <- max(tradeSize * pctATR / atrTimeStamp,
               remainingRiskCapacity / atrTimeStamp)
  }

  if(integerQty) {
    qty <- trunc(qty)
  }
  if(!rebal) {
    if(orderside == "long" & qty < 0) {
      qty <- 0
    }
    if(orderside == "short" & qty > 0) {
      qty <- 0 }
  }
  if(rebal) {
    if(pos == 0) {
      qty <- 0
    }
  }
  return(qty)
}

require(quantstrat)
require(PerformanceAnalytics)

initDate = "1990-01-01"
from = "2003-01-01"
to = "2013-12-31"
options(width = 70)

# To rerun the strategy, rerun everything below this line
# demoData.R contains all of the data-related boilerplate.
source(file.path(here::here(),  "Quantitative Trading", "common.r"))

# Trade sizing and initial equity settings
tradeSize <- 10000
initEq <- tradeSize * length(symbols)

strategy.st <- "Clenow_Simple"
portfolio.st <- "Clenow_Simple"
account.st <- "Clenow_Simple"
rm.strat(portfolio.st)
rm.strat(strategy.st)

initPortf(portfolio.st, symbols = symbols,
          initDate = initDate, currency = 'USD')

initAcct(account.st, portfolios = portfolio.st,
         initDate = initDate, currency = 'USD', initEq = initEq)

initOrders(portfolio.st, initDate = initDate)

strategy(strategy.st, store=TRUE)

##################################
# Backtesting the first strategy #
##################################
nLag = 252
pctATR = 0.02
period = 10

namedLag <- function(x, k = 1, na.pad = TRUE, ...) {
  out <- lag(x, k = k, na.pad = na.pad, ...)
  out[is.na(out)] <- x[is.na(out)]
  colnames(out) <- "namedLag"
  return(out)
}

add.indicator(strategy.st, name = "namedLag",
              arguments = list(x = quote(Cl(mktdata)), k = nLag),
              label = "ind")

add.indicator(strategy.st, name = "lagATR",
              arguments = list(HLC = quote(HLC(mktdata)), n = period),
              label = "atrX")

test <- applyIndicators(strategy.st, mktdata = OHLC(XLB))
head(round(test, 2), 253)

# Signals
add.signal(strategy.st, name = "sigCrossover",
           arguments = list(columns = c("Close", "namedLag.ind"),
                            relationship = "gt"),
           label = "coverOrBuy")

add.signal(strategy.st, name = "sigCrossover",
           arguments = list(columns = c("Close", "namedLag.ind"),
                            relationship = "lt"),
           label = "sellOrShort")

# Long rules
add.rule(strategy.st, name = "ruleSignal",
         arguments = list(sigcol = "coverOrBuy",
                          sigval = TRUE, ordertype = "market",
                          orderside = "long", replace = FALSE,
                          prefer = "Open", osFUN = osDollarATR,
                          tradeSize = tradeSize, pctATR = pctATR,
                          atrMod = "X"), type = "enter", path.dep = TRUE)

add.rule(strategy.st, name = "ruleSignal",
         arguments = list(sigcol = "sellOrShort",
                          sigval = TRUE, orderqty = "all",
                          ordertype = "market", orderside = "long",
                          replace = FALSE, prefer = "Open"),
         type = "exit", path.dep = TRUE)

# Short rules
add.rule(strategy.st, name = "ruleSignal",
         arguments = list(sigcol = "sellOrShort",
                          sigval = TRUE, ordertype = "market",
                          orderside = "short", replace = FALSE,
                          prefer = "Open", osFUN = osDollarATR,
                          tradeSize = -tradeSize, pctATR = pctATR,
                          atrMod = "X"), type = "enter", path.dep = TRUE)

add.rule(strategy.st, name = "ruleSignal",
         arguments = list(sigcol = "coverOrBuy",
                          sigval = TRUE, orderqty = "all",
                          ordertype = "market", orderside = "short",
                          replace = FALSE, prefer = "Open"),
         type = "exit", path.dep = TRUE)

# Get begin time
t1 <- Sys.time()
out <- applyStrategy(strategy = strategy.st,
                     portfolios = portfolio.st)

# Record end time
t2 <- Sys.time()
print(t2 - t1)

applyStrategy(out)


library(devtools)
library(parallel)
devtools::load_all()
RNGkind("L'Ecuyer-CMRG")
data(grid)

seed <- 999983
s_k <- 1000
s_n <- 100
s_m <- 4

new_plain_trig_1004 <- mclapply(new_r_grid_trig, r_loop <- function(s_r) {
    stephanie_type2(seed, s_k, s_n, s_m, "trigonometric", s_r, L = 1000, err = 0.25, i_face = F, approx = T, truncate.tn = 1)
}, mc.cores = 2)

save(new_plain_trig_1004, file = "new_plain_trig_1004.RData")


#' @inheritParams layer
#' @inheritParams geom_point
#' @inheritParams stat_density
#' @param scale if "area" (default), all violins have the same area (before trimming
#'   the tails). If "count", areas are scaled proportionally to the number of
#'   observations. If "width", all violins have the same maximum width.
#' @section Computed variables:
#' \describe{
#'   \item{density}{density estimate}
#'   \item{scaled}{density estimate, scaled to maximum of 1}
#'   \item{count}{density * number of points - probably useless for violin plots}
#'   \item{violinwidth}{density scaled for the violin plot, according to area, counts
#'                      or to a constant maximum width}
#'   \item{n}{number of points}
#'   \item{width}{width of violin bounding box}
#' }
#' @seealso [geom_violin()] for examples, and [stat_density()]
#'   for examples with data along the x axis.
#' @export
#' @rdname geom_violin
stat_ydensity <- function(mapping = NULL, data = NULL,
                          geom = "violin", position = "dodge",
                          ...,
                          bw = "nrd0",
                          adjust = 1,
                          kernel = "gaussian",
                          trim = TRUE,
                          scale = "area",
                          na.rm = FALSE,
                          orientation = NA,
                          show.legend = NA,
                          inherit.aes = TRUE) {
  scale <- arg_match0(scale, c("area", "count", "width"))

  layer(
    data = data,
    mapping = mapping,
    stat = StatYdensity,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list2(
      bw = bw,
      adjust = adjust,
      kernel = kernel,
      trim = trim,
      scale = scale,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatYdensity <- ggproto("StatYdensity", Stat,
  required_aes = c("x", "y"),
  non_missing_aes = "weight",

  setup_params = function(data, params) {
    params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, group_has_equal = TRUE)

    params
  },

  extra_params = c("na.rm", "orientation"),

  compute_group = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1,
                       kernel = "gaussian", trim = TRUE, na.rm = FALSE, flipped_aes = FALSE) {
    if (nrow(data) < 2) {
      cli::cli_warn("Groups with fewer than two data points have been dropped.")
      return(new_data_frame())
    }
    range <- range(data$y, na.rm = TRUE)
    modifier <- if (trim) 0 else 3
    bw <- calc_bw(data$y, bw)
    dens <- compute_density(data$y, data$w, from = range[1] - modifier*bw, to = range[2] + modifier*bw,
      bw = bw, adjust = adjust, kernel = kernel)

    dens$y <- dens$x
    dens$x <- mean(range(data$x))

    # Compute width if x has multiple values
    if (length(unique(data$x)) > 1) {
      width <- diff(range(data$x)) * 0.9
    }
    dens$width <- width

    dens
  },

  compute_panel = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1,
                           kernel = "gaussian", trim = TRUE, na.rm = FALSE,
                           scale = "area", flipped_aes = FALSE) {
    data <- flip_data(data, flipped_aes)
    data <- ggproto_parent(Stat, self)$compute_panel(
      data, scales, width = width, bw = bw, adjust = adjust, kernel = kernel,
      trim = trim, na.rm = na.rm
    )

    # choose how violins are scaled relative to each other
    data$violinwidth <- switch(scale,
      # area : keep the original densities but scale them to a max width of 1
      #        for plotting purposes only
      area = data$density / max(data$density),
      # count: use the original densities scaled to a maximum of 1 (as above)
      #        and then scale them according to the number of observations
      count = data$density / max(data$density) * data$n / max(data$n),
      # width: constant width (density scaled to a maximum of 1)
      width = data$scaled
    )
    data$flipped_aes <- flipped_aes
    flip_data(data, flipped_aes)
  }

)

calc_bw <- function(x, bw) {
  if (is.character(bw)) {
    if (length(x) < 2) {
      cli::cli_abort("{.arg x} must contain at least 2 elements to select a bandwidth automatically")
    }

    bw <- switch(
      to_lower_ascii(bw),
      nrd0 = stats::bw.nrd0(x),
      nrd = stats::bw.nrd(x),
      ucv = stats::bw.ucv(x),
      bcv = stats::bw.bcv(x),
      sj = ,
      `sj-ste` = stats::bw.SJ(x, method = "ste"),
      `sj-dpi` = stats::bw.SJ(x, method = "dpi"),
      cli::cli_abort("{.var {bw}} is not a valid bandwidth rule")
    )
  }
  bw
}


#install.packages("ggplot2")
#install.packages("RColorBrewer")
#install.packages("zoo")

library("RColorBrewer")
require("ggplot2")
library(zoo)

par(mfrow=c(1,1))

setwd("C:/Code/climData/glaser2010")

p0 <- read.csv("https://raw.githubusercontent.com/climdata/glaser2019/master/csv/p_1500_2xxx.csv", sep=",", na = "NA")
spifull <- read.csv("https://raw.githubusercontent.com/climdata/dwdSPI/master/csv/spi_de.csv", sep=",", na = "NA")

p1 <- data.frame()
monthNames = c("jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec")
for(i in 1:length(monthNames)) {
  pnew <- data.frame(year = p0$year, month = i)
  pnew$prec0 <- p0[,monthNames[i]]
  p1 <- rbind(p1, pnew)
}

p1$time = p1$year + (p1$month+0.5)/12.0

spinew <- subset(spifull, spifull$time>max(p1$time))
spinew <- spinew[, c("year","month","time","spi1")]
names(spinew)[names(spinew) == 'spi1'] <- 'prec0'
spinew <- spinew[order(spinew$time),]

### DOES NOT WORK !!!
for(i in length(spinew$prec0)) {
  if(spinew$prec0[i] > 3.0) {
    spinew$prec0[i] = 3.0
  }
  if(spinew$prec0[i] < -3.0) {
    spinew$prec0[i] = -3.0
  }
}

p1 <- rbind(p1, spinew)
p1 <- p1[order(p1$time),]

mp <- ggplot(p1, aes(year, month))
mp + geom_raster(aes(fill=prec0))+
  theme_classic(base_size=80) +
  #theme_classic() +
  labs(x="Year", y="Month", title="", subtitle="") +
  scale_y_continuous(breaks=c(1,6,12))+
  scale_x_continuous(limits=c(1500,2020)) +
  scale_fill_gradient2(low="#AA6010", mid="#FCF0C2", high="#23AB30",
                       limits=c(-3,3)) +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="PI", reverse = TRUE))


library(istack)
library(ggplot2)
# library(devtools)
# setwd('/Users/gaot/Desktop/istack')

# cancer types and treatments
set.seed(2018-12-09)
cancers = simulate_cancers(15)

p = istack(cancers,
           var = 'Disease',
           group = 'Treatment',
           icon = "https://upload.wikimedia.org/wikipedia/commons/d/d8/Person_icon_BLACK-01.svg",
           size = 0.025,
           asp = 3)

p + theme(panel.grid.major.x = element_line(colour = "grey", linetype = 'dashed')) +
  ggtitle('Cancer Treatments')

# mtcars
p = istack(mtcars,
           var = 'carb',
           group = 'gear',
           icon = "https://upload.wikimedia.org/wikipedia/commons/7/7e/Car_icon_transparent.png",
           size = 0.12,
           asp = 1)

p + theme(panel.grid.major.y = element_line(colour = "grey", linetype = 'dashed')) +
  coord_flip() + ggtitle('mtcars')


# Set up
source('2019-06-19-jsa-type-ch1/init.r')

# Libraries
library(zoo)
library(ggrepel)

library(forecast)
library(tseries)

library(Kendall)

library(segmented)

# Parameters
theme <- theme_minimal(base_size=7)
year_end <- 2018
dir_plot <- "C:\\Users\\ejysoh\\Dropbox\\msc-thesis\\research\\_figures\\_ch1\\"

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Fig. 1
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/fig-1.r")

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Fig. 2
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/fig-2.r")

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Fig. 3
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/fig-3.r")

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Fig. 4  Prop species describing <=N species
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/fig-4.r")

#########################################################################################
# Supporting Information
#########################################################################################

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - SI 2A Table 1 - Paragraph on taxonomic effort
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/si-A.r")

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - SI 2B Fig - Histogram of active years
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/si-B-fig-1.r")

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - SI 2C Fig 1
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/si-C-fig-1.r")

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - SI 2D Table 1
# Describers profile - one large monograph towards end of life, or many small?
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/si-D-table-1.r")

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - SI 2E Fig 2,3
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/si-E-fig-2,3.r")

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - SI 2F Tables - Ancillary info on describers
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
source("2019-06-19-jsa-type-ch1/plots_main/si-F-tables.r")


library("dplyr")

find_start_positions <- function(pop_df, start_positions = 0.5) {
	# set small time interval:
	all_gens_list <- unique(pop_df$Generation)
	delta <- abs(min(1E-2 * min(diff(all_gens_list)), 1E-4 * (max(all_gens_list) - min(all_gens_list))))
	start_positions <- max(start_positions, delta)
	start_positions <- min(start_positions, 1 - delta)
	start_positions <- max(start_positions, 0.5) # Manual change to account for very large datasets (LTEE)
	return(start_positions)
}

args = commandArgs(trailingOnly=TRUE)
#filename <- "/home/cld100/Documents/github/muller_diagrams/5G/tables/5_genotypes.timeseries.ggmuller.populations.tsv"
filename <- args[1]
pop_df <- read.csv(filename, sep = "\t", header = TRUE)
result <- find_start_positions(pop_df)

write(result, args[2])


#Joyce with R : nuage de mots

# Etape 1 : Ouvrir R

# Etape 2 : Charger les librairies necessaires

library(tm)
library(SnowballC)
library(wordcloud)

# Etape 3 : Charger les donnees, situees sur PATH

setwd('PATH')
texts  <-Corpus(DirSource("PATH"), readerControl = list(language="lat"))

# Verifier que les donnes ont bel et bien ete chargees.

summary(texts)

# Etape 4 : Nettoyer les donnees.

texts <- tm_map(texts, removeNumbers)
texts <- tm_map(texts, removePunctuation)
texts <- tm_map(texts , stripWhitespace)
texts <- tm_map(texts, content_transformer(tolower))
texts <- tm_map(texts, removeWords, stopwords("english"))
texts <- tm_map(texts, stemDocument, language = "english")

# Etape 5 : Créer une matrice.

TDM <- TermDocumentMatrix(texts)

# Etape 6 : Enlever les termes n'étant pas utiliser suffisament de fois.

TDM.common = removeSparseTerms(TDM, 0.1)

# Etape 8 : preparer pour le decompte des mots

TDM.dense <- as.matrix(TDM.common)

# Etape 9 : creer le nuage de mots

palette <- brewer.pal(9,"BuGn")[-(1:4)]
wordcloud(rownames(TDM.dense), rowSums(TDM.dense), min.freq = 1, color = palette)


# calculate_compensation_paper.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

# Runs a calculation of compensation with autospill, creating all figures and
# tables used in autospill paper.
#
# Requires being called as a batch script with the following two arguments:
#     control.dir    directory with the set of single-color controls
#     control.def.file    csv file defining the names and channels of the
#         single-color controls

library( autospill )

# get directory and csv file with definition of control dataset

args <- commandArgs( TRUE )

if ( length( args ) != 2 ) {
    cat( "ERROR: no arguments with directory and csv file with definition of control dataset",
        file = stderr() )
    stop()
}

control.dir <- args[[ 1 ]]
control.def.file <- args[[ 2 ]]

# set parameters

asp <- get.autospill.param( "paper" )

# read flow controls

flow.control <- read.flow.control( control.dir, control.def.file, asp )

# gate events before calculating spillover

flow.gate <- gate.flow.data( flow.control, asp )

# get initial spillover matrices from untransformed and transformed data

marker.spillover.unco.untr <- get.marker.spillover( TRUE, flow.gate,
    flow.control, asp )
marker.spillover.unco.tran <- get.marker.spillover( FALSE, flow.gate,
    flow.control, asp )

# get spillover and compensation matrices with positive and negative
# populations

spillover.error.posnegpop <- process.posnegpop( marker.spillover.unco.untr,
    flow.gate, flow.control, asp )

# refine spillover matrix iteratively

refine.spillover.result <- refine.spillover( marker.spillover.unco.untr,
    marker.spillover.unco.tran, flow.gate, flow.control, asp )

# plot results together for slope error and skewness

plot_result.together( flow.control, asp )

# replot convergence adding spillover error from the calculation with positive
# and negative populations

plot_convergence( refine.spillover.result$convergence,
    spillover.error.posnegpop$error$slop, asp )

# output session info

sessionInfo()