context("Network level indices - test boot_networklevel_n")

library(magrittr)
library(bipartite)
data(Safariland)

# Helper function to get the length of unique values from the last row of the
# given matrix.
get_length_unq <- function(test_matrix) {
  test_matrix %>%
    .[nrow(.), ] %>%
    unique() %>%
    length()
}

# Test nestedness ---------------------------------------------------------

# Note that, "nestedness" is not be affected by `level` as opposed to "niche
# overlap".

index <- "nestedness"

# For full reproducibility we need to reorder the Safariland matrix
# alphabetically. This is needed because in boot_specieslevel_once() we use the
# table() function to (re)construct/sample networks and the species names are
# ordered alphabetically, which is not the case for Safariland default matrix
# that comes with the bipartite package.
sf_sort <- Safariland[order(rownames(Safariland)), order(colnames(Safariland))]

set.seed(42)
test_both <- networklevel(sf_sort, index = index, level = "both")
set.seed(42)
test_higher <- networklevel(sf_sort, index = index, level = "higher")
set.seed(42)
test_lower <- networklevel(sf_sort, index = index, level = "lower")

# ~ both levels -----------------------------------------------------------

test_that('"nestedness" index output is ok for both levels', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_networklevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "both",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  # Is there just a single matrix in the output list?
  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)
  expect_match(names(sf_boot), "nestedness", fixed = TRUE)
  expect_true(inherits(sf_boot[["nestedness"]], 'matrix'))
  expect_true(dim(sf_boot[["nestedness"]])[2] == 6) # because n_boot = 6

  # Are all final bootstraped network values equal? That is, for each column,
  # last row values must stay the same. For the code idea, see the comment of
  # https://stackoverflow.com/a/35899767/5193830
  unq_length <- get_length_unq(sf_boot[["nestedness"]])
  expect_equal(unq_length, 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  final_boot_val <- sf_boot[["nestedness"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val, test_both)
})

# ~ higher level ----------------------------------------------------------

test_that('"nestedness" index output is ok for higher level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_networklevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "higher",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  # Is there just a single matrix in the output list?
  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)
  expect_match(names(sf_boot), "nestedness", fixed = TRUE)
  expect_true(inherits(sf_boot[["nestedness"]], 'matrix'))
  expect_true(dim(sf_boot[["nestedness"]])[2] == 6) # because n_boot = 6

  # Are all final bootstraped network values equal? That is, for each column,
  # last row values must stay the same. For the code idea, see the comment of
  # https://stackoverflow.com/a/35899767/5193830
  unq_length <- get_length_unq(sf_boot[["nestedness"]])
  expect_equal(unq_length, 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  final_boot_val <- sf_boot[["nestedness"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val, test_higher)
})

# ~ lower level -----------------------------------------------------------

test_that('"nestedness" index output is ok for lower level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_networklevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "lower",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  # Is there just a single matrix in the output list?
  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)
  expect_match(names(sf_boot), "nestedness", fixed = TRUE)
  expect_true(inherits(sf_boot[["nestedness"]], 'matrix'))
  expect_true(dim(sf_boot[["nestedness"]])[2] == 6) # because n_boot = 6

  # Are all final bootstraped network values equal? That is, for each column,
  # last row values must stay the same. For the code idea, see the comment of
  # https://stackoverflow.com/a/35899767/5193830
  unq_length <- get_length_unq(sf_boot[["nestedness"]])
  expect_equal(unq_length, 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  final_boot_val <- sf_boot[["nestedness"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val, test_lower)
})

# Test niche overlap ------------------------------------------------------

# Note that, "niche overlap" is affected by `level`.

index <- "niche overlap"

sf_sort <- Safariland %>%
  .[, order(colnames(.))] %>%
  .[order(rownames(.)), ]

set.seed(42)
test_both <- networklevel(sf_sort, index = index, level = "both")
set.seed(42)
test_higher <- networklevel(sf_sort, index = index, level = "higher")
set.seed(42)
test_lower <- networklevel(sf_sort, index = index, level = "lower")

# ~ both levels -----------------------------------------------------------

test_that('"niche overlap" index output is ok for both levels', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_networklevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "both",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  # Are there two matrices in the output list?
  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 2)

  expect_match(names(sf_boot)[1], "niche.overlap.HL", fixed = TRUE)
  expect_match(names(sf_boot)[2], "niche.overlap.LL", fixed = TRUE)

  expect_true(inherits(sf_boot[["niche.overlap.HL"]], 'matrix'))
  expect_true(inherits(sf_boot[["niche.overlap.LL"]], 'matrix'))

  expect_true(dim(sf_boot[["niche.overlap.HL"]])[2] == 6) # because n_boot = 6
  expect_true(dim(sf_boot[["niche.overlap.LL"]])[2] == 6) # because n_boot = 6

  # Are all final bootstraped network values equal? That is, for each column,
  # last row values must stay the same. For the code idea, see the comment of
  # https://stackoverflow.com/a/35899767/5193830
  unq_length_hl <- get_length_unq(sf_boot[["niche.overlap.HL"]])
  expect_equal(unq_length_hl, 1)

  unq_length_ll <- get_length_unq(sf_boot[["niche.overlap.LL"]])
  expect_equal(unq_length_ll, 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  final_boot_val_hl <- sf_boot[["niche.overlap.HL"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val_hl, test_both["niche.overlap.HL"])

  final_boot_val_ll <- sf_boot[["niche.overlap.LL"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val_ll, test_both["niche.overlap.LL"])
})

# ~ higher level ----------------------------------------------------------

test_that('"niche overlap" index output is ok for higher level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_networklevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "higher",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  # Is there just a single matrix in the output list?
  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)
  expect_match(names(sf_boot), "niche.overlap.HL", fixed = TRUE)
  expect_true(inherits(sf_boot[["niche.overlap.HL"]], 'matrix'))
  expect_true(dim(sf_boot[["niche.overlap.HL"]])[2] == 6) # because n_boot = 6

  # Are all final bootstraped network values equal? That is, for each column,
  # last row values must stay the same. For the code idea, see the comment of
  # https://stackoverflow.com/a/35899767/5193830
  unq_length <- get_length_unq(sf_boot[["niche.overlap.HL"]])
  expect_equal(unq_length, 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  final_boot_val <- sf_boot[["niche.overlap.HL"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val, test_higher)
})

# ~ lower level -----------------------------------------------------------

test_that('"niche overlap" index output is ok for lower level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_networklevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "lower",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  # Is there just a single matrix in the output list?
  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)
  expect_match(names(sf_boot), "niche.overlap.LL", fixed = TRUE)
  expect_true(inherits(sf_boot[["niche.overlap.LL"]], 'matrix'))
  expect_true(dim(sf_boot[["niche.overlap.LL"]])[2] == 6) # because n_boot = 6

  # Are all final bootstraped network values equal? That is, for each column,
  # last row values must stay the same. For the code idea, see the comment of
  # https://stackoverflow.com/a/35899767/5193830
  unq_length <- get_length_unq(sf_boot[["niche.overlap.LL"]])
  expect_equal(unq_length, 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  final_boot_val <- sf_boot[["niche.overlap.LL"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val, test_lower)
})

# Test generality ---------------------------------------------------------

# Note that "generality" is affected by `level`, but outputs as results
# "generality" for higher level and "vulnerability" for lower level.

index <- "generality"

sf_sort <- Safariland %>%
  .[, order(colnames(.))] %>%
  .[order(rownames(.)), ]

set.seed(42)
test_both <- networklevel(sf_sort, index = index, level = "both")
set.seed(42)
test_higher <- networklevel(sf_sort, index = index, level = "higher")
set.seed(42)
test_lower <- expect_warning(networklevel(sf_sort, index = index, level = "lower"),
                             "You requested 'generality' for the lower level.*")
# Expected warning: You requested 'generality' for the lower level, although it
# is not a lower level index! You will get 'vulnerability' instead (same thing,
# really).

# ~ both levels -----------------------------------------------------------

test_that('"generality" index output is ok for both levels', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_networklevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "both",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  # Are there two matrices in the output list?
  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 2)

  expect_match(names(sf_boot)[1], "generality.HL", fixed = TRUE)
  expect_match(names(sf_boot)[2], "vulnerability.LL", fixed = TRUE)

  expect_true(inherits(sf_boot[["generality.HL"]], 'matrix'))
  expect_true(inherits(sf_boot[["vulnerability.LL"]], 'matrix'))

  expect_true(dim(sf_boot[["generality.HL"]])[2] == 6) # because n_boot = 6
  expect_true(dim(sf_boot[["vulnerability.LL"]])[2] == 6) # because n_boot = 6

  # Are all final bootstraped network values equal? That is, for each column,
  # last row values must stay the same. For the code idea, see the comment of
  # https://stackoverflow.com/a/35899767/5193830
  unq_length_hl <- get_length_unq(sf_boot[["generality.HL"]])
  expect_equal(unq_length_hl, 1)

  unq_length_ll <- get_length_unq(sf_boot[["vulnerability.LL"]])
  expect_equal(unq_length_ll, 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  final_boot_val_hl <- sf_boot[["generality.HL"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val_hl, test_both["generality.HL"])

  final_boot_val_ll <- sf_boot[["vulnerability.LL"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val_ll, test_both["vulnerability.LL"])
})

# ~ higher level ----------------------------------------------------------

test_that('"generality" index output is ok for higher level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_networklevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "higher",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  # Is there just a single matrix in the output list?
  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)
  expect_match(names(sf_boot), "generality.HL", fixed = TRUE)
  expect_true(inherits(sf_boot[["generality.HL"]], 'matrix'))
  expect_true(dim(sf_boot[["generality.HL"]])[2] == 6) # because n_boot = 6

  # Are all final bootstraped network values equal? That is, for each column,
  # last row values must stay the same. For the code idea, see the comment of
  # https://stackoverflow.com/a/35899767/5193830
  unq_length <- get_length_unq(sf_boot[["generality.HL"]])
  expect_equal(unq_length, 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  final_boot_val <- sf_boot[["generality.HL"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val, test_higher)
})

# ~ lower level -----------------------------------------------------------

test_that('"generality" index output is ok for lower level', {
  sf_boot <- Safariland %>%
    web_matrix_to_df() %>%
    boot_networklevel_n(col_lower = "lower",
                        col_higher = "higher",
                        index = index,
                        level = "lower",
                        start = 100,
                        step = 100,
                        n_boot = 6,
                        n_cpu = 2)

  # Is there just a single matrix in the output list?
  expect_true(inherits(sf_boot, 'list'))
  expect_true(length(sf_boot) == 1)
  expect_match(names(sf_boot), "vulnerability.LL", fixed = TRUE)
  expect_true(inherits(sf_boot[["vulnerability.LL"]], 'matrix'))
  expect_true(dim(sf_boot[["vulnerability.LL"]])[2] == 6) # because n_boot = 6

  # Are all final bootstraped network values equal? That is, for each column,
  # last row values must stay the same. For the code idea, see the comment of
  # https://stackoverflow.com/a/35899767/5193830
  unq_length <- get_length_unq(sf_boot[["vulnerability.LL"]])
  expect_equal(unq_length, 1)

  # Is the last bootstrap value correct? As per bipartite::networklevel ?
  final_boot_val <- sf_boot[["vulnerability.LL"]] %>% .[nrow(.), 1]
  expect_equivalent(final_boot_val, test_lower)
})


library(shiny)

function(input, output) {

  data <- reactive({
    dist <- switch(input$dist,
                   norm = rnorm,
                   unif = runif,
                   exp = rexp,
                   rnorm)
    dist(input$obs)
  })

  output$plot <- renderPlot({
    distrib <- switch(input$dist,
                      norm = "Normal",
                      unif = "Uniform",
                      exp = "Exponential",
                      "Normal")
    obs <- input$obs

    hist(data(),
         main=paste(distrib, "distribution with", obs, "observations", sep=" "), xlab = "Value of Random Variable", col = input$colour)
  })

  output$summary <- renderPrint({
    summary(data())
  })

  output$table <- renderTable({
    data.frame(x=data())
  })

  output$down <- downloadHandler(
    filename = function() {
      paste(input$dist, '.csv', sep='')
    },
    content = function(file) {
      write.csv(data(), file)
    }
  )
}


setClassUnion("Int", c("integer", "matrix"))

#' Class float32
#'
#' An S4 container for 32-bit float vector/matrix objects.
#'
#' @slot Data
#' A vector or matrix of integers.
#'
#' @name float32-class
#' @docType class
#'
#' @export
setClass("float32",
  representation(
    Data="Int"
  )
)

setClassUnion("Mat", c("matrix", "float32"))
setClassUnion("BaseLinAlg", c("matrix", "vector"))


#################################################
#################################################
# Projection datasets
#################################################
#################################################

# Possible datasets for temperature:
#################################################
# tas_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc --> Mean air temperature at 1.5m °C - Salma
# tasmax_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc --> Max air temperature at 1.5m °C - Marcin
# tasmin_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc --> Min air temperature at 1.5m °C - Marcin

# Possible datasets for humidity:
#################################################
# hurs_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc --> Relative humidity at 1.5m %

# Possible datasets for wind:
#################################################

# Question: How can we combine temp, humidity, and wind? (Temp+Humid = Heat Index)
# Precipitation - Wetter/Dryer

# Libraries we need
#################################################
library(raster)
library(sf)
library(sp)
library(ncdf4)
library(ggplot2)
library(rgdal)
library(rlang)
library(dplyr)
library(lubridate)
library(zoo)

#################################################
# .nc to raster
#################################################

tasmin.nc <- nc_open("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/mon/tasmin_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc")
print(tasmin.nc)
names(tasmin.nc$var) #"tasmin"

tasmin <- brick("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/mon/tasmin_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc")
tasmin
# Information
#     class      : RasterBrick
#     dimensions : 112, 82, 9184, 1200  (nrow, ncol, ncell, nlayers) -> 100 years
#     resolution : 12000, 12000  (x, y)
#     extent     : -216000, 768000, -108000, 1236000  (xmin, xmax, ymin, ymax)
#     crs        : +proj=tmerc +lat_0=49 +lon_0=-2 +k=0.9996012717 +x_0=400000 +y_0=-100000 +a=6377563.396 +b=6356256.909 +units=m +no_defs
#     source     : tasmin_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc
#     names      : X1980.10.20, X1980.11.19, X1980.12.19, X1981.01.18, X1981.02.17, X1981.03.19, X1981.04.18, X1981.05.18, X1981.06.17, X1981.07.17, X1981.08.16, X1981.09.15, X1981.10.15, X1981.11.14, X1981.12.14, ...
#     Date/time  : 1980-10-20, 2079-04-14 (min, max)
#     varname    : tasmin
#     level      : 1

tasmax.nc <- nc_open("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/mon/tasmax_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc")
print(tasmax.nc)
names(tasmax.nc$var) #"tasmax"

tasmax <- brick("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/mon/tasmax_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc")
tasmax
# Information
#     class      : RasterBrick
#     dimensions : 112, 82, 9184, 1200  (nrow, ncol, ncell, nlayers)
#     resolution : 12000, 12000  (x, y)
#     extent     : -216000, 768000, -108000, 1236000  (xmin, xmax, ymin, ymax)
#     crs        : +proj=tmerc +lat_0=49 +lon_0=-2 +k=0.9996012717 +x_0=400000 +y_0=-100000 +a=6377563.396 +b=6356256.909 +units=m +no_defs
#     source     : tasmax_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc
#     names      : X1980.10.20, X1980.11.19, X1980.12.19, X1981.01.18, X1981.02.17, X1981.03.19, X1981.04.18, X1981.05.18, X1981.06.17, X1981.07.17, X1981.08.16, X1981.09.15, X1981.10.15, X1981.11.14, X1981.12.14, ...
#     Date/time  : 1980-10-20, 2079-04-14 (min, max)
#     varname    : tasmax
#     level      : 1

tas.nc <- nc_open("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/mon/tas_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc")
print(tas.nc)
names(tas.nc$var) #"tasmin"

tas <- brick("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/mon/tas_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc")
tas
# Information
#     class      : RasterBrick
#     dimensions : 112, 82, 9184, 1200  (nrow, ncol, ncell, nlayers)
#     resolution : 12000, 12000  (x, y)
#     extent     : -216000, 768000, -108000, 1236000  (xmin, xmax, ymin, ymax)
#     crs        : +proj=tmerc +lat_0=49 +lon_0=-2 +k=0.9996012717 +x_0=400000 +y_0=-100000 +a=6377563.396 +b=6356256.909 +units=m +no_defs
#     source     : tas_rcp85_land-rcm_uk_12km_01_mon_198012-208011.nc
#     names      : X1980.10.20, X1980.11.19, X1980.12.19, X1981.01.18, X1981.02.17, X1981.03.19, X1981.04.18, X1981.05.18, X1981.06.17, X1981.07.17, X1981.08.16, X1981.09.15, X1981.10.15, X1981.11.14, X1981.12.14, ...
#     Date/time  : 1980-10-20, 2079-04-14 (min, max)
#     varname    : tas
#     level      : 1

#################################################
# Some manipulations
#################################################

# Masking and cropping some grids
tasminM <- mask(tasmin, uk_borders) %>% crop(uk_borders)
tasmaxM <- mask(tasmax, uk_borders) %>% crop(uk_borders)
tasM <- mask(tas, uk_borders) %>% crop(uk_borders)

plot(tasminM[[1]])

# Standardized layers' dates - From .nc to rasterbrick there are some problems with layers' names.
head(names(tasminM)) # "X1980.10.20" "X1980.11.19" "X1980.12.19" "X1981.01.18" "X1981.02.17" "X1981.03.19"
tail(names(tasminM)) # "X2078.11.15" "X2078.12.15" "X2079.01.14" "X2079.02.13" "X2079.03.15" "X2079.04.14"

time_layers <- seq(as.Date("1980/12/01"), as.Date("2080/11/30"), by = "month")
tasminM <- setZ(tasminM, time_layers, "months")
names(tasminM) <- time_layers

tasmaxM <- setZ(tasmaxM, time_layers, "months")
names(tasmaxM) <- time_layers

tasM <- setZ(tasM, time_layers, "months")
names(tasM) <- time_layers

#################################################
# Anomaly
#################################################

# Calculate averages by month to get "historical" baseline - 1980 Dec (nl= 1) to 2000 Nov (nl= 240)
tasmin1980_2000 <- dropLayer(tasminM, c(241:1200))
tasmax1980_2000 <- dropLayer(tasmaxM, c(241:1200))
tas1980_2000 <- dropLayer(tasM, c(241:1200))

month_layers <- seq(as.Date("2000/12/1"), by = "month", length.out = 12)

tasminSA1980_2000  <-  zApply(tasmin1980_2000, by=month, fun= mean, name = "months") # Mean of 20 Jans, 20 Febs...20 Decs. It worked and stars from Dec-Nov
tasminSA1980_2000  <- setZ(tasminSA1980_2000, month_layers, "months")
names(tasminSA1980_2000) <- month_layers

tasmaxSA1980_2000  <-  zApply(tasmax1980_2000, by=month, fun= mean, name = "months")
tasmaxSA1980_2000 <- setZ(tasmaxSA1980_2000, month_layers, "months")
names(tasmaxSA1980_2000) <- month_layers

tasSA1980_2000  <-  zApply(tas1980_2000, by=month, fun= mean, name = "months")
tasSA1980_2000  <- setZ(tasSA1980_2000, month_layers, "months")
names(tasSA1980_2000) <- month_layers

# For current temperature: We're using from 2000 onward (Dec 1999 (nl= 229))
# Drop layer we do not need (Dec 1980 to Nov 1999)
tasmin2000_2080 <- dropLayer(tasminM, c(1:228))
tasmax2000_2080 <- dropLayer(tasmaxM, c(1:228))
tas2000_2080 <- dropLayer(tasM, c(1:228))

# Now, I need to subtract current temp - historical temp by month

#AnomTime_layers <- as.character(seq(as.Date("1999/12/01"), as.Date("2080/11/30"), by = "month"))
#AnomMin2000_2080 <- brick(nrows=109, ncols=55, xmn=0, xmx=660000, ymn=-84000, ymx=1224000 , nl=972)
#names(AnomMin2000_2080) <- AnomTime_layers

#for(i in 1:2){
#  (subset(AnomMin2000_2080, which(substr(names(tasmin2000_2080),6,7) %in% c(i)))) <- (subset(tasmin2000_2080, which(substr(names(tasmin2000_2080),6,7) %in% c(i)))) - tasminSA1980_2000[[i]]
#}

# TasMin
TasMinAnomDec <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("12")))) - tasminSA1980_2000[[1]]
Dec_layers <- seq(as.Date("1999/12/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomDec) <- Dec_layers

TasMinAnomJan <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("01")))) - tasminSA1980_2000[[2]]
Jan_layers <- seq(as.Date("2000/01/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomJan) <- Jan_layers

TasMinAnomFeb <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("02")))) - tasminSA1980_2000[[3]]
Feb_layers <- seq(as.Date("2000/02/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomFeb) <- Feb_layers

TasMinAnomMar <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("03")))) - tasminSA1980_2000[[4]]
Mar_layers <- seq(as.Date("2000/03/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomMar) <- Mar_layers

TasMinAnomApr <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("04")))) - tasminSA1980_2000[[5]]
Apr_layers <- seq(as.Date("2000/04/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomApr) <- Apr_layers

TasMinAnomMay <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("05")))) - tasminSA1980_2000[[6]]
May_layers <- seq(as.Date("2000/05/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomMay) <- May_layers

TasMinAnomJun <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("06")))) - tasminSA1980_2000[[7]]
Jun_layers <- seq(as.Date("2000/06/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomJun) <- Jun_layers

TasMinAnomJul <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("07")))) - tasminSA1980_2000[[8]]
Jul_layers <- seq(as.Date("2000/07/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomJul) <- Jul_layers

TasMinAnomAug <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("08")))) - tasminSA1980_2000[[9]]
Aug_layers <- seq(as.Date("2000/08/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomAug) <- Aug_layers

TasMinAnomSep <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("09")))) - tasminSA1980_2000[[10]]
Sep_layers <- seq(as.Date("2000/09/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomSep) <- Sep_layers

TasMinAnomOct <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("10")))) - tasminSA1980_2000[[11]]
Oct_layers <- seq(as.Date("2000/10/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomOct) <- Oct_layers

TasMinAnomNov <- (subset(tasmin2000_2080, which(substr(getZ(tasmin2000_2080),6,7) %in% c("11")))) - tasminSA1980_2000[[12]]
Nov_layers <- seq(as.Date("2000/11/01"), as.Date("2080/11/30"), by = "year")
names(TasMinAnomNov) <- Nov_layers

TasMinAnom2000_2080 <- stack(TasMinAnomDec, TasMinAnomJan, TasMinAnomFeb, TasMinAnomMar, TasMinAnomApr, TasMinAnomMay,
                             TasMinAnomJun, TasMinAnomJul, TasMinAnomAug, TasMinAnomSep, TasMinAnomOct, TasMinAnomNov)

# TasMax
TasMaxAnomDec <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("12")))) - tasmaxSA1980_2000[[1]]
names(TasMaxAnomDec) <- Dec_layers

TasMaxAnomJan <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("01")))) - tasmaxSA1980_2000[[2]]
names(TasMaxAnomJan) <- Jan_layers

TasMaxAnomFeb <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("02")))) - tasmaxSA1980_2000[[3]]
names(TasMaxAnomFeb) <- Feb_layers

TasMaxAnomMar <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("03")))) - tasmaxSA1980_2000[[4]]
names(TasMaxAnomMar) <- Mar_layers

TasMaxAnomApr <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("04")))) - tasmaxSA1980_2000[[5]]
names(TasMaxAnomApr) <- Apr_layers

TasMaxAnomMay <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("05")))) - tasmaxSA1980_2000[[6]]
names(TasMaxAnomMay) <- May_layers

TasMaxAnomJun <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("06")))) - tasmaxSA1980_2000[[7]]
names(TasMaxAnomJun) <- Jun_layers

TasMaxAnomJul <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("07")))) - tasmaxSA1980_2000[[8]]
names(TasMaxAnomJul) <- Jul_layers

TasMaxAnomAug <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("08")))) - tasmaxSA1980_2000[[9]]
names(TasMaxAnomAug) <- Aug_layers

TasMaxAnomSep <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("09")))) - tasmaxSA1980_2000[[10]]
names(TasMaxAnomSep) <- Sep_layers

TasMaxAnomOct <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("10")))) - tasmaxSA1980_2000[[11]]
names(TasMaxAnomOct) <- Oct_layers

TasMaxAnomNov <- (subset(tasmax2000_2080, which(substr(getZ(tasmax2000_2080),6,7) %in% c("11")))) - tasmaxSA1980_2000[[12]]
names(TasMaxAnomNov) <- Nov_layers

TasMaxAnom2000_2080 <- stack(TasMaxAnomDec, TasMaxAnomJan, TasMaxAnomFeb, TasMaxAnomMar, TasMaxAnomApr, TasMaxAnomMay,
                             TasMaxAnomJun, TasMaxAnomJul, TasMaxAnomAug, TasMaxAnomSep, TasMaxAnomOct, TasMaxAnomNov)

# Tas
TasAnomDec <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("12")))) - tasSA1980_2000[[1]]
names(TasAnomDec) <- Dec_layers

TasAnomJan <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("01")))) - tasSA1980_2000[[2]]
names(TasAnomJan) <- Jan_layers

TasAnomFeb <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("02")))) - tasSA1980_2000[[3]]
names(TasAnomFeb) <- Feb_layers

TasAnomMar <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("03")))) - tasSA1980_2000[[4]]
names(TasAnomMar) <- Mar_layers

TasAnomApr <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("04")))) - tasSA1980_2000[[5]]
names(TasAnomApr) <- Apr_layers

TasAnomMay <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("05")))) - tasSA1980_2000[[6]]
names(TasAnomMay) <- May_layers

TasAnomJun <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("06")))) - tasSA1980_2000[[7]]
names(TasAnomJun) <- Jun_layers

TasAnomJul <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("07")))) - tasSA1980_2000[[8]]
names(TasAnomJul) <- Jul_layers

TasAnomAug <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("08")))) - tasSA1980_2000[[9]]
names(TasAnomAug) <- Aug_layers

TasAnomSep <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("09")))) - tasSA1980_2000[[10]]
names(TasAnomSep) <- Sep_layers

TasAnomOct <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("10")))) - tasSA1980_2000[[11]]
names(TasAnomOct) <- Oct_layers

TasAnomNov <- (subset(tas2000_2080, which(substr(getZ(tas2000_2080),6,7) %in% c("11")))) - tasSA1980_2000[[12]]
names(TasAnomNov) <- Nov_layers

TasAnom2000_2080 <- stack(TasAnomDec, TasAnomJan, TasAnomFeb, TasAnomMar, TasAnomApr, TasAnomMay,
                             TasAnomJun, TasAnomJul, TasAnomAug, TasAnomSep, TasAnomOct, TasAnomNov)

#################################################
# Creating averages by seasons
#################################################
# Winter (December-January-February, DJF);
# Spring (March-April-May, MAM);
# Summer (June-July-August, JJA);
# Autumn (September-October-November, SON)

# 2020 avg temp for winter... -> 2080

# Same thing for decades


treatmentTypes <- c("3TC", "NRTI", "NNRTI", "PI", "total")

cond_surv <- foreach(treatmentType = treatmentTypes, .combine = "rbind")%do%{

    print(paste0("Analyzing ", treatmentType))

    #read in the data -
    #NOTE: this data must be acquired via the BC Centre for Excellence in HIV/AIDS
    km <- read.table(paste0("BC_KM_", treatmentType, ".csv"), sep = ",", header = TRUE)

    #I think we should just be selecting the columns STRATUM, follow_X_res, and Censor here
    km <- km[c(1, 3, 4)]

    #standardize column names
    colnames(km) <- c('STRATUM', "follow_res", "Censor")

    #For this survival analysis, we need our censor events to be encoded by 0s
    km <- cbind(km, Event = 1 - km$Censor)

    #We only want to keep individuals from strata 1 and 2
    km.toanalyze <- km[km$STRATUM == 1 | km$STRATUM == 2, ]

    #For each year of follow up
    conditional_survivals <- foreach(k = 0:9, .combine = "rbind")%do%{

                          #This should fit the conditional survival probability for year k + 1
                          #conditional only on individuals with no events up to year k
                          #the time1 = follow_res, event1 = 0 means that there are no additional
                          #events we're tracking beyond the initial endpoint
        cond_surv_year_k <- summary(survCOND(survCS(
            time1 = follow_res, event1 = Event,
            Stime = follow_res, event = Event) ~ 1,
            x = k, y = k+1,
            data = km.toanalyze, method = "KMW"))

        #Let's also keep track of the sample sizes at the start of each year
        n <- nrow(km.toanalyze[km.toanalyze$follow_res >= k, ])

        return(c(as.numeric(cond_surv_year_k), n))

    }

    colnames(conditional_survivals) <-
        c("Year", "point.estimate", "95_conf_low", "95_conf_high", "n")

    km.toanalyze.with.dummy <- km.toanalyze
    km.toanalyze.with.dummy$dummy = 0
    surv_object <- Surv(time = km.toanalyze.with.dummy$follow_res,
                        event = km.toanalyze.with.dummy$Event)
    fit1 <- survfit(surv_object ~ dummy, data = km.toanalyze.with.dummy)
    km.est <- (((summary(fit1, times = 0:10)))[[6]])[-1]

    tbl_df(conditional_survivals) %>% mutate(km = km.est,
                                             treatmentType = treatmentType)# %>%
#    mutate(year_kp1_over_year_k = ifelse(is.na(lag(km)), km, km/lag(km))) %>%
#    select(Year, point.estimate, year_kp1_over_year_k)
#   This commented code can also be used to compute a rough estimate of the conditional
#   survival probability from the km estimates.

}

write.table(cond_surv, "../processed/conditional_survival_analysis.csv",
            sep = ",", col.names = TRUE,
            row.names = FALSE, quote = FALSE)


## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for the Soay sheep coat colour IBM
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

library(arm) ## invlogit

## Population statistics from annual sheep data
sdNt <- 127.1302
midNt <- 431.7917
scaleN <- function(N) return((N-midNt)/sdNt)

## Mean age and capture weight of mothers of age 0 individuals (from
## Soay demographic data)
mean.ageMum <- 4.06147
mean.capWgtMum <- 3.082146

initState <- function (m.par, init.pop.size = 500, init.G = NULL, maxA = 15) {
    ## Initialise individual state array for the population.

    ## Follows strategy in supplementary material to Rees et al. 2014,
    ## which is to initialise the population with a random selection
    ## of new recruits from a normal distribution based on mean parent
    ## size.

    ## If an initial genotype is specified then the new individuals
    ## are assigned to that genotype, with an equal number of
    ## offspring of each sex. Otherwise, offspring are equally
    ## distributed between sexes and genotypes.

    ## Args:
    ##   m.par: Demographic model parameters.
    ##   init.pop.size: Initial size of the population.
    ##   init.G: Initial genotype of population.
    ##   maxA: Maximum age.

    ## Returns:
    ##   Individual state array containing the size of each individual
    ##   in the population, structured by age, sex and coat colour
    ##   genotype.

    ## Population structure - age, sex, genotype
    Aset <- as.character(seq.int(0, maxA))
    Gset <- c("GG","GT","TT")
    Sset <- c("F","M")

    ## Initialise state array
    z <- mk.flist(list(S=Sset, A=Aset, G=Gset))

    ## Assume equal numbers of offspring of each sex, distributed
    ## equally amongst genotypes, unless an initial genotype is
    ## specified.
    n <- ifelse(is.null(init.G), init.pop.size/6, init.pop.size/2)

    ## Get proportion of twins in the new population based on twinning
    ## rate for an average adult female
    p.twin <- invlogit(m.par["t.a1.F.(Intercept)"] + m.par["t.a1.F.capWgt"]*mean.capWgtMum
                       + m.par["t.a1.F.poly(ageY, 2, raw = TRUE)1"]*mean.ageMum
                       + m.par["t.a1.F.poly(ageY, 2, raw = TRUE)2"]*mean.ageMum^2)
    ## Proportion of twins is number of twin lambs over total number of lambs
    ## From twinning rate, 0.5*num.twin = p.twin(0.5*num.twin + num.sing))
    ## Substitute num.sing = num.tot - num.twin and rearrange to get num.twin/num.tot:
    prop.twin <- 2*p.twin/(1+p.twin)

    ## Get the sizes of the new individuals in each class, based on
    ## mean maternal state
    for (G in Gset) {
        if (!is.null(init.G) && init.G != G) next
        for (S in Sset) {
            mu <- m.par["sz.off.(Intercept)"] +
                m.par["sz.off.capWgtMum"]*mean.capWgtMum +
                    m.par["sz.off.ageMum"]*mean.ageMum +
                        m.par["sz.off.sexM"]*as.numeric(S=="M")

            z[[S, "0", G]] <- c(rnorm(n*prop.twin
                                      , mean = mu + m.par["sz.off.isTwnMat"]
                                      , sd = m.par["sz.off.sigma"]),
                                rnorm(n*(1-prop.twin)
                                      , mean = mu
                                      , sd = m.par["sz.off.sigma"]))

        }
    }
    return(z)
}

doSim <- function (model.params, init.pop.size = 500, sim.length = 200, init.G = NULL, init.state = NULL, maxA = 15) {
    ## Run simulation for the Soay coat colour genotype IBM.

    ## This could be generalised to require that client passes in the
    ## functions required to set up the state array for the system and
    ## to iterate the array between time steps.

    ## Args:
    ##   model.params: Demographic model parameters.
    ##   init.pop.size: Initial size of the population.
    ##   sim.length: Maximum number of time-steps in simulation.
    ##   init.G: Initial genotype.
    ##   init.state: Initial state array. If not specified then an
    ##      initial population state array is generated.
    ##   maxA: Maximum age of individuals.

    ## Returns:
    ##   Time series data consisting of population state array for each time step.

    ## Check the dimensions of model.params to determine whether
    ## to run simulation as averaged or variable environment.
    tEnv <- numeric(0)
    mPar <- model.params
    if (!is.null(dim(mPar))) {
        ## Sample environment parameters from the set available
        tEnv <- sample(1:(dim(mPar)[2]), sim.length+1, replace=TRUE)
        mPar <- model.params[,tEnv[1]]
    }

    ## Get initial population state
    if (is.null(init.state)) {
        z <- initState (mPar, init.pop.size, init.G, maxA)
    } else {
        z <- init.state
    }

    ## Population structure - age, sex, genotype
    Aset <- dimnames(z)$A
    Gset <- dimnames(z)$G
    Sset <- dimnames(z)$S

    numAset <- as.numeric(Aset)
    names(numAset) <- Aset
    numGset <- seq.int(-1,1)
    names(numGset) <- Gset

    ## Storage for simulated population at each timestep
    zt <- list(sim.length)

    for (i in seq_len(sim.length)) {
        if(length(tEnv)>0) {
            ## Select model parameters for this step
            mPar <- model.params[,tEnv[i+1]]
        }

        ## Get the current population density (standardized according
        ## to the mean and standard deviation observed in the St Kilda
        ## population)
        Nt <- scaleN(length(unlist(z)))

        ## Calculate male paternity probabilities for each genotype
        pGm <- calcMalePaternity(z, Nt, mPar)

        ## Apply life history events
        z1 <- mk.flist(list(S=Sset, A=Aset, G=Gset))
        z1.rec <- mk.flist(list(S=Sset, G=Gset))
        for (G in Gset) {
            numG <- switch(G, GG=-1, GT=0, TT=+1)
            for (A in Aset) {
                numA <- numAset[A]
                for (S in Sset) {
                    z.sub <- z[[S, A, G]]
                    if (!is.null(z.sub) & length(z.sub) > 0) {

                        ## survival
                        pS <- p.surv(z.sub, numG, S, numA, Nt, mPar)
                        surv <- rbinom(n=length(z.sub), prob=pS, size=1)
                        z.sub <- z.sub[which(surv == 1)]

                        if (length(z.sub) == 0) next

                        ## growth
                        if (numA < maxA) {
                            z1[[S, as.character(numA+1), G]] <- r.grow(z.sub, numG, S,
                                                                       numA, Nt, mPar)
                        }

                        ## reproduction
                        if (S == "F" && !is.na(pGm)) {
                            pB <- p.repr(z.sub, numG, numA, Nt, mPar)
                            repr <- rbinom(n=length(z.sub), prob=pB, size=1)
                            z.repr <- z.sub[which(repr == 1)]

                            ## Twin or not?
                            pT <- p.twin(z.repr, numG, numA, Nt, mPar)
                            twin <- rbinom(n=length(z.repr), prob=pT, size=1)

                            for (t.off in seq.int(0,1)) {

                                z_ <- z.repr[which(twin == t.off)]
                                n.off <- ifelse(t.off == 1, 2*length(z_), length(z_))

                                ## Offspring sex
                                o.sex <- rbinom(n=n.off, prob=0.5, size=1)
                                o.sex <- paste(c("F","M")[match(o.sex, c(0,1))])

                                ## Offspring genotype
                                ## pGm is paternity probability for male genotypes
                                pOffgen <- p.offgenotype(Gset, G, pGm)
                                ## Assign (numeric) genotypes to
                                ## offspring; not taking account of
                                ## paternity of twins for now. (Pemberton
                                ## et al. 1999 recorded 26% of twins with
                                ## known paternity having same sire.)
                                o.gen <- rmultinom(n=n.off, prob=pOffgen, size=1)
                                o.gen <- t(o.gen)%*%numGset

                                ## Offspring survival
                                ## Need to do for each offspring sex (M/F) and twin (0/1) status
                                for (s.off in Sset) {
                                    ## Index into maternal set for this sex
                                    ## This should sort out the parents appropriately for twin offspring
                                    i.subset <- which(o.sex == s.off)
                                    i.par <- ifelse(t.off == 1, ceiling(i.subset/2), i.subset)
                                    pRec <- p.offsurv(z_[i.par], A=numA, Nt=Nt, mPar=mPar,
                                                      S.off=s.off, T.off=t.off)
                                    recr <- rep(NA, n.off)
                                    recr[i.subset] <- rbinom(n=length(i.subset), prob=pRec, size=1)

                                    ## Recruit size
                                    if (sum(recr,na.rm=TRUE)>0) {
                                        z1.rec <- rep(NA, n.off)
                                        i.recr <- which(recr == 1)
                                        i.par <- ifelse(t.off == 1, ceiling(i.recr/2), i.recr)
                                        z1.rec[i.recr] <- r.offsize(z_[i.par], numG, numA, Nt,
                                                                    mPar, S.o=s.off, T.off=t.off)
                                        ## Store result for each genotype from the survivors
                                        for (numG.off in unique(o.gen[which(recr==1)])) {
                                            G.off <- Gset[numG.off+2]
                                            z1[[s.off, "0", G.off]] <- c(z1[[s.off, "0", G.off]],
                                                                         z1.rec[which(recr == 1 &
                                                                                o.gen == numG.off)])
                                        }
                                    }
                                }
                            }
                        }
                    }
                }
            }
        }
        ## Store population for this timestep
        zt[[i]] <- z1
        if(length(unlist(z1)) == 0) {
            break
        }
        z <- z1
    }
    return(zt)
}

calcMalePaternity <- function(z, Nt, model.params) {
    ## Calculate male paternity probabilities for each genotype.

    ## Calculates male paternity probabilities for each genotype based
    ## on the expected number of offspring for males of each genotype
    ## in the population.

    ## Args:
    ##   z: Population state vector
    ##   Nt: Population density
    ##   model.params: Vital rate model parameters

    ## Returns:
    ##   Vector indicating the probability of paternity for males of
    ##   each genotype, or NA if the expected number of offspring for
    ##   all genotypes is zero.

    Gset <- dimnames(z)$G
    Aset <- dimnames(z)$A
    num.off <- mk.flist(list(G=Gset))
    for (G in Gset) {
        num.off[[G]] <- 0
        numG <- switch(G, GG=-1, GT=0, TT=+1)
        for (A in Aset) {
            z.sub <- z[["M", A, G]]
            if (!is.null(z.sub) & length(z.sub) > 0) {
                numA <- as.numeric(A)
                ## n.mrepro gives mean num offspring for each individual
                lambda <- n.mrepro(z.sub, numG, numA, Nt, model.params)
                ## rpois gets random pick from Poisson distribution with the given mean
                num.off[[G]] <- sum(sapply(lambda, function(x) rpois(1,x))) + num.off[[G]]
            }
        }
    }
    ## obtain mating probs
    nTot <- sum(unlist(num.off))
    if (nTot > 0) {
        pGm <- sapply(num.off, function(x) x/nTot)
    } else {
        pGm <- NA
    }
    return(pGm)
}

summariseSimRun <- function (simRun) {
    simLen <- length(simRun)
    ntT <- ntF <- ntM <- ntGG <- ntGT <- ntTT <- numeric(simLen)
    ## compute quantities
    for (tt in 1:simLen) {
        nt1 <- simRun[[tt]]
        ntT [tt] <- length(unlist(nt1[   ,,    ]))
        ntF [tt] <- length(unlist(nt1["F",,    ]))
        ntM [tt] <- length(unlist(nt1["M",,    ]))
        ntGG[tt] <- length(unlist(nt1[   ,,"GG"]))
        ntGT[tt] <- length(unlist(nt1[   ,,"GT"]))
        ntTT[tt] <- length(unlist(nt1[   ,,"TT"]))
    }
    return( list(ntT=ntT, ntF=ntF, ntM=ntM, ntGG=ntGG, ntGT=ntGT, ntTT=ntTT) )
}

## Adapted from IPM code
r.grow.list <- mk.flist(list(S=c("F","M"), A=c(0,+1)))

r.grow.list[["F","0"]] <- function(x, Nt, mPar) {
    mu <- mPar["g.a0.F.(Intercept)"]+mPar["g.a0.F.capWgt"]*x+mPar["g.a0.F.Nt"]*Nt
    sg <- mPar["g.a0.F.sigma"]
    return(rnorm(length(x),mu,sg))
}
r.grow.list[["F","1"]] <- function(x, G, A, Nt, mPar) {
    mu <- mPar["g.a1.F.(Intercept)"] +
        mPar["g.a1.F.capWgt"]*x +
            mPar["g.a1.F.poly(ageY, 2, raw = TRUE)1"]*A +
                mPar["g.a1.F.Nt"]*Nt +
                    mPar["g.a1.F.ageY:Nt"]*Nt*A +
                        mPar["g.a1.F.poly(ageY, 2, raw = TRUE)2"]*A^2
    sg <- mPar["g.a1.F.sigma"]
    return(rnorm(length(x),mu,sg))
}
r.grow.list[["M","0"]] <- function(x, Nt, mPar) {
    mu <- mPar["g.a0.M.(Intercept)"]+
        mPar["g.a0.M.capWgt"]*x+
            mPar["g.a0.M.Nt"]*Nt+
                mPar["g.a0.M.obsY"]*mPar["obsY"]
    sg <- mPar["g.a0.M.sigma"]
    return(rnorm(length(x),mu,sg))
}
r.grow.list[["M","1"]] <- function(x, G, A, Nt, mPar) {
    mu <- mPar["g.a1.M.(Intercept)"] +
        mPar["g.a1.M.capWgt"]*x
    sg <- mPar["g.a1.M.sigma"]
    return(rnorm(length(x),mu,sg))
}

r.grow <- function(x, G, S, A, Nt, mPar)
{
    ## expect S and A to have length=1
    if (length(S) != 1 | length(A) != 1)
        stop("growth function not vectorised for S(ex) and (A)ge")
    ## assign the required function
    if       (S=="F") {
        if        (A ==  0) {
            f <- r.grow.list[["F", "0"]]
        } else if (A >=  1) {
            f <- r.grow.list[["F", "1"]]
        } else stop("invalid (A)ge")
    } else if (S=="M") {
        if        (A ==  0) {
            f <- r.grow.list[["M", "0"]]
        } else if (A >=  1) {
            f <- r.grow.list[["M", "1"]]
        } else stop("invalid (A)ge")
    } else stop("invalid (S)ex")
    ## get the required arguments as a list of atomic 'names'
    fargs <- names(formals(f))
    fargs <- sapply(fargs, as.name)
    ## call the function and return
    return(do.call("f", fargs))
}

## Adapted from IPM code
r.offsize.list <- mk.flist(list(S.off=c("F","M"), T.off=c("0","1")))

r.offsize.list[["F","0"]] <- function(x, A, Nt, mPar) {
    mu <- mPar["sz.off.(Intercept)"]+mPar["sz.off.capWgtMum"]*x+
          mPar["sz.off.ageMum"]*A+
          mPar["sz.off.Ntm1"]*Nt+
          mPar["sz.off.obsY"]*mPar["obsY"]+
          mPar["sz.off.ageMum:obsY"]*A*mPar["obsY"]
    sg <- mPar["sz.off.sigma"]
    return(rnorm(length(x),mu,sg))
}
r.offsize.list[["M","0"]] <- function(x, A, Nt, mPar) {
    mu <- mPar["sz.off.(Intercept)"]+mPar["sz.off.capWgtMum"]*x+
          mPar["sz.off.ageMum"]*A+
          mPar["sz.off.Ntm1"]*Nt+mPar["sz.off.sexM"]+
          mPar["sz.off.obsY"]*mPar["obsY"]+
          mPar["sz.off.ageMum:obsY"]*A*mPar["obsY"]
    sg <- mPar["sz.off.sigma"]
    return(rnorm(length(x),mu,sg))
}
r.offsize.list[["F","1"]] <- function(x, A, Nt, mPar) {
    mu <- mPar["sz.off.(Intercept)"]+mPar["sz.off.capWgtMum"]*x+
          mPar["sz.off.ageMum"]*A+
          mPar["sz.off.Ntm1"]*Nt+mPar["sz.off.isTwnMat"]+
          mPar["sz.off.obsY"]*mPar["obsY"]+
          mPar["sz.off.ageMum:obsY"]*A*mPar["obsY"]
    sg <- mPar["sz.off.sigma"]
    return(rnorm(length(x),mu,sg))
}
r.offsize.list[["M","1"]] <- function(x, A, Nt, mPar) {
    mu <- mPar["sz.off.(Intercept)"]+mPar["sz.off.capWgtMum"]*x+
          mPar["sz.off.ageMum"]*A+
          mPar["sz.off.Ntm1"]*Nt+mPar["sz.off.sexM"]+mPar["sz.off.isTwnMat"]+
          mPar["sz.off.obsY"]*mPar["obsY"]+
          mPar["sz.off.ageMum:obsY"]*A*mPar["obsY"]
    sg <- mPar["sz.off.sigma"]
    return(rnorm(length(x),mu,sg))
}

r.offsize <- function(x, G, A, Nt, mPar, S.off, T.off)
{
    ## expect S and A to have length=1
    if (length(S.off) != 1 | length(T.off) != 1)
        stop("offspring size function not vectorised for offspring S(ex), female (A)ge and (T)win status")
    ## assign the required function
    if (all(A >= 0)) {
        if        (S.off == "F") {
            if        (T.off == 0) {
                f <- r.offsize.list[["F","0"]]
            } else if (T.off == 1) {
                f <- r.offsize.list[["F","1"]]
            } else stop("invalid offspring (T)win status")
        } else if (S.off == "M") {
            if        (T.off == 0) {
                f <- r.offsize.list[["M","0"]]
            } else if (T.off == 1) {
                f <- r.offsize.list[["M","1"]]
            } else stop("invalid offspring (T)win status")
        } else stop("invalid offspring (S)ex")
    } else stop("invalid (A)ge")
    ## get the required arguments as a list of atomic 'names'
    fargs <- names(formals(f))
    fargs <- sapply(fargs, as.name)
    ## call the function and return
    return(do.call("f", fargs))
}


#####################################################################################################
# Function for FDR corrected hypergeometric enrichment test
#####################################################################################################
set.based.enrichment.test=function(steps, pool, select, DB, nthread=1) {

  ## convert the database and the select and pollt to sorted integer lists
  list_of_all_genes<-unique(c(unlist(DB),pool))

  select <- intersect ( select, pool)

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

  DB_names <- names(DB)
  number_of_DB_categories <- length(DB)  # Number of DB categories
  size_pool <- length(pool)
  size_select <- length(select)

  # init empty data frame  with the row-size of DB (number of DB categories) to store the result
  result_df1 <- data.frame(
    DB_names=DB_names,
    DB_in_select = as.integer(NA),
    DB_in_pool = as.integer(NA),
    Genes_in_DB = as.integer(NA),
    P_val = as.double(NA),
    R_obs = as.integer(NA)
  )

   # for every DB entity in the DB list
  for (i in 1:number_of_DB_categories)
  {
    # create a vector of genes connected to the i-th DB category
    current_DB_category=DB[[i]]
    # hypergometric test
    result_df1$DB_in_select[i]=length(intersect(select,current_DB_category)) 	#q: number of common genes between a DBterm and select
    result_df1$DB_in_pool[i]=length(intersect(pool,current_DB_category))	#m: number of common genes between DBterm and BackGround
    result_df1$Genes_in_DB[i]=length(current_DB_category)

  }

  # compute the p values  (raw p values witout any corrections )
  #
  # n: number of non-pool genes among DB
  # k: number of genes in select
  # phyper(q, m, n, k, lower.tail = TRUE, log.p = FALSE)
  result_df1$P_val=1-phyper(result_df1$DB_in_select-1, result_df1$DB_in_pool, size_pool-result_df1$DB_in_pool, size_select)

  P_val_round=round(result_df1$P_val, digits=15) ## can change the digits, this is important for the precision of '0' is R
  result_df1$R_obs=rank(P_val_round, na.last = TRUE,ties.method ="max")

  result_df1$P_adj_Bonf=p.adjust(result_df1$P_val, method="bonferroni")
  result_df1$P_adj_BH=p.adjust(result_df1$P_val, method="BH")

  ################################################
  ############# simualtion
  ######

  if(length(select)==0 )
  {
    result_df1$R_exp=NaN
    result_df1$FDR=NaN

    return(result_df1)
  }

  names(DB) <- NULL

  if( nthread==1)
  {

    # simple call op C++ part of the code

    simulation_result_tbl =  tryCatch(
      enrichment_test_simulation(
        DB,
        list_of_all_genes ,
        pool,
        length(select),
        steps,
        0)
      , error = print)  # RCPP calling
  }else if(nthread>1 && round(nthread)==nthread)
  {

    # paralel call of C++

    vv<-floor(steps / nthread)
    cc<-steps %% nthread
    steps_per_thread <- c( rep(vv , nthread-cc),rep(vv+1 , cc))
    seeds_per_thread <- sample( 2^15,nthread)
    stopifnot(sum(  steps_per_thread)==steps)
    rm(cc,vv)

    library(parallel)
    cl <- makeCluster(spec=nthread, type = "PSOCK",outfile= "log1.txt")

    current_env <- environment()
    clusterExport(cl,"DB", envir = current_env)
    clusterExport(cl,"list_of_all_genes", envir = current_env)
    clusterExport(cl,"pool", envir = current_env)
    clusterExport(cl,"select", envir = current_env)
    # clusterExport(cl,"enrichment_test_simulation") #, envir = current_env
    clusterExport(cl,"seeds_per_thread", envir = current_env)
    clusterExport(cl,"steps_per_thread", envir = current_env)

    clusterEvalQ(cl, library(MulEA))

    # Sys.sleep(10)

    # muleaPkgDir <- find.package("MulEA")
    # cppSourceFile <- paste(muleaPkgDir,"/srcCpp/set-based-enrichment-test.cpp", sep = "")
    # clusterExport(cl,"cppSourceFile", envir = current_env)

    # clusterEvalQ(cl, library(Rcpp))

    # clusterEvalQ(cl, Sys.setenv("PKG_CXXFLAGS"="-std=c++11"))
    # sourceCpp(code='
    #   #include <Rcpp.h>
    #
    #   // [[Rcpp::export]]
    #   int fibonacci(const int x) {
    #     if (x == 0) return(0);
    #     if (x == 1) return(1);
    #     return (fibonacci(x - 1)) + fibonacci(x - 2);
    #   }'
    # )

    # clusterEvalQ(cl, sourceCpp(cppSourceFile))
    # clusterEvalQ(cl, Rcpp::sourceCpp(cppSourceFile))

    result_of_paralel <- clusterApplyLB(cl=cl,1:nthread, function(idx){
      simulation_result_tbl <-  tryCatch(
        enrichment_test_simulation(
          DB,
          list_of_all_genes ,
          pool,
          length(select),
          steps_per_thread[[idx]],
          seeds_per_thread[[idx]])
        , error = print)  # RCPP hívás

      return(simulation_result_tbl)
    })

    stopCluster(cl)
    simulation_result_tbl<-do.call(rbind, result_of_paralel)

  }else{
    stop("nthred parameter must be a positive integer number")
  }

  names(simulation_result_tbl)<-c("DB_in_pool","intersect.size","multiplicity") # set the column names
  simulation_result_tbl$p <- 1-phyper(simulation_result_tbl$intersect.size-1, simulation_result_tbl$DB_in_pool, length(pool)-simulation_result_tbl$DB_in_pool,  length(select))

  # test consitency
  stopifnot(steps*length(DB)==sum(simulation_result_tbl$multiplicity))  # ez nem fontos, de igy kell legyen
  if(! all(is.finite(simulation_result_tbl$p)) ) {stop("ERROR_002")} # TODO handle somehow the exception

  # from the manual of phyper(q, m, n, k)
  #
  # simulation_result_tbl$intersect.size-1  ~ q  vector of quantiles representing the number of white balls drawn without replacement from an urn which contains both black and white balls.
  #
  # simulation_result_tbl$DB_in_pool               ~ m   the number of white balls in the urn.
  # length(pool)-simulation_result_tbl$DB_in_pool  ~ n 	the number of black balls in the urn.
  # length(select)                             ~ k  the number of balls drawn from the urn, hence must be in 0,1,…, m+n.

  #############################
  # group by the equal p-values and summarise the multiplicities

  simulation_result_tbl<-simulation_result_tbl[,c("multiplicity","p")]
  simulation_result_tbl$p<-round(simulation_result_tbl$p, digits=15)
  simulation_result_tbl<-simulation_result_tbl[order(simulation_result_tbl$p),]

  list11<- split(simulation_result_tbl,simulation_result_tbl$p)

  for( i in seq(list11))
  {
    if(nrow( list11[[i]])>1)
    {
      list11[[i]]<-data.frame(multiplicity=sum(list11[[i]]$multiplicity),p=list11[[i]]$p[1])
    }
  }
  simulation_result_tbl<-do.call(rbind, list11)
  rownames(simulation_result_tbl)<-NULL
  rm(list11)

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

  ##########

  # some preparation to help the binary search
  if(simulation_result_tbl$p[1]!=0)
  {
    simulation_result_tbl<-rbind(data.frame(multiplicity=0,p=0),simulation_result_tbl)
  }
  if(simulation_result_tbl$p[nrow(simulation_result_tbl)]!=1)
  {
    simulation_result_tbl<-rbind(simulation_result_tbl,data.frame(multiplicity=0,p=1))
  }

  simulation_result_tbl$cum_sum_multiplicity<-cumsum(simulation_result_tbl$multiplicity)

  R_exp=integer(number_of_DB_categories) # init an empty vector. I  will store here the result

  NN<-simulation_result_tbl$cum_sum_multiplicity[nrow(simulation_result_tbl)] # this id the greatest/last in cumsum.multiplicity
  for (i in 1:number_of_DB_categories) {
    if(P_val_round[i]>=1)
    {
      R_exp[i]= NN  # it makes things much faster
    }else{
      target<-P_val_round[i]

      # binary search
      a1 <- 1
      a2 <- nrow(simulation_result_tbl) #-cnt.of.ones
      while(a1+1 < a2)
      {

        a3<-floor((a1+a2)/2)
        current <- simulation_result_tbl$p[a3]
        if( current <= target)
        {
          a1<-a3
        }
        else
        {
          a2<-a3
        }
      }
      # at the end of the binary search the
      # simulation_result_tbl$cum_sum_multiplicity[[a1]] is the count of p where p<=target
      # and a2=a1+1
      #		 		R_exp[l]<-a2
      R_exp[i]<-simulation_result_tbl$cum_sum_multiplicity[[a1]]
    }
  }
  result_df1$R_exp=R_exp/steps
  result_df1$FDR=result_df1$R_exp/result_df1$R_obs

  return(result_df1)
}


#!/usr/bin/env Rscript

args <- commandArgs(trailingOnly = TRUE)

t <- args[1]
a <- as.integer(args[2])
b <- as.integer(args[3])
c <- as.integer(args[4])
d <- as.integer(args[5])

fet <- fisher.test(matrix(c(a,b,c,d),2,2), alternative = t)
cat(paste(c(fet$p.value, fet$estimate, paste(fet$conf.int, sep=" "), sep=" ")))


#  James Rekow

conSynthChrtCreator = function(synthM, abdList, conGraph, int = TRUE, numSample = numSample){

  #  compute the number of samples in the base cohort
  M = length(abdList)

  #  create adjacency matrix for connectivity graph
  adjMat = as.matrix(get.adjacency(conGraph, type = "both"))

  if(int){

    #  make a list to store samples that are not part of any connected subgraphs with
    #  M or more vertices
    unfitSamples = c()

    constructSynthChrt = function(synthM, M, adjMat, unfitSamples){

      #  samples in the synthetic cohort
      synthSamples = 0 * (1:synthM)

      validStartSamples = 1:M

      if(length(unfitSamples > 0)){
        validStartSamples = validStartSamples[-unfitSamples]
      }

      #  select the first sample
      newSample = sample(validStartSamples, 1)

      #  add the first sample to the synthetic cohort
      synthSamples[1] = newSample

      #  remove extraneous edges connecting to newSample from the adjacency matrix
      adjMat[newSample, ] = 0

      #  samples which are connected to any of the samples in the existing synthetic cohort
      potentialSamples = which(adjMat[ , synthSamples[1]] == 1)

      for(ii in 2:synthM){

        #  if there are no potential samples, but the synthetic cohort is not large enough, mark all
        #  of the synthSamples produced on this iteration as unfit, as they form a connected subgraph
        #  that is disconnected from all of the other samples, but insufficiently large to create a
        #  synthetic cohort with synthM samples
        if(length(potentialSamples) == 0){

          #  return the negative indices of samples if they are not part of any connected synthetic
          #  cohort with at least synthM vertices
          synthSamples = -synthSamples
          break

        } #  end if

        ##  select a new sample to add to the synthetic cohort
        if(length(potentialSamples) == 1){
          newSample = potentialSamples[1]
        } #  end if

        if(length(potentialSamples) > 1){
          newSample = sample(potentialSamples, 1)
        } #  end if

        #  remove extraneous edges connecting to newSample from the adjacency matrix
        adjMat[newSample, ] = 0

        #  remove the newly added sample from the vector of potential samples
        potentialSamples = potentialSamples[potentialSamples != newSample]

        #  identify new potential samples from non-reduntant edges incident to newSample
        newPotentialSamples = which(adjMat[ , newSample] == 1)

        #  add new potential samples to potential samples
        potentialSamples = append(potentialSamples, newPotentialSamples)

        #  add the new sample to synthSamples
        synthSamples[ii] = newSample

      } #  end while loop

      return(synthSamples)

    } #  end constructSynthChrt function

    while(length(unfitSamples) < (M - synthM)){

      synthSamples = constructSynthChrt(synthM = synthM, M = M, adjMat = adjMat,
                                        unfitSamples = unfitSamples)

      if(synthSamples[1] < 0){
        unfitSamples = append(unfitSamples, -synthSamples)
        print(unfitSamples)
        print(synthSamples)

      } #  end if

      else{
        break
      } #  end else

    } #  end while loop

    if(synthM > (M - length(unfitSamples))){
      warning("No valid synthetic cohorts could be created.")
      return(NULL)
    } #  end if

    else{
      synthChrt = abdList[synthSamples]
      #  for testing
      return(synthSamples)
      #  end for testing
      return(synthChrt)
    } #  end else

  } #  end if interacting

  #  create whole synthChrts simultaneously, not one by one, then continue. Fix below, or create a
  #  separate interacting and non-interacting method call. Separate out the interacting single
  #  synthSample fcn, then call it in this function to create the whole synthChrt. Alter this function
  #  to return the entire synth chrt.
  if(!int){

    synthSamples = disconnectedSubgraphs(g = conGraph, v = synthM, numSample = numSample)
    synthChrt = abdList[synthSamples] #  need to lapply or something

  } #  end if not interacting

  return(synthChrt)

} #  end conSynthChrtCreator function


# This code requires use of the R package rmutil
library(rmutil)
library(argparse)
library(mdatools)
parser <- ArgumentParser()

parser$add_argument("--file", type="character", default= "no_input_return_error",
    help="file containing variant frequencies and reads")
parser$add_argument("--plot_bool", type="logical", default= FALSE,
    help="determines whether pdf plot exact_plot.pdf is produced or not")
parser$add_argument("--var_calling_threshold", type="double", default= 0.03,
    help="variant calling threshold")
parser$add_argument("--Nb_min", type="integer", default= 1,
    help="Minimum bottleneck value considered")
parser$add_argument("--Nb_max", type="integer", default= 200,
    help="Maximum bottleneck value considered")
parser$add_argument("--confidence_level", type="double", default= .95,
    help="Confidence level (determines bounds of confidence interval)")
args <- parser$parse_args()
if (args$file == "no_input_return_error" ) { stop("file with lists of donor and recipient frequencies is a required argument.", call.=FALSE)}

plot_bool  <- args$plot_bool
var_calling_threshold  <- args$var_calling_threshold
Nb_min <-  args$Nb_min
Nb_max <- args$Nb_max
confidence_level <- args$confidence_level
donor_freqs_recip_freqs_and_reads_observed <- read.table(args$file)
donor_freqs_observed <- as.data.frame(donor_freqs_recip_freqs_and_reads_observed[,1])
n_variants <- nrow(donor_freqs_recip_freqs_and_reads_observed)
recipient_total_reads <- as.data.frame(donor_freqs_recip_freqs_and_reads_observed[,3]) #read.table(args[2])
recipient_var_reads_observed <- as.data.frame(donor_freqs_recip_freqs_and_reads_observed[,4])#read.table(args[3])

##########################################################################
##########################################################log_likelihood_function <- matrix( 0, Nb_max)

generate_log_likelihood_function_exact <- function(donor_freqs_observed, recipient_total_reads, recipient_var_reads_observed, Nb_min, Nb_max, var_calling_threshold, confidence_level)
{
  num_NB_values <- Nb_max -Nb_min + 1
likelihood_matrix <- matrix( 0, n_variants, num_NB_values)
log_likelihood_matrix <- matrix( 0, n_variants, num_NB_values)
  log_likelihood_function <- matrix( 0, Nb_max)
  for (i in 1:n_variants) {for (j in 1:num_NB_values) {
  Nb_val <- (j - 1 + Nb_min)
  nu_donor <- donor_freqs_observed[i, 1]
  variant_reads <- recipient_var_reads_observed[i, 1]
  total_reads <- recipient_total_reads[i, 1]
   if (variant_reads >= var_calling_threshold*total_reads)
   	    { # implement variant calling threshold
    for (k in 0:Nb_val){
	alpha <- k
	beta <- (Nb_val - k)
	if (alpha == 0)
   	    { alpha <- 0.00001 }
   	if (beta == 0)
   	    { beta <- 0.00001 }
    m <- alpha/(alpha + beta)
	s <- (alpha + beta)
    likelihood_matrix[i, j] <- likelihood_matrix[i, j] +
	(dbetabinom( variant_reads, total_reads, m, s, log = FALSE)*dbinom(k, size=Nb_val, prob= nu_donor))
	     }
	log_likelihood_matrix[i,j] = log(likelihood_matrix[i, j])
	 }
   if (variant_reads < var_calling_threshold*total_reads)
   	    { # implement variant calling threshold
   likelihood_matrix[i, j] = 0
   log_likelihood_matrix[i,j] = 0
   for (k in 0:Nb_val){
	alpha <- k
	beta <- (Nb_val - k)
	if (alpha == 0)
   	    { alpha <- 0.00001 }
    if (beta == 0)
   	    { beta <- 0.00001 }
    m <- alpha/(alpha + beta)
	s <- (alpha + beta)
    likelihood_matrix[i, j] <- likelihood_matrix[i, j] +
	(pbetabinom( floor(var_calling_threshold*total_reads), total_reads, m, s)*dbinom(k, size=Nb_val, prob= nu_donor))
	}
    log_likelihood_matrix[i,j] = log(likelihood_matrix[i, j])
         }
# Now we sum over log likelihoods of the variants at different loci to get the total log likelihood for each value of Nb
log_likelihood_function[Nb_val] <- log_likelihood_function[Nb_val] + log_likelihood_matrix[i,j]
}}
return(log_likelihood_function)

}

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

restrict_log_likelihood <- function(log_likelihood_function, Nb_min, Nb_max) # restricts log likelihood to the interval of interst
{
for (h in 1:(Nb_min )){
		if(h< Nb_min)
		{log_likelihood_function[h] = - 999999999}	      # kludge for ensuring that these values less than Nb_min don't interfere with our search for the max of log likelihood in the interval of Nb_min to Nb_max
	  }

return(log_likelihood_function)
#print(erfinv(percent_confidence_interval)*sqrt(2))
}

return_bottleneck_size <- function(log_likelihood_function, Nb_min, Nb_max)
{ max_log_likelihood = which(log_likelihood_function == max(log_likelihood_function))

    return(max_log_likelihood)
}

return_CI_lower <- function(log_likelihood_function, Nb_min, Nb_max) ## returns lower bound of confidence interval
  { max_log_likelihood = which(log_likelihood_function == max(log_likelihood_function))  ## This is the point on the x-axis (bottleneck size) at which log likelihood is maximized
max_val =  max(log_likelihood_function)  ## This is the maximum value of the log likelihood function, found when the index is our bottleneck estimate
CI_height = max_val - erfinv(confidence_level)*sqrt(2)  # This value (  height on y axis) determines the confidence intervals using the likelihood ratio test

    CI_index_lower = Nb_min
  CI_index_upper = max_log_likelihood
for (h in 1:Nb_min){
		if(h< Nb_min)
		{log_likelihood_function[h] = NA}	  #  Removing parameter values less than Nb_min from plot
	      }
## above loop just enforces our minimum bottleneck cutoff
for (h in Nb_min:max_log_likelihood){
		test1 = (log_likelihood_function[CI_index_lower] - CI_height) * (log_likelihood_function[CI_index_lower] - CI_height)
		test2 = (log_likelihood_function[h] - CI_height) * (log_likelihood_function[h] - CI_height)
        if( test2 < test1){  CI_index_lower = h  }
}
if(  (log_likelihood_function[CI_index_lower] - CI_height) > 0  ){CI_index_lower = CI_index_lower - 1   }
# above loops use likelihood ratio test to find lower confidence interval
for (h in max_log_likelihood:Nb_max)
{       test1 = (log_likelihood_function[CI_index_upper] - CI_height) * (log_likelihood_function[CI_index_upper] - CI_height)
	    test2 = (log_likelihood_function[h] - CI_height) * (log_likelihood_function[h] - CI_height)
        if( test2 < test1  ){CI_index_upper = h   }
}
if(  (log_likelihood_function[CI_index_upper] - CI_height) > 0  ){CI_index_upper = CI_index_upper + 1   }

  return(CI_index_lower)

  }

return_CI_upper <- function(log_likelihood_function,  Nb_min, Nb_max) ## returns upper bound of confidence interval
  { max_log_likelihood = which(log_likelihood_function == max(log_likelihood_function))  ## This is the point on the x-axis (bottleneck size) at which log likelihood is maximized
   max_val =  max(log_likelihood_function)  ## This is the maximum value of the log likelihood function, found when the index is our bottleneck estimate
   CI_height = max_val - erfinv(confidence_level)*sqrt(2)  # This value (  height on y axis) determines the confidence intervals using the likelihood ratio test

    CI_index_lower = Nb_min
  CI_index_upper = max_log_likelihood
for (h in 1:Nb_min){
    if(h< Nb_min)
    {log_likelihood_function[h] = NA}   #  Removing parameter values less than Nb_min from plot
        }
## above loop just enforces our minimum bottleneck cutoff
for (h in Nb_min:max_log_likelihood){
    test1 = (log_likelihood_function[CI_index_lower] - CI_height) * (log_likelihood_function[CI_index_lower] - CI_height)
    test2 = (log_likelihood_function[h] - CI_height) * (log_likelihood_function[h] - CI_height)
        if( test2 < test1){  CI_index_lower = h  }
}
if(  (log_likelihood_function[CI_index_lower] - CI_height) > 0  ){CI_index_lower = CI_index_lower - 1   }
# above loops use likelihood ratio test to find lower confidence interval
for (h in max_log_likelihood:Nb_max)
{       test1 = (log_likelihood_function[CI_index_upper] - CI_height) * (log_likelihood_function[CI_index_upper] - CI_height)
      test2 = (log_likelihood_function[h] - CI_height) * (log_likelihood_function[h] - CI_height)
        if( test2 < test1  ){CI_index_upper = h   }
}
if(  (log_likelihood_function[CI_index_upper] - CI_height) > 0  ){CI_index_upper = CI_index_upper + 1   }

  return(CI_index_upper)

  }

log_likelihood_function <- generate_log_likelihood_function_exact(donor_freqs_observed, recipient_total_reads, recipient_var_reads_observed, Nb_min, Nb_max, var_calling_threshold, confidence_level)
log_likelihood_function <- restrict_log_likelihood(log_likelihood_function, Nb_min, Nb_max)
bottleneck_size <- return_bottleneck_size(log_likelihood_function,  Nb_min, Nb_max)
CI_index_lower <- return_CI_lower(log_likelihood_function,  Nb_min, Nb_max)
CI_index_upper <- return_CI_upper(log_likelihood_function,  Nb_min, Nb_max)

		  	##########################
##############################################################################################  ABOVE THIS LINE DETERMINES PEAK LOG LIKELIHOOD AND CONFIDENCE INTERVALS
 # Npw we plot the result
if(plot_bool == TRUE)
{svg(file="exact_plot.svg")
plot(log_likelihood_function)
abline(v = bottleneck_size, col="black" )  # Draws a verticle line at Nb value for which log likelihood is maximized
abline(v = CI_index_lower, col="green" ) # confidence intervals
abline(v = CI_index_upper, col="green" )
dev.off()
}

print("Bottleneck size")
print(bottleneck_size)
print("confidence interval left bound")
print(CI_index_lower)
print("confidence interval right bound")
print(CI_index_upper)


#' Generic density function for HMM's emission probability
#'
#' @param x numeric matrix, size T x p, where T is the number of observations, p the dimension of the obs data
#' @param j hidden state index
#' @param model current model as defined in hmmspec.gen(..)
#' @return the emssion density of hidden state j
#' @details see example code for usage
#' @export
generic.density = function( x, j, model, NegInf=-1000 ) {
   require(corpcor)
   p = NCOL(x)
   Ttot = NROW(x)
   D = model$D
   M = model$M
   if ( length(model$mtype) != p )
      stop("no. of columns does not equal length of mtype.")

   # 1 = discrete
   ix1 = which(model$mtype == 1)
   if ( length(ix1) == 1 ) {
     # prob.v is a vector of length D, the number of multinomial outcomes
     prob.v = model$parms.emission$M1$prob.l[[j]]
     # x is coded so that it just take a simple table look-up to get the emission probability
     if ( model$Log ) {
        logb1 = log(prob.v[x])   # table look up
     } else {
        logb1 = prob.v[x]   # table look up
     }
   } else if ( length(ix1) > 1 ) {
     # prob.m is a matrix max(D) x p
     prob.m = model$parms.emission$M1$prob.l[[j]]
     bb = matrix(0, nrow=Ttot, ncol=length(ix1))
     for ( i in 1:length(ix1) ) {
       if ( model$Log ) {
         bb[,i] = log(prob.m[x[, ix1[i]], i])  # <-- make sure usage matches definition
       } else {
         bb[,i] = prob.m[x[, ix1[i]], i]  # <-- make sure usage matches definition
       }
     }
     if ( model$Log ) {
       logb1 = apply(bb, 1, sum)
     } else {
       logb1 = apply(bb, 1, prod)
     }
   } else {
     if ( model$Log ) {
       logb1 = rep(0, Ttot)
     } else {
       logb1 = rep(1, Ttot)
     }
   }

   # 2 = normal/multivariate
   ix2 = which(model$mtype == 2)
   if ( length(ix2) >= 1 ) {
     # for multivariate normal, M2$mu is a list of vector where the ith element
     # of the list is a vector for state i, and each element of the vector
     # is the mu for a gaussian density;
     # M2$sigma is a list of matrices where the ith element is the cov matrix for
     # state i.
     mu.v = model$parms.emission$M2$mu.l[[j]]
     sigma.m = model$parms.emission$M2$sigma.l[[j]]
     #cat("In generic.density, i see sigma :", as.vector(sigma.m), "\n")
     #ev = eigen(sigma.m)$values
     #cat("In generic.density, i see eigenvalues :", ev, "\n")
     if ( model$Log == FALSE & model$Intv == TRUE ) {
       logb2 = pmvnorm.intv(x[,ix2, drop=FALSE], mean=mu.v, sigma=sigma.m)
     } else {
       # Note that Dmvnorm will return a log value if log is set to TRUE.
       logb2 = Dmvnorm(x[,ix2, drop=FALSE], mean=mu.v, sigma=sigma.m, log=model$Log)
     }
   } else {
     if ( model$Log ) {
       logb2 = rep(0, Ttot)
     } else {
       logb2 = rep(1, Ttot)
     }
   }

   # 5 = gaussian mixture
   ix5 = which(model$mtype == 5)
   #cat("ix5", ix5, "\n")
   if ( length(ix5) >= 1 ) {
     # M5$mu is a list of lists where each element of the lists is a list, and
     # each element of this sublist is a vector corresponding to the mu for each
     # component of the mixture gaussian density; likewise, M5$sigma is a list
     # of lists, each list corresponds to a state, and each element of the sublist
     # corresponds to the cov matrix of a mixture component;
     # M5$c.l is a list of vectors, each element is the state i's mixture proportion
     # NOTATION :   x.ll = list of list     x.l = list
     mu.l = model$parms.emission$M5$mu.ll[[j]]
     sigma.l = model$parms.emission$M5$sigma.ll[[j]]
     c.v = model$parms.emission$M5$c.l[[j]]
     Ttot = NROW(x)
     # check for consistency
     #if ( length(c.v) != M ) {
      # cat("c.v length, M :", length(c.v), M, "\n")
      # stop("length mismatch in mixture parameters.")
     #}
     # logbb : each row is a log probability of observing one observation (a row in x[,])
     # conditioned on mu and sigma of the hidden state
     logbb = matrix(NA, nrow=Ttot, ncol=M)
     for ( m in 1:M ) {
       tmp = x[, ix5, drop=FALSE]
       mu.v = mu.l[[m]]
       sigma.m = sigma.l[[m]]
       logbb[,m] = log(c.v[m]) + Dmvnorm(tmp, mean=mu.v, sigma=sigma.m, log=TRUE)
     }
     sum.p = rep(NA, Ttot)
     # since the columns of logbb are the gaussian mixture components, we need to sum them.
     for ( tt in 1:Ttot) {
       sum.p[tt] = Elnsum.vec(logbb[tt,]) # in the non-log version: sum.pr = rowSums(bb)
     }

     if ( model$Log == TRUE ) {
       logb5 = sum.p
     } else {
       logb5 = exp(sum.p)
     }
   } else {
     if ( model$Log ) {
       logb5 = rep(0, Ttot)
     } else {
       logb5 = rep(1, Ttot)
     }
   }

   # 3 = gamma
   ix3 = which(model$mtype == 3)
   if ( length(ix3) >= 1 ) {
     shape.v = model$parms.emission$M3$shape.l[[j]]
     scale.v = model$parms.emission$M3$scale.l[[j]]
     bb = matrix(NA, ncol=length(ix3), nrow=Ttot)
     for ( i in 1:length(ix3) ) {
       tmp = dgamma(x[,ix3[i]], shape=shape.v[i], scale=scale.v[i])
       #iz = which(tmp < 1e-323)
       #tmp[iz] = 1e-323
       #cat("counting small values in dgamma:", length(iz), "\n")
       if ( model$Log ) {
         bb[,i] = log(tmp)
       } else {
         bb[,i] = tmp
       }
     }
     if ( model$Log ) {
       logb3 = apply(bb, 1, sum)
     } else {
       logb3 = apply(bb, 1, prod)
     }
   } else {
     if ( model$Log ) {
       logb3 = rep(0, Ttot)
     } else {
       logb3 = rep(1, Ttot)
     }
   }

   # 4 = beta
   ix4 = which(model$mtype == 4)
   if ( length(ix4) >= 1 ) {
     shape1.v = model$parms.emission$M4$shape1.l[[j]]
     shape2.v = model$parms.emission$M4$shape2.l[[j]]
     bb = matrix(NA, ncol=length(ix4), nrow=Ttot)
     for ( i in 1:length(ix4) ) {
        tmp = dbeta(x[,ix4[i]], shape1=shape1.v[i], shape2=shape2.v[i])
        #iz = which(tmp < 1e-323)
        #tmp[iz] = 1e-323
        #cat("counting small values in dgamma:", length(iz), "\n")
        if ( model$Log ) {
          bb[,i] = log(tmp)
        } else {
          bb[,i] = tmp
        }
     }
     if ( model$Log ) {
       logb4 = apply(bb, 1, sum)
     } else {
       logb4 = apply(bb, 1, prod)
     }
   } else {
     if ( model$Log ) {
       logb4 = rep(0, Ttot)
     } else {
       logb4 = rep(1, Ttot)
     }
   }
   if ( model$Log ) {
     b = logb1 + logb2 + logb3 + logb4 + logb5
     # NOTE : b may have -Inf, which can't be passed into C, so need to make them very small
     b[which(b < NegInf)] = NegInf
   } else {
     b = logb1 * logb2 * logb3 * logb4 * logb5
   }
   return(b)
}

#' Multivariable normal distribution at a point, calculate probability for a small interval around a point
#'
#' @param x numeric matrix
#' @param mean mean vector of the multivariate normal
#' @param sigma covariance matrix
#' @param eps small numeric neighborhood around x
#' @return vector of proabilities, length equal the number of rows in x
#' @details used in generic.density
#' @export
pmvnorm.intv = function (x, mean, sigma, eps=0.1) {
  require(mvtnorm)
  ll = x - eps/2
  uu = x + eps/2
  pp = double(NROW(x))
  for ( i in 1:NROW(x)) {
    pp[i] = pmvnorm(lower=ll[i,], upper=uu[i,], mean=mean, sigma=sigma)
  }
  return(pp)
}

#' Multivariable normal density for a hidden state evaluated at x
#'
#' @param x numeric matrix
#' @param model HMM model
#' @param j hidden state index
#' @param Log boolean whether log is used, default to FALSE
#' @return vector of proabilities, length equal the number of rows in x
#' @details used in generic.density
#' @export
dmvnorm.hext = function (x, j, model, Log=FALSE) {
  mu.v = model$parms.emission$M2$mu.l[[j]]
  sigma.m = model$parms.emission$M2$sigma.l[[j]]
  ans = Dmvnorm(x, mean=mu.v, sigma=sigma.m, log=Log)
  #ans[is.na(ans)] <- 1   # not sure what this is for?
  return(ans)
}

#' Multivariable normal density, similar to the similar named function in mvtnorm
#'
#' @param x numeric matrix
#' @param mean mean vector
#' @param sigma covariance matrix
#' @param log boolean whether log is used, default to FALSE
#' @param num.cutoff numeric cutoff value
#' @return vector of proabilities, length equal the number of rows in x
#' @details use ginv from MASS to compute inverse matrix
#' @export
Dmvnorm = function (x, mean, sigma, log=TRUE, num.cutoff=1e-100)  {
    require(MASS)  # MASS is needed because of ginv
    if (is.vector(x)) {
        x <- matrix(x, ncol = length(x))
    }
    #if (missing(mean)) {
    #    mean <- rep(0, length = NCOL(x))
    #}
    #if (missing(sigma)) {
    #    sigma <- diag(NCOL(x))
    #}
    #if (NCOL(x) != NCOL(sigma)) {
    #    stop("x and sigma have non-conforming size")
    #}
    #if (!isSymmetric(sigma, tol = sqrt(.Machine$double.eps))) {
    #   assign("SIGMA", sigma, envir = .GlobalEnv)
    #   stop("sigma must be a symmetric matrix")
    #}
    #if (length(mean) != NROW(sigma)) {
    #    stop("mean and sigma have non-conforming size")
    #}
    # Use this function from MASS, instead of the default solve()
    inv.sigma = ginv(sigma)

    distval = mahalanobis(x, center=mean, cov=inv.sigma, inverted=TRUE)
    ev = eigen(sigma, symmetric = TRUE, only.values = TRUE)$values
    logdet = sum(log(ev))

    logretval = -(NCOL(x) * log(2 * pi) + logdet + distval)/2
    ix = which(logretval > 0) # because exp(logretval) would be > 1
    #if ( length(ix) > 0 ) {
    #  cat("NCOL(x):", NCOL(x), " ")
    #  cat("logdet:", logdet, " ")
    #  cat("distval[ix]:", distval[ix], "\n")
    #}

    if (log == TRUE) {
      return(logretval)
    } else {
      # put a floor on the probability value
      tmp = exp(logretval)
      ix = which( tmp < num.cutoff )
      if ( length(ix) > 0 ) {
        tmp[ix] = num.cutoff
      }
      return(tmp)
    }
}

#' Beta emission density for hidden state j in an HMM
#'
#' @param x numeric vector
#' @param j hidden state index
#' @param model HMM model
#' @return vector of proabilities, length equal the number of rows in x
#' @export
dbeta.hext = function(x, j, model) {
    b = dbeta(x, shape1=model$parms.emission$shape1[j],
                 shape2=model$parms.emission$shape2[j])
    b[is.na(b)] = 1
    return(b)
}

#' Multivariate beta emission density for hidden state j in an HMM
#'
#' @param x numeric matrix of size T x p, where T is number of obs, p the dimension of x
#' @param j hidden state index
#' @param model HMM model
#' @return vector of proabilities, length equal the number of rows in x
#' @export
dmvbeta.hext = function(x, j, model) {
    p = NCOL(x)
    n = NROW(x)
    Shape1 = model$parms.emission$shape1[[j]]
    Shape2 = model$parms.emission$shape2[[j]]
    # shape and scale should be vector of length p
    if ( length(Shape1) != p | length(Shape2) != p )
      stop("shape1 or shape2 are of the wrong length!")
    b = matrix(NA, nrow=n, ncol=p)
    for ( i in 1:p ) {
       b[,i] = dbeta(x[,i], shape1=Shape1[i], shape2=Shape2[i])
    }
    ans = apply(b, 1, prod)
    return(ans)
}

#' Univariate gamma emission density for hidden state j in an HMM
#'
#' @param x numeric vector
#' @param j hidden state index
#' @param model HMM model
#' @return vector of proabilities, length equal the number of rows in x
#' @export
dgamma.hext = function(x, j, model) {
    b = dgamma(x, shape=model$parms.emission$shape[j],
                  scale=model$parms.emission$scale[j])
    b[is.na(b)] = 1
    return(b)
}

#' Multivariate gamma emission density for hidden state j in an HMM
#'
#' @param x numeric matrix of size T x p, where T is number of obs, p the dimension of x
#' @param j hidden state index
#' @param model HMM model
#' @return vector of proabilities, length equal the number of rows in x
#' @export
dmvgamma.hext = function(x, j, model) {
    p = NCOL(x)
    n = NROW(x)
    Shape = model$parms.emission$shape[[j]]
    Scale = model$parms.emission$scale[[j]]
    # shape and scale should be vector of length p
    if ( length(Shape) != p | length(Scale) != p )
      stop("shape or scale are of the wrong length!")
    b = matrix(NA, nrow=n, ncol=p)
    for ( i in 1:p ) {
       b[,i] = dgamma(x[,i], shape=Shape[i], scale=Scale[i])
    }
    ans = apply(b, 1, prod)
    return(ans)
}

#' Weighted covariance matrices, similar to cov.wt in hsmm
#'
#' @param x numeric matrix of size T x p, where T is number of obs, p the dimension of x
#' @param wt vector of weights for each obs
#' @param cor boolean whether correlation matrix to be returned
#' @param center centers to be used when computing covariances
#' @param method either "unbiased" or "ML
#' @return list with components cov, center, n.obs, wt, cor
#' @export
cov.wt.hext = function (x, wt = rep(1/nrow(x), nrow(x)), cor = FALSE, center = TRUE, method = c("unbiased", "ML")) {
    if (is.data.frame(x))
        x <- as.matrix(x)
    else if (!is.matrix(x))
        stop("'x' must be a matrix or a data frame")
    if (!all(is.finite(x)))
        stop("'x' must contain finite values only")
    n <- nrow(x)
    if (with.wt <- !missing(wt)) {
        if (length(wt) != n)
            stop("length of 'wt' must equal the number of rows in 'x'")
        s = sum(wt)
        if (any(wt < 0) || s == 0)
            stop("weights must be non-negative and not all zero")
        wt <- wt/s

    }
    if (is.logical(center)) {
        center <- if (center)
            colSums(wt * x)
        else 0
    }
    else {
        if (length(center) != ncol(x))
            stop("length of 'center' must equal the number of columns in 'x'")
    }
    x <- sqrt(wt) * sweep(x, 2, center, check.margin = FALSE)
    denom = 1 - sum(wt^2)
    if ( denom < 1e-300 ) {
      stop("1 - sum(wt^2) is very close to zero!\n")
    }
    cov <- switch(match.arg(method), unbiased=crossprod(x)/denom, ML = crossprod(x))
    y <- list(cov = cov, center = center, n.obs = n)
    if (with.wt)
        y$wt <- wt
    if (cor) {
        Is <- 1/sqrt(diag(cov))
        R <- cov
        R[] <- Is * cov * rep(Is, each = nrow(cov))
        y$cor <- R
    }
    y
}


#!/usr/bin/env Rscript
library(Rtsne)
library(ggplot2)
library(dbscan)
library(getopt)
library(RColorBrewer)

spec = matrix(c(
	'help','h', 0, "logical","Print short help message",
	'log','L', 0, "logical","Perform logarythmization (not really recommended)",
	'clustering','c', 2, "character","Clustering mode: h - HDBSCAN (default), k- k-means",
	'inputfile','i', 1, "character", "Data file with TNF, coverage and contig length",
	'contignumber','n', 1, "integer","Total number of analyzed contigs <10000>",
	'minimumlength','m',1,"integer","Minimum length of contig <1000>"
), byrow=TRUE, ncol=5)
opt = getopt(spec)

if ( !is.null(opt$help) ) {
	cat(getopt(spec, usage=TRUE))
	q(status=1)
}

if ( is.null(opt$inputfile) ) {
	cat("No input file specified!\n")
	cat(getopt(spec, usage=TRUE))
	q(status=1)
}

# Clustering mode
if ( is.null( opt$clustering    ) ) { opt$clustering    = "h" }
# Max contig number
if ( is.null( opt$contignumber  ) ) { opt$contignumber  = 10000 }
# Minimum contig length
if ( is.null( opt$minimumlength ) ) { opt$minimumlength = 1000  }
# Logarythm
if ( is.null( opt$log           ) ) { opt$log           = FALSE }

rdata <- read.delim(opt$inputfile,header=F)
lastcol = ncol(rdata)
rdata <- rdata[as.matrix(rdata[,lastcol])>=opt$minimumlength,]

n <- min(opt$contignumber, nrow(rdata))

mdata <- as.matrix(rdata[1:n,2:(lastcol-1)])
meanByCol <- apply(mdata,2,mean)
normdata <- sweep(mdata,2,meanByCol,"/")

# Do logarythmization of data
if(opt$log){
	normdata <- apply(normdata + unique(sort(as.vector(normdata)))[2]/4,2,log)
}

cat(paste0("Loaded data for ", n, " sequences.\n"))

nn <- round(n / 100)/10

#Perplexity for tSNE:
perplexities = ceiling(c(20,40,60) * nn**0.3)
#K-means cluster number
clustersvector = ceiling(c(5,10,15) * nn**0.4)

mytsne <- function(i){
	tsne <- Rtsne(normdata, perplexity=i)
	return(tsne$Y)
}

# For testing purposes only
mykmean <- function(tsne,nc,i){
	kx <- kmeans(tsne,centers=nc,nstart=100,iter.max=10000)
	cldata <- data.frame(rdata[1:n,1],tsne,kx$cluster,rdata[1:n,(lastcol-1):lastcol])
	colnames(cldata)=c("Contig ID","X","Y","cluster","Ncoverage","length")
	cat(paste0("Clustering results for ",nc," clusters:\n"))
	cat("Bin#\tbin size, nt.\n")
	for (x in 1:nc){
		cat(paste0(x,"\t",sum(cldata[cldata$cluster==x,6]),"\n"))
	}
	datafile <- paste0("yamb-pp-",i,"-cl-",nc,".csv")
	write.table(cldata,file=datafile,sep="\t",row.names = FALSE, quote=FALSE)
	p <- ggplot(cldata) +
		geom_point(aes(x=X,y=Y,size=length,alpha=Ncoverage,colour=as.factor(cluster))) +
		scale_size(range=c(0.2,10)) +
		geom_label(data = as.data.frame(kx$centers),aes(x=V1,y=V2,label=rownames(kx$centers))) +
		theme_bw()
	return(p)
}

myhdbscan <- function(tsne){
	hx <- hdbscan(tsne,minPts=20)
	nc <- max(hx$cluster)
	cldata <- data.frame(rdata[1:n,1],tsne,hx$cluster,rdata[1:n,(lastcol-1):lastcol])
	colnames(cldata)=c("Seq ID","X","Y","cluster","Ncoverage","length")
	cat(paste0("Clustering results for ",nc," clusters:\n"))
	cat("Bin#\tbin size, nt.\n")
	for (x in 0:nc){
		cat(paste0(x,"\t",sum(cldata[cldata$cluster==x,6]),"\n"))
	}
	datafile <- paste0("yamb-pp-",i,"-hdbscan.csv")
	write.table(cldata,file=datafile,sep="\t",row.names = FALSE, quote=FALSE)
	p <- ggplot(cldata) +
		geom_point(aes(x=X,y=Y,size=length,alpha=Ncoverage,colour=as.factor(cluster))) +
		scale_size(range=c(0.2,10)) + theme_bw() +
		scale_color_manual(values=c("black",colorRampPalette(brewer.pal(12,"Paired"))(nc)))
	return(p)
}

for(i in perplexities){
	tsne <- mytsne(i)
	if(opt$clustering == "k"){
		for(clusters in clustersvector){
			pngfile <- paste0("yamb-",nn,"K-pp-",i,"-cl-",clusters,".png")
			mykmean(tsne,clusters,i)
			ggsave(file=pngfile)
		}
	}else if(opt$clustering == "h"){
		pngfile <- paste0("yamb-pp-",i,"-hdbscan.png")
		myhdbscan(tsne)
		ggsave(file=pngfile)
	}
}

cat("R analysis completed!\n")
q()


# Function to calculate a shade or a tint of a color
# 'Shade or tint'

#' Shade or tint
#'
#' Shade or tint
#'
#' @param x (vector of) color(s) with no alpha
#' @param opt "tint" (lighten) or "shade" (darken)
#' @return altered (vector of) color(s)
#' @export
tint = function(colors=c('red','green','blue'), opt='shade', factor=0.5) {
  if(!(opt %in% c('shade','tint'))){stop("Option must be either 'shade' or 'tint'")}
  cols    <- col2rgb(col=colors, alpha=FALSE)
  if (opt=='shade'){
    outcol = cols*(1-factor) / 255
  }else if(opt=='tint'){
    outcol = (cols+(255-cols)*factor) / 255
  }
  return(rgb(red=outcol[1,],green=outcol[2,],blue=outcol[3,]))
}

#' @rdname tint
#' @export
pkTintShade <- tint