#' Network data formats
#'
#' List of accepted graph formats
#'
#' @name netdiffuseR-graphs
#' @details The \pkg{netdiffuseR} package can handle different types of graph
#' objects. Two general classes are defined across the package's functions:
#' static graphs, and dynamic graphs.
#' \itemize{
#'  \item{In the case of \strong{static graphs}, these are represented as adjacency
#'  matrices of size \eqn{n\times n}{n * n} and can be either \code{\link{matrix}}
#'  (dense matrices) or \code{\link[Matrix:dgCMatrix-class]{dgCMatrix}}
#'  (sparse matrix from the \pkg{\link[Matrix:Matrix]{Matrix}} package). While
#'  most of the package functions are defined for both classes, the default output
#'  graph is sparse, i.e. \code{dgCMatrix}.}
#'  \item{With respect to \strong{dynamic graphs}, these are represented by either
#'  a \code{\link{diffnet}} object, an \code{\link{array}} of size
#'  \eqn{n\times n \times T}{n * n * T}, or a list of size \eqn{T}
#'  with sparse matrices (class \code{dgCMatrix}) of size \eqn{n\times n}{n * n}.
#'  Just like the static graph case, while most of the functions accept both
#'  graph types, the default output is \code{dgCMatrix}.}
#' }
#' @section diffnet objects:
#'  In the case of \code{diffnet}-class objects, the following arguments can be omitted
#'  when calling fuictions suitable for graph objects:
#'  \itemize{
#'    \item{\code{toa}: Time of Adoption vector}
#'    \item{\code{adopt}: Adoption Matrix}
#'    \item{\code{cumadopt}: Cumulative Adoption Matrix}
#'    \item{\code{undirected}: Whether the graph is directed or not}
#'  }
#'
#' @section Objects' names:
#' When possible, \pkg{netdiffuseR} will try to reuse graphs dimensional names,
#' this is, \code{\link{rownames}}, \code{\link{colnames}}, \code{\link{dimnames}}
#' and \code{\link{names}} (in the case of dynamic graphs as lists). Otherwise,
#' when no names are provided, these will be created from scratch.
#' @include imports.r
#' @author George G. Vega Yon
#' @family graph formats
NULL

as_generic_graph <- function(graph) UseMethod("as_generic_graph")

# Method for igraph objects
as_generic_graph.igraph <- function(graph) {

  # If multiple then warn
  if (igraph::any_multiple(graph))
    warning("The -igraph- object has multiple edges. Only one of each will be retrieved.")
  if ("weight" %in% igraph::graph_attr_names(graph)) {
    adjmat <- igraph::as_adj(graph, attr="weight")
  } else {
    adjmat <- igraph::as_adj(graph)
  }

  # Converting to dgCMatrix
  env <- environment()
  ans <- new_generic_graph()
  suppressWarnings(add_to_generic_graph("ans", "graph", list(`1`=adjmat), env))
  meta <- c(classify_graph(adjmat), list(
    self       = any(igraph::is.loop(graph)),
    undirected = FALSE, # For now we will assume it is undirected
    multiple   = FALSE, # And !multiple
    class      = "igraph"
    ))
  add_to_generic_graph("ans", "meta", meta, env)

  return(ans)
}

new_generic_graph <- function() {
  list(graph=NULL, meta=NULL)
}

# This function adds an element checking that the slot exits
add_to_generic_graph <- function(gg,nam,val,env=environment()) {
  obj <- get(gg, envir = env)
  if (!(nam %in% names(obj))) stop(nam," unknown slot.")
  obj[[nam]] <- val
  assign(gg,obj,envir = env)
  invisible(NULL)
}

# Method for network objects
as_generic_graph.network <- function(graph) {
  # If multiple then warn
  if (network::is.multiplex(graph))
    warning("The -network- object has multiple edges. These will be added up.")

  # Converting to an adjacency matrix (dgCMatrix)
  adjmat <- edgelist_to_adjmat(
    network::as.edgelist(graph),
    undirected = !network::is.directed(graph),
    multiple   = network::is.multiplex(graph),
    self       = network::has.loops(graph)
    )

  ord <- network::network.vertex.names(graph)
  ord <-  match(ord, rownames(adjmat))
  adjmat <- adjmat[ord,ord]

  env <- environment()
  ans <- new_generic_graph()
  suppressWarnings(add_to_generic_graph("ans", "graph", list(`1`=adjmat), env))

  meta <- c(classify_graph(adjmat), list(
    self       = network::has.loops(graph),
    undirected = !network::is.directed(graph),
    multiple   = network::is.multiplex(graph),
    class      = "network"
  ))

  add_to_generic_graph("ans", "meta", meta, env)

  return(ans)
}

stopifnot_graph <- function(x)
  stop("No method for graph of class -",class(x),"- for ", deparse(sys.call()) #match.call()
       ,". Please refer to the manual 'netdiffuseR-graphs'.")

#' Analyze an R object to identify the class of graph (if any)
#' @template graph_template
#' @details This function analyzes an R object and tries to classify it among the
#' accepted classes in \pkg{netdiffuseR}. If the object fails to fall in one of
#' the types of graphs the function returns with an error indicating what (and
#' when possible, where) the problem lies.
#'
#' The function was designed to be used with \code{\link{as_diffnet}}.
#' @seealso \code{\link{as_diffnet}}, \code{\link{netdiffuseR-graphs}}
#' @return Whe the object fits any of the accepted graph formats, a list of attributes including
#' \item{type}{Character scalar. Whether is a static or a dynamic graph}
#' \item{class}{Character scalar. The class of the original object}
#' \item{ids}{Character vector. Labels of the vertices}
#' \item{pers}{Integer vector. Labels of the time periods}
#' \item{nper}{Integer scalar. Number of time periods}
#' \item{n}{Integer scalar. Number of vertices in the graph}
#' Otherwise returns with error.
#' @author George G. Vega Yon
#' @export
classify_graph <- function(graph) {

  # Diffnet object
  if (inherits(graph, "diffnet")) {
    return(classify_graph(graph$graph))
  } else if (inherits(graph, "matrix") || inherits(graph, "dgCMatrix")) { # Static graphs
    # Step 0: Should have length
    d <- dim(graph)
    if (!d[1])
      stop("Nothing to do. Empty matrix.")

    # Step 1: Should be square
    if (d[1] != d[2])
      stop("-graph- must be a square matrix\n\tdim(graph) = c(",
           paste0(d, collapse=","),").")

    # Step 3: Should be numeric
    m <- mode(graph)
    if (!inherits(graph, "dgCMatrix") && !(m %in% c("numeric", "integer")))
      stop("-graph- should be either numeric or integer.\n\tmode(graph) =  \"",
           m, "\".")

    # Step 4: Dimension names
    ids <- rownames(graph)
    if (!length(ids)) ids <- 1:d[1]

    return(invisible(list(
      type="static",
      class="matrix",
      ids=ids,
      pers=1,
      nper=1,
      n=d[1]
    )))
  }
  # Dynamic graphs (list) ------------------------------------------------------
  else if (inherits(graph, "list")) {
    # Step 0: Should have length!
    t <- length(graph)
    if (t < 2)
      stop("-graph- must be at least of length 2.")

    # Step 1: All should be of class -dgCMatrix-
    c <- sapply(graph, inherits, "dgCMatrix")
    if (!all(c))
      stop("The following elements are not of class -dgCMatrix-:\n\t",
           paste0(which(!c), collapse=", "),".")

    # Step 2.1: All must be square matrices
    d <- lapply(graph, dim)
    s <- sapply(d, function(x) x[1] == x[2])

    # Step 2.2: It must have some people!
    if (!d[[1]][1])
      stop("Nothing to do. Empty graph.")

    if (!all(s))
      stop("The following adjmat are not square:\n\t",
           paste0(which(!s), collapse=", "),".")

    # Step 3: All must have the same dimension
    e <- unlist(d, TRUE) == d[[1]][1]
    if (!all(e))
      stop("The dimensions of all slices must be equal. ",
           "The following elements don't coincide with the first slice:\n\t",
           paste0(which(!e), collapse=", "),".")

    # Step 4.1: Individual's ids
    ids <- rownames(graph[[1]])
    if (!length(ids)) ids <- 1:d[[1]][1]

    # Step 4.2 Time ids
    suppressWarnings(pers <- as.integer(names(graph)))
    if (!length(pers)) pers <- 1:t
    else {
      # Step 4.2.1: Must be coercible into integer
      if (any(is.na(pers))) stop("names(graph) should be either numeric or integer.")

      # Step 4.2.1: Must keep uniqueness
      if (length(unique(pers)) != t) stop("When coercing names(graph) into integer,",
                                       "some slices acquired the same name.")
    }

    return(invisible(list(
      type="dynamic",
      class="list",
      ids=as.character(ids),
      pers=pers,
      nper=t,
      n=d[[1]][1])
    ))

  }
  # Dynamic graphs (array) -----------------------------------------------------
  else if (inherits(graph, "array")) {
    # Step 0: it should have length!
    d <- dim(graph)
    if (d[3] < 2)
      stop("-graph- must be at least of length 2.")

    # Step 1: there must be some people
    if (!d[1])
      stop("Nothing to do. Empty matrix.")

    # Step 2: It must be square
    if (d[1] != d[2])
      stop("Each adjmat in -graph- must be a square matrix\n\tdim(graph) = c(",
           paste0(d, collapse=","),").")

    # Step 3: Should be numeric
    m <- mode(graph)
    if (!(m %in% c("numeric", "integer")))
      stop("-graph- should be either numeric or integer.\n\tmode(graph) =  \"",
           m, "\".")

    # Step 4: Dimension names
    ids <- rownames(graph)
    if (!length(ids)) ids <- 1:d[1]

    pers <- as.numeric(dimnames(graph)[[3]])
    if (!length(pers)) pers <- 1:d[3]
    else {
      # Step 4.2.1: Must be coercible into integer
      suppressWarnings(alters <- as.integer(floor(pers)))
      if (any(is.na(alters))) stop("names(graph) should be either numeric or integer.")

      # Step 4.2.1: Must keep uniqueness
      if (length(unique(alters)) != length(pers))
        stop("When coercing names(graph) into integer,",
             "some slices acquired the same name.")
      pers <- alters
    }

    return(invisible(list(
      type="dynamic",
      class="array",
      ids=ids,
      pers=pers,
      nper=d[3],
      n=d[1])
    ))
  }

  # Other case (ERROR) ---------------------------------------------------------
  stop("Not an object allowed in netdiffuseR. It must be either:\n\t",
       "matrix, dgCMatrix, list or array.\n", "Please refer to ?\"netdiffuseR-graphs\" ")
}

# Auxiliar function to check if there's any attribute of undirectedness
checkingUndirected <- function(graph, warn=TRUE, default=getOption("diffnet.undirected")) {

  # Ifendifying the class of graph
  if (inherits(graph, "diffnet")) undirected <- graph$meta$undirected
  else undirected <- attr(graph, "undirected")

  if (warn)
    if (length(undirected) && undirected != FALSE)
      warning("The entered -graph- will now be directed.")

  if (!length(undirected)) undirected <- default

  invisible(undirected)

}


# Download and preprocess GLSDEM

# URLs: ftp://ftp.glcf.umd.edu/glcf/GLSDEM/Degree_tiles/n060/GLSDEM_n060e025/GLSDEM_n060e025.tif.gz
library(R.utils)
library(landsat)
source("utils/raster-utils.r")
source("utils/dem-statistics.r")

GLSDir = "../../userdata/dem/glsdem"
TilesN = 55:61
TilesE = 28:29

dems = list()
for(n in TilesN)
{
    for(e in TilesE)
    {
        filename = paste0("GLSDEM_n0", n, "e0", e, ".tif")
        url = paste0("ftp://ftp.glcf.umd.edu/glcf/GLSDEM/Degree_tiles/n0", n,
            "/GLSDEM_n0", n, "e0", e, "/", filename, ".gz")
        outfile = paste0(GLSDir, "/", filename)
        outfilegz = paste0(outfile, ".gz")
        if(!file.exists(outfilegz) && !file.exists(outfile))
            download.file(url, outfilegz, "wget")
        if(file.exists(outfilegz) && file.size(outfilegz) > 0)
            gunzip(paste0(outfile, ".gz"))
        if(file.exists(outfile) && file.size(outfile) > 0)
            dems = list(dems, raster(outfile))
    }
}
dems = unlist(dems)

GLSMosaic = mosaic(dems, fun=mean, filename=paste0(GLSDir, "/mosaic.grd"), overwrite=TRUE, tolerance=0.5)
# USGS doesn't provide rasters for pure sea since it's 0 by definition, so fill it if needed
#DEMMosaic[is.na(DEMMosaic)] = 0
#GLSMosaic = reclassify(GLSMosaic, cbind(NA, 0))
#writeRaster(GLSMosaic, filename=paste0(GLSDir,"/mosaic.tif"), overwrite=TRUE)
PVExample = raster("/data/MTDA/TIFFDERIVED/PROBAV_L3_S5_TOC_100M/20160711/PROBAV_S5_TOC_20160711_100M_V001/PROBAV_S5_TOC_X20Y01_20160711_100M_V001_NDVI.tif")
CalculateDEMStatistics(GLSMosaic, GLSDir, PVExample)

# R3241-R5414
# L2333-K4421-K5442
# K-R 2-5
# Filelist obtained via bash script:
# rsync -arPv rsync://tiedostot.kartat.kapsi.fi/mml/korkeusmalli/hila_10m/etrs-tm35fin-n2000 | grep \.tif | awk '{print $5}' | grep -P "[K-R]" > filelist.txt


#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# DATA WRANGLING ----
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# 1. Merge data from different rounds
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

# This function merges data from different rounds and merge them into
# a single data.frame for a given year.

merge_cartola_data <- function(year){
  year <- as.character(year)
  require(dplyr)
  setwd(paste0("data/", year))
  files <- list.files(pattern = "rodada")

  list_of_data_frames <- lapply(files, function(x){
    read.csv(x, header = TRUE, stringsAsFactors = FALSE)
  })

  df <- do.call(bind_rows, list_of_data_frames)
  return(df)
}

# Let's open 2018's data
cartola <- merge_cartola_data(2018)
setwd("../../")

#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# 2. Wrangle scouts from Cartola API, aggregated format  ----
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

## Carregar pacotes
library(dplyr)
library(tidyr)

# Sort data by id and round
cartola <-
  cartola %>%
  arrange(atletas.atleta_id, - atletas.rodada_id)

df <- cartola

# Create a data.frame to manipulate scouts
df <- df[, c(6,16:31)]

# Convert NA values into zeroes
df[,2:17] <- sapply(df[,2:17], function(x) ifelse(is.na(x), 0, x))

df <- df %>%
      group_by(atletas.atleta_id) %>%
      mutate_all(funs(abs(diff(c(.,0)))))

df$atletas.rodada_id <- cartola$atletas.rodada_id

# Remove aggregated scouts statistics
cartola <- cartola[, -c(16:33)]

# Join with proper scouts
df <- left_join(df, cartola, by = c("atletas.atleta_id", "atletas.rodada_id"))

# Arrange variable columns
df <- df[, c(1, 18, 20:31, 2:17)]

cartola <- df
rm(df)


##################
## cfg			##
##################
source("cfg.r")
graphics.off()

limits_TC = c(1, 10, 20, 30, 40, 50, 60, 70)
cols_TC   = c("white", "#AAAA00", "#003300")

dlimits_TC = c(-40, -20, -10, -5, -2, -1, 1, 2, 5, 10, 20, 40)
dcols_TC   = c("#1A001A", "#330033", "#662366", "#AA78AA", "#eed9ee", "#ffffe5", "#d9f0a3", "#78c679", "#238443", "#004529", "#002211")

limits_BA = c(0.1, 1, 2, 3, 5, 10, 20, 30, 50)
cols_BA   = c('#ffffcc','#fed976','#fd8d3c','#e31a1c','#800026')

dlimits_BA = c(-10, -5, -2, -1, -0.1, -0.01, 0.01, 0.1, 2, 5, 10)
dcols_BA   = rev(c('#a50026','#d73027','#f46d43','#fdae61','#fee090','#ffffbf','#e0f3f8','#abd9e9','#74add1','#4575b4','#313695'))

items = c(2:3, 5:6)
yrs   = c(2002, 2008, 2014)

JULES_dir = "../jules_outputs/"

JULES_control     =  c("u-bk543", "u-bi607_CropFrag")
JULES_experiments =  list(mortExps    = c("u-bk757", "u-bk809", "u-bk716",
                                          "u-bk807", "u-bk811", "u-bk812", "u-bk812"),
                          INFERNOExps = c("u-bi607_CropFrag", "u-bi607_FUEL_RH",
                                          "u-bi607_FUEL", "u-bi607_RH"))

Experiment_names  = list(c("A  MAP", "B  Burnt area", "C  Rainfall distribution",
                           "D  Temperature stress", "G  Cropland", "H  Pasture",
                           "I  All land use"),
                         c("Cropland Fragmentation", "Fuel and RH", "Fuel", "RH"))

lmat = list(rbind(c(0,1), c(2,2), 3:4, 5:6, 0, 7:8,c(9, 0), 10), NULL)
heights = list(c(1, 0.33, 1, 1, 1, 1, 1, 0.33), NULL)
grab_cache = TRUE

######################
## open	            ##
######################

plotExperimentSet <- function(name, Exp_names, lmat = NULL, heights = 1, normalise = FALSE, ...) {
    c(Jules_TC_control, Jules_TC_exp, Jules_BA_control, Jules_BA_exp, Jules_dout, Jules_PFTs) :=
        openJulesExperimentSet(name, yrs = yrs, grab_cache = grab_cache,...)
    if (normalise) {
        mortExpD = layer.apply(Jules_TC_exp, function(i) (i - Jules_TC_control)/  max(addLayer(i, Jules_TC_control)))
    } else {
        mortExpD =  (Jules_TC_exp - Jules_TC_control)
    }

    mortExpD = lapply(layer.apply(mortExpD, function(i) c(i)), function(i) i[[1]])

    fname = paste0('figs/JULES_mort_maps', '-', name)

    if (length(mortExpD) == 1){ nrow = 1; ncol = 1
    } else { ncol = 2; nrow = ceiling(length(mortExpD)/2)}

    if (is.null(lmat)) {
        lmat = matrix(c(1:length(mortExpD), 0)[1:(ncol * nrow)], ncol = ncol, nrow =nrow)
        lmat = rbind(c(1, 0), c(2, 0), lmat + 2, max(lmat) + 3)
        heights = c(1, 0.5, rep(1, nrow), 0.5)
    }
    height = (4.75/6.5) * 5 * ((nrow(lmat)-3.5) + 1.6)/4.6

    plotMe <- function(fnamei, control, experiment, limits, cols, dlimits, dcols) {
        fname = paste0(fname, '-', fnamei, '.png')
        png(fname, height = height, width = 4.75 * ncol/2, units = 'in', res = 300)
            layout(lmat, heights = heights)
            par(mar = c(0, 0, 0, 0), oma = c(0, 1, 1.5, 1))

            plotStandardMap(control, limits =  limits/100, cols =  cols,
                            'Control', mtext_line = -.8)
            par(mar = c(0.3, 0, 0,0))
            add_raster_legend2(cols = cols, limits = limits,transpose = FALSE, srt = 0,
                               plot_loc = c(0.15, 0.85, 0.7, 0.9), add = FALSE,
                               labelss = c(0, limits, 100), units = '%')
            par(mar = rep(0, 4))
            mapply(plotStandardMap, experiment, Exp_names,
                   MoreArgs = list(limits =  dlimits/100, cols =  dcols, mtext_line = -0.8))
             par(mar = c(0.3, 0, 0,0))
            add_raster_legend2(cols = dcols, limits = dlimits, extend_min = TRUE, extend_max = TRUE,
                               transpose = FALSE, srt = 0, units= '%',
                                plot_loc = c(0.02, 0.98, 0.7, 0.9), add = FALSE)
        dev.off()

    }

    plotMe('TC', Jules_TC_control, mortExpD, limits = limits_TC, cols = cols_TC, dlimits = dlimits_TC, dcols = dcols_TC)
    Jules_BA_exp[[2]][] = 0.0
    mortExpD = layers2list(Jules_BA_exp - Jules_BA_control)
    plotMe('BA', Jules_BA_control,  mortExpD,
           limits = limits_BA, cols = cols_BA, dlimits = dlimits_BA, dcols = dcols_BA)
    browser()
}

mapply(plotExperimentSet, paste0(names(JULES_experiments), '-normalise'),
       Experiment_names, JULES_control, JULES_experiments, lmat = lmat, heights = heights,
       MoreArgs = list(normalise = TRUE))

mapply(plotExperimentSet, names(JULES_experiments), Experiment_names, JULES_control, JULES_experiments, lmat = lmat, heights = heights,
       MoreArgs = list(normalise = FALSE))


context("dalda")

test_that("dalda: misspecified arguments", {
	data(iris)
	# wrong variable names
	expect_error(dalda(formula = Species ~ V1, data = iris, wf = "gaussian", bw = 10))
	# wrong class
	expect_error(dalda(formula = iris, data = iris, wf = "gaussian", bw = 10))
	#expect_error(dalda(iris, data = iris, wf = "gaussian", bw = 10))
	# target variable also in x
	expect_error(dalda(grouping = iris$Species, x = iris, wf = "gaussian", bw = 10))      					## system singular
	expect_warning(dalda(Species ~ Species + Petal.Width, data = iris, wf = "gaussian", bw = 10))           ## warning, Species on RHS removed
	# missing x
	expect_error(dalda(grouping = iris$Species, wf = "gaussian", bw = 10))
	## itr
	expect_that(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, itr = -5), throws_error("'itr' must be >= 1"))
	expect_that(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, itr = 0), throws_error("'itr' must be >= 1"))
	## wrong method argument
	# missing quotes
	expect_error(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, method = ML))
	# method as vector
	expect_error(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, method = c("ML","unbiased")))
	# expect_that(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, method = c("ML","unbiased")), throws_error("'arg' must be of length 1"))
})

test_that("dalda throws a warning if grouping variable is numeric", {
	data(iris)
	# formula, data
	expect_that(dalda(formula = Sepal.Length ~ ., data = iris, wf = "gaussian", bw = 10), gives_warning("'grouping' was coerced to a factor"))
	expect_error(dalda(formula = Petal.Width ~ ., data = iris, wf = "gaussian", bw = 10))	## system singular
	# grouping, x
	expect_that(dalda(grouping = iris[,1], x = iris[,-1], wf = "gaussian", bw = 10), gives_warning("'grouping' was coerced to a factor"))
	expect_error(dalda(grouping = iris[,4], x = iris[,-1], wf = "gaussian", bw = 10))     	## system singular
})

test_that("dalda works if only one predictor variable is given", {
	data(iris)
	fit <- dalda(Species ~ Petal.Width, data = iris, wf = "gaussian", bw = 5)
	expect_equal(ncol(fit$means), 1)
	expect_equal(dim(fit$cov), rep(1, 2))
})

test_that("dalda: training data from only one class", {
	data(iris)
	expect_that(dalda(Species ~ ., data = iris, bw = 2, subset = 1:50), throws_error("training data from only one group given"))
	expect_that(dalda(grouping = iris$Species, x = iris[,-5], bw = 2, subset = 1:50), throws_error("training data from only one group given"))
})

test_that("dalda: one training observation", {
	data(iris)
	# one training observation
	expect_that(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = 1), throws_error("training data from only one group given"))
	# one training observation in one predictor variable
	expect_that(dalda(Species ~ Petal.Width, data = iris, wf = "gaussian", bw = 1, subset = 1), throws_error("training data from only one group given"))
})

test_that("dalda: initial weighting works correctly", {
	data(iris)
	## check if weighted solution with initial weights = 1 equals unweighted solution
	fit1 <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2)
	fit2 <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2, weights = rep(1,150))
	expect_equal(fit1[-9],fit2[-9])
	## returned weights
	a <- rep(1,150)
	names(a) <- 1:150
	expect_equal(fit1$weights[[1]], a)
	expect_equal(fit1$weights, fit2$weights)
	## weights and subsetting
	# formula, data
	expect_that(fit <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2, subset = 11:60), gives_warning("group virginica is empty"))
	a <- rep(1,50)
	names(a) <- 11:60
	expect_equal(fit$weights[[1]], a)
	# formula, data, weights
	a <- rep(1:3,50)[11:60]
	a <- a/sum(a) * length(a)
	names(a) <- 11:60
	expect_that(fit <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2, weights = rep(1:3, 50), subset = 11:60), gives_warning("group virginica is empty"))
	expect_equal(fit$weights[[1]], a)
	# x, grouping
	a <- rep(1,50)
	names(a) <- 11:60
	expect_that(fit <- dalda(x = iris[,-5], grouping = iris$Species, wf = "gaussian", bw = 2, subset = 11:60), gives_warning("group virginica is empty"))
	expect_equal(fit$weights[[1]], a)
	# x, grouping, weights
	a <- rep(1:3,50)[11:60]
	a <- a/sum(a) * length(a)
	names(a) <- 11:60
	expect_that(fit <- dalda(x = iris[,-5], grouping = iris$Species, wf = "gaussian", bw = 2, weights = rep(1:3, 50), subset = 11:60), gives_warning("group virginica is empty"))
	expect_equal(fit$weights[[1]], a)
	## wrong specification of weights argument
	# weights in a matrix
	weight <- matrix(seq(1:150), nrow = 50)
	expect_error(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2, weights = weight))
	# weights < 0
	expect_error(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2, weights = rep(-5, 150)))
	# weights true/false
	expect_error(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2, weights = TRUE))
})

test_that("dalda breaks out of for-loop if only one class is left", {
	expect_that(fit <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, k = 50), gives_warning("for at least one class all weights are zero"))
	expect_equal(fit$itr, 3)
	expect_equal(length(fit$weights), 4)
	set.seed(123)
	expect_that(fit <- dalda(Species ~ ., data = iris, wf = "biweight", bw = 0.9, subset = 51:150), gives_warning("training data from only one group, breaking out of iterative procedure"))
	expect_equal(fit$itr, 2)
	expect_equal(length(fit$weights), 3)
})
#sapply(fit$weights, function(x) return(list(sum(x[1:50]), sum(x[51:100]), sum(x[101:150]))))

test_that("dalda: subsetting works", {
	data(iris)
	# formula, data
	expect_that(fit1 <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2, subset = 1:80), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(Species ~ ., data = iris[1:80,], wf = "gaussian", bw = 2), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9],fit2[-9])
	a <- rep(1,80)
	names(a) <- 1:80
	expect_equal(fit1$weights[[1]], a)
	# formula, data, weights
	expect_that(fit1 <- dalda(Species ~ ., data = iris, weights = rep(1:3, each = 50), wf = "gaussian", bw = 2, subset = 1:80), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(Species ~ ., data = iris[1:80,], weights = rep(1:3, each = 50)[1:80], wf = "gaussian", bw = 2), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9],fit2[-9])
	a <- rep(80, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	b <- rep(1:3, each = 50)[1:80]
	b <- b/sum(b) * length(b)
	names(b) <- 1:80
	expect_equal(fit1$weights[[1]], b)
	# x, grouping
	expect_that(fit1 <- dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 2, subset = 1:80), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(grouping = iris$Species[1:80], x = iris[1:80,-5], wf = "gaussian", bw = 2), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9],fit2[-9])
	a <- rep(1,80)
	names(a) <- 1:80
	expect_equal(fit1$weights[[1]], a)
	# x, grouping, weights
	expect_that(fit1 <- dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 2, weights = rep(1:3, each = 50), subset = 1:80), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(grouping = iris$Species[1:80], x = iris[1:80,-5], wf = "gaussian", bw = 2, weights = rep(1:3, each = 50)[1:80]), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9],fit2[-9])
	a <- rep(80, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	b <- rep(1:3, each = 50)[1:80]
	b <- b/sum(b) * length(b)
	names(b) <- 1:80
	expect_equal(fit1$weights[[1]], b)
	# wrong specification of subset argument
	expect_error(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = iris[1:10,]))
	expect_error(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = FALSE))
	expect_error(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = 0))
	expect_error(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = -10:50))
})

test_that("dalda: NA handling works correctly", {
	### NA in x
	data(iris)
	irisna <- iris
	irisna[1:10, c(1,3)] <- NA
	## formula, data
	# na.fail
	expect_that(dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 6:60, na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 6:60, na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 11:60), gives_warning("group virginica is empty"))
	expect_equal(fit1[-c(9, 18)], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	## formula, data, weights
	# na.fail
	expect_that(dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 6:60, weights = rep(1:3, 50), na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 6:60, weights = rep(1:3, 50), na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 11:60, weights = rep(1:3, 50)), gives_warning("group virginica is empty"))
	expect_equal(fit1[-c(9, 18)], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)

	## x, grouping
	# na.fail
	expect_that(dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 6:60, na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 6:60, na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 11:60), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	## x, grouping, weights
	# na.fail
	expect_that(dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 6:60, weights = rep(1:3, 50), na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 6:60, weights = rep(1:3, 50), na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 11:60, weights = rep(1:3, 50)), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)

	### NA in grouping
	irisna <- iris
	irisna$Species[1:10] <- NA
	## formula, data
	# na.fail
	expect_that(dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 6:60, na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 6:60, na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 11:60), gives_warning("group virginica is empty"))
	expect_equal(fit1[-c(9, 18)], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	## formula, data, weights
	# na.fail
	expect_that(dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 6:60, weights = rep(1:3, 50), na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 6:60, weights = rep(1:3, 50), na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(Species ~ ., data = irisna, wf = "gaussian", bw = 10, subset = 11:60, weights = rep(1:3, 50)), gives_warning("group virginica is empty"))
	expect_equal(fit1[-c(9, 18)], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	## x, grouping
	# na.fail
	expect_that(dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 6:60, na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 6:60, na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 11:60), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	## x, grouping, weights
	# na.fail
	expect_that(dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 6:60, weights = rep(1:3, 50), na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 6:60, weights = rep(1:3, 50), na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(grouping = irisna$Species, x = irisna[,-5], wf = "gaussian", bw = 10, subset = 11:60, weights = rep(1:3, 50)), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)

	### NA in weights
	weights <- rep(1:3,50)
	weights[1:10] <- NA
	## formula, data, weights
	# na.fail
	expect_that(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = 6:60, weights = weights, na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = 6:60, weights = weights, na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = 11:60, weights = weights), gives_warning("group virginica is empty"))
	expect_equal(fit1[-c(9, 18)], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	## x, grouping, weights
	# na.fail
	expect_that(dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 10, subset = 6:60, weights = weights, na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 10, subset = 6:60, weights = weights, na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 10, subset = 11:60, weights = weights), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)

	### NA in subset
	subset <- 6:60
	subset[1:5] <- NA
	## formula, data
	# na.fail
	expect_that(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = subset, na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = subset, na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = 11:60), gives_warning("group virginica is empty"))
	expect_equal(fit1[-c(9, 18)], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	## formula, data, weights
	# na.fail
	expect_that(dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = subset, weights = rep(1:3, 50), na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = subset, weights = rep(1:3, 50), na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = 11:60, weights = rep(1:3, 50)), gives_warning("group virginica is empty"))
	expect_equal(fit1[-c(9, 18)], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	## x, grouping
	# na.fail
	expect_that(dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 10, subset = subset, na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 10, subset = subset, na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 10, subset = 11:60), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
	## x, grouping, weights
	# na.fail
	expect_that(dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 10, subset = subset, weights = rep(1:3, 50), na.action = na.fail), throws_error("missing values in object"))
	# check if na.omit works correctly
	expect_that(fit1 <- dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 10, subset = subset, weights = rep(1:3, 50), na.action = na.omit), gives_warning("group virginica is empty"))
	expect_that(fit2 <- dalda(grouping = iris$Species, x = iris[,-5], wf = "gaussian", bw = 10, subset = 11:60, weights = rep(1:3, 50)), gives_warning("group virginica is empty"))
	expect_equal(fit1[-9], fit2[-9])
	a <- rep(50, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, length), a)
})

test_that("dalda: try all weight functions", {
	fit1 <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = 0.5)
	fit2 <- dalda(formula = Species ~ ., data = iris, wf = gaussian(0.5))
	fit3 <- dalda(x = iris[,-5], grouping = iris$Species, wf = "gaussian", bw = 0.5)
	fit4 <- dalda(x = iris[,-5], grouping = iris$Species, wf = gaussian(0.5))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit3[-9], fit4[-9])
	expect_equal(fit2[c(1:8,10:15)], fit4[c(1:8,10:15)])

	expect_that(fit1 <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = 0.5, k = 30), gives_warning("for at least one class all weights are zero"))
	expect_that(fit2 <- dalda(formula = Species ~ ., data = iris, wf = gaussian(bw = 0.5, k = 30)), gives_warning("for at least one class all weights are zero"))
	expect_that(fit3 <- dalda(x = iris[,-5], grouping = iris$Species, wf = "gaussian", bw = 0.5, k = 30), gives_warning("for at least one class all weights are zero"))
	expect_that(fit4 <- dalda(x = iris[,-5], grouping = iris$Species, wf = gaussian(0.5, 30)), gives_warning("for at least one class all weights are zero"))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit3[-9], fit4[-9])
	expect_equal(fit2[c(1:8,10:15)], fit4[c(1:8,10:15)])
	a <- rep(30, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	fit1 <- dalda(formula = Species ~ ., data = iris, wf = "epanechnikov", bw = 5)
	fit2 <- dalda(formula = Species ~ ., data = iris, wf = epanechnikov(bw = 5))
	fit3 <- dalda(x = iris[,-5], grouping = iris$Species, wf = "epanechnikov", bw = 5)
	fit4 <- dalda(x = iris[,-5], grouping = iris$Species, wf = epanechnikov(5))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit3[-9], fit4[-9])
	expect_equal(fit2[c(1:8,10:15)], fit4[c(1:8,10:15)])
	a <- rep(150, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	expect_that(fit1 <- dalda(formula = Species ~ ., data = iris, wf = "rectangular", bw = 5, k = 30), gives_warning("for at least one class all weights are zero"))
	expect_that(fit2 <- dalda(formula = Species ~ ., data = iris, wf = rectangular(bw = 5, k = 30)), gives_warning("for at least one class all weights are zero"))
	expect_that(fit3 <- dalda(x = iris[,-5], grouping = iris$Species, wf = "rectangular", bw = 5, k = 30), gives_warning("for at least one class all weights are zero"))
	expect_that(fit4 <- dalda(x = iris[,-5], grouping = iris$Species, wf = rectangular(5, 30)), gives_warning("for at least one class all weights are zero"))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit3[-9], fit4[-9])
	expect_equal(fit2[c(1:8,10:15)], fit4[c(1:8,10:15)])
	a <- rep(30, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	fit1 <- dalda(formula = Species ~ ., data = iris, wf = "triangular", bw = 5)
	fit2 <- dalda(formula = Species ~ ., data = iris, wf = triangular(5))
	fit3 <- dalda(x = iris[,-5], grouping = iris$Species, wf = "triangular", bw = 5)
	fit4 <- dalda(x = iris[,-5], grouping = iris$Species, wf = triangular(5))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit3[-9], fit4[-9])
	expect_equal(fit2[c(1:8,10:15)], fit4[c(1:8,10:15)])
	a <- rep(150, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	expect_that(fit1 <- dalda(formula = Species ~ ., data = iris, wf = "biweight", bw = 5, k = 30), gives_warning("for at least one class all weights are zero"))
	expect_that(fit2 <- dalda(formula = Species ~ ., data = iris, wf = biweight(5, k = 30)), gives_warning("for at least one class all weights are zero"))
	expect_that(fit3 <- dalda(x = iris[,-5], grouping = iris$Species, wf = "biweight", bw = 5, k = 30), gives_warning("for at least one class all weights are zero"))
	expect_that(fit4 <- dalda(x = iris[,-5], grouping = iris$Species, wf = biweight(5, 30)), gives_warning("for at least one class all weights are zero"))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit3[-9], fit4[-9])
	expect_equal(fit2[c(1:8,10:15)], fit4[c(1:8,10:15)])
	a <- rep(30, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	fit1 <- dalda(formula = Species ~ ., data = iris, wf = "optcosine", bw = 5)
	fit2 <- dalda(formula = Species ~ ., data = iris, wf = optcosine(5))
	fit3 <- dalda(x = iris[,-5], grouping = iris$Species, wf = "optcosine", bw = 5)
	fit4 <- dalda(x = iris[,-5], grouping = iris$Species, wf = optcosine(5))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit3[-9], fit4[-9])
	expect_equal(fit2[c(1:8,10:15)], fit4[c(1:8,10:15)])
	a <- rep(150, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	expect_that(fit1 <- dalda(formula = Species ~ ., data = iris, wf = "cosine", bw = 5, k = 30), gives_warning("for at least one class all weights are zero"))
	expect_that(fit2 <- dalda(formula = Species ~ ., data = iris, wf = cosine(5, k = 30)), gives_warning("for at least one class all weights are zero"))
	expect_that(fit3 <- dalda(x = iris[,-5], grouping = iris$Species, wf = "cosine", bw = 5, k = 30), gives_warning("for at least one class all weights are zero"))
	expect_that(fit4 <- dalda(x = iris[,-5], grouping = iris$Species, wf = cosine(5, 30)), gives_warning("for at least one class all weights are zero"))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit3[-9], fit4[-9])
	expect_equal(fit2[c(1:8,10:15)], fit4[c(1:8,10:15)])
	a <- rep(30, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)
})

test_that("dalda: local solution with rectangular window function and large bw and global solution coincide", {
	fit1 <- wlda(formula = Species ~ ., data = iris)
	fit2 <- dalda(formula = Species ~ ., data = iris, wf = rectangular(20))
	expect_equal(fit1[-c(7,9)], fit2[-c(7,9:15)])
	expect_equal(fit1$weights, fit2$weights[[1]])
})

test_that("dalda: arguments related to weighting misspecified", {
	# bw, k not required
	expect_that(fit1 <- dalda(Species ~ ., data = iris, wf = gaussian(0.5), k = 30, bw = 0.5), gives_warning(c("argument 'k' is ignored", "argument 'bw' is ignored")))
	fit2 <- dalda(Species ~ ., data = iris, wf = gaussian(0.5))
	expect_equal(fit1[-9], fit2[-9])

	expect_that(fit1 <- dalda(Species ~ ., data = iris, wf = gaussian(0.5), bw = 0.5), gives_warning("argument 'bw' is ignored"))
	fit2 <- dalda(Species ~ ., data = iris, wf = gaussian(0.5))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$k, NULL)
	expect_equal(fit1$nn.only, NULL)
	expect_equal(fit1$bw, 0.5)
	expect_equal(fit1$adaptive, FALSE)

	expect_that(fit1 <- dalda(Species ~ ., data = iris, wf = function(x) exp(-x), bw = 0.5, k = 30), gives_warning(c("argument 'k' is ignored", "argument 'bw' is ignored")))
	expect_that(fit2 <- dalda(Species ~ ., data = iris, wf = function(x) exp(-x), k = 30), gives_warning("argument 'k' is ignored"))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$k, NULL)
	expect_equal(fit1$nn.only, NULL)
	expect_equal(fit1$bw, NULL)
	expect_equal(fit1$adaptive, NULL)

	expect_that(fit1 <- dalda(Species ~ ., data = iris, wf = function(x) exp(-x), bw = 0.5), gives_warning("argument 'bw' is ignored"))
	fit2 <- dalda(Species ~ ., data = iris, wf = function(x) exp(-x))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$k, NULL)
	expect_equal(fit1$nn.only, NULL)
	expect_equal(fit1$bw, NULL)
	expect_equal(fit1$adaptive, NULL)

	# missing quotes
	expect_error(dalda(formula = Species ~ ., data = iris, wf = gaussian)) ## error because length(weights) and nrow(x) are different

	# bw, k missing
	expect_that(dalda(formula = Species ~ ., data = iris, wf = gaussian()), throws_error("either 'bw' or 'k' have to be specified"))
	expect_that(dalda(formula = Species ~ ., data = iris, wf = gaussian(), k = 10), throws_error("either 'bw' or 'k' have to be specified"))
	expect_that(dalda(Species ~ ., data = iris), throws_error("either 'bw' or 'k' have to be specified"))

	# bw < 0
	expect_that(dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = -5), throws_error("'bw' must be positive"))
	expect_that(dalda(formula = Species ~ ., data = iris, wf = "cosine", k = 10, bw = -50), throws_error("'bw' must be positive"))

	# bw vector
	expect_that(dalda(formula = Species ~., data = iris, wf = "gaussian", bw = rep(1, nrow(iris))), gives_warning("only first element of 'bw' used"))

	# k < 0
	expect_that(dalda(formula = Species ~ ., data = iris, wf = "gaussian", k =-7, bw = 50), throws_error("'k' must be positive"))

	# k too small
	#expect_error(dalda(formula = Species ~ ., data = iris, wf = "gaussian", k = 5, bw = 0.005))

	# k too large
	expect_that(dalda(formula = Species ~ ., data = iris, k = 250, wf = "gaussian", bw = 50), throws_error("'k' is larger than 'n'"))

	# k vector
	expect_that(dalda(formula = Species ~., data = iris, wf = "gaussian", k = rep(50, nrow(iris))), gives_warning("only first element of 'k' used"))
})

test_that("dalda: weighting schemes work", {
	## wf with finite support
	# fixed bw
	fit1 <- dalda(formula = Species ~ ., data = iris, wf = "rectangular", bw = 5)
	fit2 <- dalda(formula = Species ~ ., data = iris, wf = rectangular(bw = 5))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$bw, 5)
	expect_equal(fit1$k, NULL)
	expect_equal(fit1$nn.only, NULL)
	expect_true(!fit1$adaptive)

	# adaptive bw, only knn
	expect_that(fit1 <- dalda(formula = Species ~ ., data = iris, wf = "rectangular", k = 50), gives_warning("for at least one class all weights are zero"))
	expect_that(fit2 <- dalda(formula = Species ~ ., data = iris, wf = rectangular(k = 50)), gives_warning("for at least one class all weights are zero"))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$bw, NULL)
	expect_equal(fit1$k, 50)
	expect_equal(fit1$bw, NULL)
	expect_true(fit1$nn.only)
	expect_true(fit1$adaptive)
	a <- rep(50, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	# fixed bw, only knn
	fit1 <- dalda(formula = Species ~ ., data = iris, wf = "rectangular", bw = 5, k = 50)
	fit2 <- dalda(formula = Species ~ ., data = iris, wf = rectangular(bw = 5, k = 50))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$bw, 5)
	expect_equal(fit1$k, 50)
	expect_true(fit1$nn.only)
	expect_true(!fit1$adaptive)
	a <- rep(50, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	# nn.only not needed
	expect_that(dalda(formula = Species ~ ., data = iris, wf = "rectangular", bw = 5, nn.only = TRUE), gives_warning("argument 'nn.only' is ignored"))

	# nn.only has to be TRUE if bw and k are both given
	expect_that(dalda(formula = Species ~ ., data = iris, wf = "rectangular", bw = 5, k = 50, nn.only = FALSE), throws_error("if 'bw' and 'k' are given argument 'nn.only' must be TRUE"))

	## wf with infinite support
	# fixed bw
	fit1 <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = 0.5)
	fit2 <- dalda(formula = Species ~ ., data = iris, wf = gaussian(bw = 0.5))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$bw, 0.5)
	expect_equal(fit1$k, NULL)
	expect_equal(fit1$nn.only, NULL)
	expect_true(!fit1$adaptive)
	a <- rep(150, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, function(x) sum(x > 0)), a)

	# adaptive bw, only knn
	expect_that(fit1 <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", k = 50), gives_warning("for at least one class all weights are zero"))
	expect_that(fit2 <- dalda(formula = Species ~ ., data = iris, wf = gaussian(k = 50)), gives_warning("for at least one class all weights are zero"))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$bw, NULL)
	expect_equal(fit1$k, 50)
	expect_equal(fit1$nn.only, TRUE)
	expect_true(fit1$adaptive)
	a <- rep(50, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	# adaptive bw, all obs
	fit1 <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", k = 50, nn.only = FALSE)
	fit2 <- dalda(formula = Species ~ ., data = iris, wf = gaussian(k = 50, nn.only = FALSE))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$bw, NULL)
	expect_equal(fit1$k, 50)
	expect_equal(fit1$nn.only, FALSE)
	expect_true(fit1$adaptive)
	a <- rep(150, 4)
	names(a) <- 0:3
	expect_equal(sapply(fit1$weights, function(x) sum(x > 0)), a)

	# fixed bw, only knn
	expect_that(fit1 <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = 1, k = 50), gives_warning("for at least one class all weights are zero"))
	expect_that(fit2 <- dalda(formula = Species ~ ., data = iris, wf = gaussian(bw = 1, k = 50)), gives_warning("for at least one class all weights are zero"))
	expect_equal(fit1[-9], fit2[-9])
	expect_equal(fit1$bw, 1)
	expect_equal(fit1$k, 50)
	expect_equal(fit1$nn.only, TRUE)
	expect_true(!fit1$adaptive)
	a <- rep(50, 3)
	names(a) <- 1:3
	expect_equal(sapply(fit1$weights[2:4], function(x) sum(x > 0)), a)

	# nn.only has to be TRUE if bw and k are both given
	expect_that(dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = 1, k = 50, nn.only = FALSE), throws_error("if 'bw' and 'k' are given argument 'nn.only' must be TRUE"))
})

#=================================================================================================================
context("predict.dalda")

test_that("predict.dalda works correctly with formula and data.frame interface and with missing newdata", {
	data(iris)
	ran <- sample(1:150,100)
	## formula, data
	fit <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = 2, subset = ran)
  	pred <- predict(fit)
  	expect_equal(rownames(pred$posterior), rownames(iris)[ran])
  	expect_equal(names(pred$class), rownames(iris)[ran])
	## formula, data, newdata
	fit <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = 2, subset = ran)
  	pred <- predict(fit, newdata = iris[-ran,])
  	expect_equal(rownames(pred$posterior), rownames(iris)[-ran])
  	expect_equal(names(pred$class), rownames(iris)[-ran])
	## grouping, x
	fit <- dalda(x = iris[,-5], grouping = iris$Species, wf = "gaussian", bw = 2, subset = ran)
  	pred <- predict(fit)
  	expect_equal(rownames(pred$posterior), rownames(iris)[ran])
  	expect_equal(names(pred$class), rownames(iris)[ran])
	## grouping, x, newdata
	fit <- dalda(x = iris[,-5], grouping = iris$Species, wf = "gaussian", bw = 2, subset = ran)
  	pred <- predict(fit, newdata = iris[-ran,-5])
  	expect_equal(rownames(pred$posterior), rownames(iris)[-ran])
  	expect_equal(names(pred$class), rownames(iris)[-ran])
})

test_that("predict.dalda: retrieving training data works", {
	data(iris)
	## no subset
	# formula, data
	fit <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = 2)
  	pred1 <- predict(fit)
  	pred2 <- predict(fit, newdata = iris)
  	expect_equal(pred1, pred2)
	# y, x
	fit <- dalda(x = iris[,-5], grouping = iris$Species, wf = "gaussian", bw = 2)
  	pred1 <- predict(fit)
  	pred2 <- predict(fit, newdata = iris[,-5])
  	expect_equal(pred1, pred2)
	## subset
	ran <- sample(1:150,100)
	# formula, data
	fit <- dalda(formula = Species ~ ., data = iris, wf = "gaussian", bw = 2, subset = ran)
  	pred1 <- predict(fit)
  	pred2 <- predict(fit, newdata = iris[ran,])
  	expect_equal(pred1, pred2)
	# y, x
	fit <- dalda(x = iris[,-5], grouping = iris$Species, wf = "gaussian", bw = 2, subset = ran)
  	pred1 <- predict(fit)
  	pred2 <- predict(fit, newdata = iris[ran,-5])
  	expect_equal(pred1, pred2)
})

test_that("predict.dalda works with missing classes in the training data", {
	data(iris)
	ran <- sample(1:150,100)
	expect_that(fit <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 10, subset = 1:100), gives_warning("group virginica is empty"))
	expect_equal(length(fit$prior), 2)
	a <- rep(50, 2)
	names(a) <- names(fit$counts)
	expect_equal(fit$counts, a)
	expect_equal(fit$N, 100)
	expect_equal(nrow(fit$means), 2)
	pred <- predict(fit, newdata = iris[-ran,])
	expect_equal(nlevels(pred$class), 3)
	expect_equal(ncol(pred$posterior), 2)
	# a <- rep(0,50)
	# names(a) <- rownames(pred$posterior)
	# expect_equal(pred$posterior[,3], a)
})

test_that("predict.dalda works with one single predictor variable", {
	data(iris)
	ran <- sample(1:150,100)
	fit <- dalda(Species ~ Petal.Width, data = iris, wf = "gaussian", bw = 2, subset = ran)
	expect_equal(ncol(fit$means), 1)
	expect_equal(dim(fit$cov), rep(1, 2))
	pred <- predict(fit, newdata = iris[-ran,])
})

test_that("predict.dalda works with one single test observation", {
	data(iris)
	ran <- sample(1:150,100)
	fit <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2, subset = ran)
  	pred <- predict(fit, newdata = iris[5,])
	expect_equal(length(pred$class), 1)
	expect_equal(dim(pred$posterior), c(1, 3))
	a <- factor("setosa", levels = c("setosa", "versicolor", "virginica"))
	names(a) = "5"
	expect_equal(pred$class, a)
	pred <- predict(fit, newdata = iris[58,])
	expect_equal(length(pred$class), 1)
	expect_equal(dim(pred$posterior), c(1, 3))
	a <- factor("versicolor", levels = c("setosa", "versicolor", "virginica"))
	names(a) = "58"
	expect_equal(pred$class, a)
})

test_that("predict.dalda works with one single predictor variable and one single test observation", {
	data(iris)
	ran <- sample(1:150,100)
	fit <- dalda(Species ~ Petal.Width, data = iris, wf = "gaussian", bw = 2, subset = ran)
	expect_equal(ncol(fit$means), 1)
	expect_equal(dim(fit$cov), rep(1, 2))
	pred <- predict(fit, newdata = iris[5,])
	expect_equal(length(pred$class), 1)
	expect_equal(dim(pred$posterior), c(1, 3))
})

test_that("predict.dalda: NA handling in newdata works", {
	data(iris)
	ran <- sample(1:150,100)
	irisna <- iris
	irisna[1:17,c(1,3)] <- NA
	fit <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 50, subset = ran)
	expect_warning(pred <- predict(fit, newdata = irisna))
	expect_equal(all(is.na(pred$class[1:17])), TRUE)
	expect_equal(all(is.na(pred$posterior[1:17,])), TRUE)
})

test_that("predict.dalda: misspecified arguments", {
	data(iris)
	ran <- sample(1:150,100)
	fit <- dalda(Species ~ ., data = iris, wf = "gaussian", bw = 2, subset = ran)
    # errors in newdata
    expect_error(predict(fit, newdata = TRUE))
    expect_error(predict(fit, newdata = -50:50))
    # errors in prior
    expect_error(predict(fit, prior = rep(2,length(levels(iris$Species))), newdata = iris[-ran,]))
    expect_error(predict(fit, prior = TRUE, newdata = iris[-ran,]))
    expect_error(predict(fit, prior = 0.6, newdata = iris[-ran,]))
})

#=================================================================================================================
# mod <- dalda(Species ~ Sepal.Length + Sepal.Width, data = iris, wf = "gaussian", bw = 0.5)
# x1 <- seq(4,8,0.05)
# x2 <- seq(2,5,0.05)
# plot(iris[,1], iris[,2], col = iris$Species, cex = mod$weights[[1]])
# plot(iris[,1], iris[,2], col = iris$Species, cex = mod$weights[[2]])
# plot(iris[,1], iris[,2], col = iris$Species, cex = mod$weights[[3]])
# plot(iris[,1], iris[,2], col = iris$Species, cex = mod$weights[[4]])
# legend("bottomright", legend = levels(iris$Species), col = as.numeric(unique(iris$Species)), lty = 1)

# iris.grid <- expand.grid(Sepal.Length = x1, Sepal.Width = x2)
# pred <- predict(mod, newdata = iris.grid)
# prob.grid <- pred$posterior
# contour(x1, x2, matrix(prob.grid[,1], length(x1)), add = TRUE, label = colnames(prob.grid)[1])
# contour(x1, x2, matrix(prob.grid[,2], length(x1)), add = TRUE, label = colnames(prob.grid)[2])
# contour(x1, x2, matrix(prob.grid[,3], length(x1)), add = TRUE, label = colnames(prob.grid)[3])


# user options
nox<-2; noy<-3;
paper<-T   # if paper==T output on file, else screen
cleanup()

SMS.option<-" "

first.year.in.mean<-2020    # years where output is independent of initial conditions and used as "equilibrium"
last.year.in.mean<-2029

do.simulation<-T     # do the simulations and create data files for plots

read.condense<-T
do.plot.condense<-T

read.detailed<-T
cutof.year.detailed<-2008
do.plot.detailed<-T

include.probability<-T

######### end user options #########

#do.HCR.batch<-function() {

#Read refence points from file reference_points.in
ref<-Read.reference.points()
blim<-ref[,"Blim"]
bpa<-ref[,"Bpa"]
T1<-blim
T2<-bpa

#  files for output
ssb.out<-'HCR_SSB.dat'
yield.out<-'HCR_yield.dat'
F.out<-'HCR_F.dat'
prob.out<-'HCR_prob.dat'

ssb.out.all<-'mcout_SSB.out.all'
yield.out.all<-'mcout_yield.out.all'
F.out.all<-'mcout_mean_F.out.all'
prob.out.all<-'HCR_prob.dat.all'

if (do.simulation) {

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat.gem')

  sp.name<-control@species.names

  percentiles<-c(0.025,0.05,0.10,0.25,0.50,0.75,0.95,0.975)

  # headers in output files
  heading<-"targetF Freduction TACconstraint Trigger2"
  cat(paste(heading,"Species.n "),file=ssb.out)
  cat(paste("SSB",formatC(percentiles*1000,width=3,flag='0'),sep=''),file=ssb.out,append=T); cat('\n',file=ssb.out,append=T)
  cat(paste(heading,"Species.n "),file=yield.out)
  cat(paste("y",formatC(percentiles*1000,width=3,flag='0'),sep=''),file=yield.out,append=T); cat('\n',file=yield.out,append=T)
  cat(paste(heading,"Species.n "),file=F.out)
  cat(paste("F",formatC(percentiles*1000,width=3,flag='0'),sep=''),file=F.out,append=T); cat('\n',file=F.out,append=T)
  cat(paste(heading,"Species.n "," p.T1 p.T2 \n"),file=prob.out)

  iter<-0

  HCR@no.MCMC.iterations<-1   #no of iterations
  HCR@last.prediction.year<-2030

  targetFs<-seq(0.18,0.35,0.02)
  Freductions<-c(20,30, 40, 50)
  TAC2<-       c(800, 750, 700,600)*1000

  #Freductions<-50
  #TACconstraints<-seq(15,45,10)
  TACconstraints<-0
  Trigger2s<-seq(2500000,3000000,250000)

   i<-0
   for (targetF in (targetFs)) for (Freduction in (Freductions)) for (TACconstraint in (TACconstraints)) for (Trigger2 in (Trigger2s)) i<-1+i
   print(paste("You have asked for",i,"runs. Do you want to continue? (Y/N):"))
   a<-readLines(n=1)
   if(a=='N') stop("Script stopped'")
   print('OK')
   tot.rep<-i

  for (targetF in (targetFs)) for (Freduction in (Freductions)) for (TACconstraint in (TACconstraints)) for (Trigger2 in (Trigger2s)){
      iter<-iter+1
      print(paste("targetF:",targetF," Freduction:",Freduction," TACconstraint:",TACconstraint," Trigger2;",Trigger2))
      print(paste("run no.:",iter, "out of a total of",tot.rep,"runs"))

      HCR@constant.F[1]<-targetF

     HCR@intermidiate.TAC['second',1]<-TAC2[grep(Freduction,Freductions) ]

      HCR@real.time["dist",1]<-Freduction

      if (TACconstraint>0 ) {
         HCR@TAC.constraints["min",1]<-1-TACconstraint/100
         HCR@TAC.constraints["max",1]<-1+TACconstraint/100
       } else {
         HCR@TAC.constraints["min",1]<-0
         HCR@TAC.constraints["max",1]<-0
       }

      HCR@Trigger["T2",1]<-Trigger2
      HCR@Trigger.a.b["FT12b",1]<-(targetF-HCR@Trigger.a.b["FT1b",1])/ (HCR@Trigger["T2",1]-HCR@Trigger["T1",1])
      HCR@Trigger.a.b["FT2a",1]<-targetF
      HCR@Trigger.a.b["FT2b",1]<-0.0

      write.FLSMS.predict.control(HCR,file='HCR_options.dat')

      #run SMS
      shell(paste( file.path(root,"program","sms.exe"),"-mceval",SMS.option,sep=" "), invisible = TRUE)

      condense_file<-function(filename){
        file<-file.path(data.path,filename)
        a<-read.table(file,header=TRUE)
        a<-subset(a,Year>cutof.year.detailed)
        a<-data.frame(a,targetF=targetF, Freduction=Freduction, TACconstraint=TACconstraint, Trigger2=Trigger2)

        file<-paste(file,".all",sep='')
        if (iter==1) write.table(a, file =file, row.names = F,col.names = T,quote = F) else write.table(a, file =file, row.names =F,col.names =F, quote =F,append=T)
      }

      condense_file("mcout_SSB.out")
      condense_file("mcout_recruit.out")
      condense_file("mcout_mean_F.out")
      condense_file("mcout_yield.out")

      a<-Read.MCMC.SSB.rec.data()
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)

      b<-tapply(a$SSB,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      for (i in (1:length(b))) {
         cat(paste(targetF,Freduction, TACconstraint, Trigger2 ,i,' '),file=ssb.out,append=TRUE)
         cat(b[[i]],file=ssb.out,append=TRUE)
         cat('\n',file=ssb.out,append=TRUE)
      }

      dummy<-by(a,list(a$Species.n),function(x) {
        q<-tapply(x$SSB,list(x$Year,x$Repetion,x$Iteration),sum)
        sp<-x[1,"Species.n"]
        q[q>T2[sp]]<-0
        q[q>0]<-1
        p.T2<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])

        q<-tapply(x$SSB,list(x$Year,x$Repetion,x$Iteration),sum)
        q[q>T1[sp]]<-0
        q[q>0]<-1
        p.T1<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])
        cat(paste(targetF,Freduction, TACconstraint, Trigger2,sp,p.T1,p.T2,'\n'),file=prob.out,append=TRUE)
      })

      a<-Read.MCMC.F.yield.data(dir=data.path)
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)
      b<-tapply(a$Yield,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      for (i in (1:length(b))) {
         cat(paste(targetF,Freduction, TACconstraint, Trigger2,i,' '),file=yield.out,append=TRUE)
         cat(b[[i]],file=yield.out,append=TRUE)
         cat('\n',file=yield.out,append=TRUE)
      }

      b<-tapply(a$mean.F,list(a$Species.n), function(x) quantile(x,probs = percentiles))
      for (i in (1:length(b))) {
         cat(paste(targetF,Freduction, TACconstraint, Trigger2,i,' '),file=F.out,append=TRUE)
         cat(b[[i]],file=F.out,append=TRUE)
         cat('\n',file=F.out,append=TRUE)
      }
  }
}   # end do.simulations

if (read.condense) {

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.name<-control@species.names

  ssb<-read.table(ssb.out,header=TRUE)
  yield<-read.table(yield.out,header=TRUE)
  proba<-read.table(prob.out,header=TRUE)
  fi<-read.table(F.out,header=TRUE)

  a<-merge(ssb,yield)
  a<-merge(a,proba)
  a<-merge(a,fi)
  condensed<-data.frame(a,targetF.fac=as.factor(a$targetF), Freduction.fac=as.factor(a$Freduction),
    TACconstraint.fac=as.factor(a$TACconstraint), Trigger2.fac=as.factor(a$Trigger2/1000))
 }

if (read.detailed) {

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.name<-control@species.names
  Years<- c(2009,2010,2011,2012,2013,2014,2015, 2018, 2020, 2027,2029)
  ssb<-read.table(ssb.out.all,header=TRUE)
  ssb<-subset(ssb,Year %in% Years)

  cat("Year targetF Freduction TACconstraint Trigger2 p.T2 p.T1 Species.n\n",file=prob.out.all)
  dummy<-by(ssb,list(ssb$Species.n),function(x) {
        q<-tapply(x$SSB,list(x$Repetion,x$Iteration,x$Year,x$targetF,x$Freduction,x$TACconstraint,x$Trigger2),sum)
        sp<-x[1,"Species.n"]
        q[q>T2[sp]]<-0
        q[q>0]<-1
        p.T2<-apply(q,c(3,4,5,6,7),sum)/ (dim(q)[1]*dim(q)[2])

        q<-tapply(x$SSB,list(x$Repetion,x$Iteration,x$Year,x$targetF,x$Freduction,x$TACconstraint,x$Trigger2),sum)
        q[q>T1[sp]]<-0
        q[q>0]<-1
        p.T1<-apply(q,c(3,4,5,6,7),sum)/ (dim(q)[1]*dim(q)[2])

        a<-arr2dfny(p.T2,name="p.T2")
        b<-arr2dfny(p.T1,name="p.T1")
        a<-data.frame(merge(a,b),Species.n=sp)
        names(a)[1:5]<-list("Year", "targetF","Freduction", "TACconstraint", "Trigger2")

        write.table(a,row.names=F,col.names=F,quote=F,file=prob.out.all,append=T)
   })

  #proba<-read.table(prob.out.all,header=TRUE)

  yield<-read.table(yield.out.all,header=TRUE)
  yield<-subset(yield,Year %in% Years)

  fi<-read.table(F.out.all,header=TRUE)
  fi<-subset(fi,Year %in% Years)

  a<-merge(ssb,yield)
  a<-merge(a,fi)
  detailed<-data.frame(a,Year.fac=as.factor(a$Year),targetF.fac=as.factor(a$targetF), Freduction.fac=as.factor(a$Freduction),TACconstraint.fac=as.factor(a$TACconstraint), Trigger2.fac=as.factor(a$Trigger2/1000))
  print(summary(detailed))
 }

 #### plot function
 my.dev<-function(filen) {
 	  win.metafile(filename = filen, width=14,height=14,restoreConsole = TRUE, pointsize=12)
  }

if (do.plot.detailed) {

  PlotYears<- c(2009,2010,2011,2012, 2020, 2027)
 #PlotYears<- c(2010,2012,2015, 2020, 2025,2029)
 ### Yield
 res<-subset(detailed,(Year %in% PlotYears))

 a<-subset(res,Year>2008 ,select=c(yield,targetF,Freduction,Year,Trigger2,TACconstraint))
 # tapply(a$yield,list(a$targetF,a$Freduction,a$Year,a$Trigger2,a$TACconstraint),mean)
 a<-aggregate(a,list(a$targetF,a$Freduction,a$Year,a$Trigger2,a$TACconstraint),mean)
 max(a$yield)/1000

 resTAC<-data.frame(a,Year.fac=as.factor(a$Year),targetF.fac=as.factor(a$targetF),
    Freduction.fac=as.factor(a$Freduction),TACconstraint.fac=as.factor(a$TACconstraint), Trigger2.fac=as.factor(a$Trigger2/1000))

my.fontsize<-22
my.dev("TAC_SMS2.wmf")

    print(contourplot(yield/1000 ~ targetF * Freduction | Year.fac*Trigger2.fac,  data = resTAC,
             cuts = 10, region = TRUE,
             at=seq(0,800,100),
            # at=seq(200,500,50),

              xlab = "F target",  par.settings=list(fontsize=list(text=my.fontsize)),
              ylab = "% F reduction", col.regions=rev(heat.colors(1000)), pretty=T,
              main = paste(my.stock.dir,": TAC"))
  )
  if (paper) cleanup()

 ### SSB
 a<-subset(res,Year>2008 ,select=c(SSB,targetF,Freduction,Year,Trigger2,TACconstraint))
 #tapply(a$SSB,list(a$targetF,a$Freduction,a$Year,a$Trigger2,a$TACconstraint),mean)
 min(a$SSB)/1000
 max(a$SSB)/1000
 a<-aggregate(a,list(a$targetF,a$Freduction,a$Year,a$Trigger2,a$TACconstraint),mean)
 max(a$SSB)/1000
 resTAC<-data.frame(a,Year.fac=as.factor(a$Year),targetF.fac=as.factor(a$targetF),
    Freduction.fac=as.factor(a$Freduction),TACconstraint.fac=as.factor(a$TACconstraint), Trigger2.fac=as.factor(a$Trigger2/1000))
 my.dev("SSB_SMS.wmf")
 print(contourplot(SSB/1000 ~ targetF * Freduction | Year.fac*Trigger2.fac,  data = resTAC,
             cuts = 10, region = TRUE,at=seq(1400,2800,100),
              xlab = "F target",  par.settings=list(fontsize=list(text=my.fontsize)),
              ylab = "% F reduction", col.regions=rev(heat.colors(1000)), pretty=T,
              main = paste(my.stock.dir,": SSB"))
  )

 if (paper) cleanup()
}

if (do.plot.condense) {

 a<-read.table(prob.out.all,header=TRUE)
 a<-subset(a,(Year %in% PlotYears))
 a<-data.frame(a,Year.fac=as.factor(a$Year),targetF.fac=as.factor(a$targetF),
    Freduction.fac=as.factor(a$Freduction),TACconstraint.fac=as.factor(a$TACconstraint), Trigger2.fac=as.factor(a$Trigger2/1000))
 #print(summary(a))
 #a<-subset(a,TACconstraint==45)

my.dev("Plim_SMS.wmf")

 #  tapply(a$p.T1,list(a$targetF,a$Freduction,a$Year,a$Trigger2,a$TACconstraint),max)
max(a$p.T1)

 print(contourplot(p.T1 ~ targetF * Freduction | Year.fac*Trigger2.fac, data = a,
              region = TRUE,at=seq(0,0.6,0.05),
              xlab = "F target",  par.settings=list(fontsize=list(text=my.fontsize)),
              ylab = "% F reduction", col.regions=rev(heat.colors(1000)), pretty=T,
              main = paste(my.stock.dir,"Prob(SSB<=Blim)"))
  )

 if (paper) cleanup()

  # user options
 nox<-1; noy<-1;
 if (paper) dev<-"wmf" else dev<-"screen"
 newplot(dev,nox,noy,dir=data.path,filename=paste("Batch2_",sep=''),Portrait=T);
  xlab.title<-'Cod F'

  # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.name<-control@species.names

  ssb<-read.table(ssb.out,header=TRUE)
  yield<-read.table(yield.out,header=TRUE)
  prob<-read.table(prob.out,header=TRUE)
  fi<-read.table(F.out,header=TRUE)

  a<-merge(ssb,yield)
  a<-merge(a,prob)
  a<-merge(a,fi)

} #end do.plot.condense

#}
#do.HCR.batch()


library(phyloseq)
library(microbiome)
#library(microbiomeutilities)
library(DirichletMultinomial)
library(reshape2)
library(magrittr)
library(dplyr)
library(tidyr)
library(pheatmap)
library(ggpubr)
library(ggsci)
# getwd()
# count_tab<-read.table("Combined_BALF_GO_Terms_counts.txt", header = T, sep = "\t", row.names = 1)
# tax_tab<-read.table("Combined_BALF_GO_Terms_tax.txt", header = T, sep = "\t", row.names = 1)
# sam_tab<-read.table("Combined_BALF_GO_Terms_metadata.txt", header = T, sep = "\t", row.names = 1)
# count<-otu_table(count_tab,taxa_are_rows = T)
# tax<-tax_table(as.matrix(tax_tab),errorIfNULL = T)
# sam<-sample_data(sam_tab)
#pseq<-bio_bac_physeq
pseq <- phyloseq(bio_bac_counts_phy, bio_bac_tax_phy, sample_data(bio_bac_sam))

test<-as.data.frame(tax_table(pseq))
head(test$name, n=1000L)
pseq
pseq<-subset_samples(pseq, sample_type!="neg_control")
pseq<-subset_samples(pseq, sample_type!="Unknown")
pseq

summarize_phyloseq(pseq)
meta(pseq)$case
##########################################
mypal2<- pal_startrek("uniform", alpha = 1)(7)
mypal <- pal_aaas("default", alpha = 1)(7)
mypal2
mypal3<-rbind(mypal, mypal2)
mypal3

mypal3<-c("#3B4992FF", "#BB0021FF", "#5F559BFF", "#CC0C00FF", "#EE0000FF","#008B45FF",  "#631879FF", "#008280FF", "#5C88DAFF", "#84BD00FF", "#FFCD00FF", "#7C878EFF", "#00B5E2FF", "#00AF66FF")
p <- plot_frequencies(sample_data(pseq), "publication","sample_type")+scale_fill_manual(values = mypal3)

q <- plot_frequencies(sample_data(pseq), "publication","case")+scale_fill_manual(values =c( "#008B45FF","#3B4992FF" ,"#EE0000FF"))#green-blue-red

#########################################
# Pre-processing
#########################################
#maybe I want to subset for the depth....not sure yet
#pseq_prune<-subset_taxa(physeq = pseq_prune,depth >10)
pseq_prune <- prune_taxa(taxa_sums(pseq) > 1, pseq)
pseq_prune <- prune_samples(sample_sums(pseq_prune) > 1, pseq_prune)
pseq_prune

#rownames clean still
pseq_prune<-tax_glom(physeq = pseq_prune, taxrank = "name")
pseq_prune
####################Do NOT EXECUTE THIS CODE#################################################
#write.table(x = rownames(data.frame(otu_table(pseq_prune))), file = "test.tsv",sep = "\t")
#this was causing major issues with the rownames
taxa_names(pseq_prune)<-get_taxa_unique(pseq_prune,taxonomic.rank = "name" )
############################################################################################

########################################
#DMM modeling
#########################################
dat <- abundances(pseq_prune)
count <- as.matrix(t(dat))
dim(dat)
dim(count)
dmn
fit<-mclapply(1:7,FUN =  dmn, count = count, verbose=TRUE)
fit
#Check the model fit with different number of mixture componenets using standard information criteria
lplc <- sapply(fit, laplace) # AIC / BIC / Laplace
aic  <- sapply(fit, AIC) # AIC / BIC / Laplace
bic  <- sapply(fit, BIC) # AIC / BIC / Laplace
plot(lplc, type="b", xlab="Number of Dirichlet Components", ylab="Model Fit")
plot(aic)
plot(bic)
#lines(aic, type="b", lty = 2)
#lines(bic, type="b", lty = 3)
best <- fit[[which.min(lplc)]]
best
best <-fit[[4]]
heatmapdmn(count, fit[[1]], best,ntaxa = 30,
           transform = sqrt, lblwidth = 0.1 * nrow(count))
mixturewt(best)
ass <- apply(mixture(best), 1, which.max)
ass
write.table(ass,"3_greoup_GO_term_sample_DMM_groups.tsv",sep="")
write.table(fitted(best),"3_group_GO_term_DMM2_contributions.tsv", sep="\t")

physeq<-pseq_prune
meta<-data.frame(sample_data(physeq))
meta$dmm<-ass
for (k in seq(ncol(fitted(best))))
{
  d <- melt(fitted(best))
  colnames(d) <- c("GO", "cluster", "value")
  d <- subset(d, cluster == k) %>%
    # Arrange GOs by assignment strength
    arrange(value) %>%
    mutate(GO = factor(GO, levels = unique(GO))) %>%
    # Only show the most important drivers
    filter(abs(value) > quantile(abs(value), 0.995))

  p <- ggplot(d, aes(x = GO, y = value)) +
    geom_bar(stat = "identity") +
    coord_flip() +
    labs(title = paste("Top drivers in  : GO  Terms cluster type ", k, sep = ""))
  #paste(p,k, sep = "")<-p
  #print(k)
  print(p)
  #print(paste(p,k, sep=""))
}

dim(d)
pseq_prune
sample_data(pseq_prune)$dmn<-ass
library(phyloseq)
library(speedyseq)
tmp<-psmelt(pseq_prune)
tmp<-as_tibble(tmp)

tmp
d2<-tmp %>%
  select(case,name,Abundance, dmn)%>%
  group_by(name,case, dmn) %>%
  summarise(avg = mean(Abundance),std = sd(Abundance)) %>%
  group_by(name, case,dmn, std)%>%
  arrange(desc(std))
d2
#d3<-tidyr::spread(d2,dmn, avg)
d3<-tidyr::spread(d2,case,avg)
d3
d3[4:6]
library(mosaic)
#d3$tot<-sd(d3[3:5])
#d3$tot<-rowSums(d3[3:5], na.rm = T)
d3<-d3%>%arrange(desc(std))
rank<-as.character(d3$name)

d4<-d3[1:500,]

d4<-d4%>%
  gather(data = d4,avg,4:6)

colnames(d4)<-c("name","dmn","std", "group","avg")

#d4<-d3%>%group_by(name,group)
d4<-d4%>%filter(!is.na(avg))

d4
ggballoonplot(data = d4, y ="name",x = "group", size = "avg", facet.by = "dmn",fill = "avg")+scale_fill_viridis_c()

library(mosaic)

meta(pseq_prune)
head(tmp$OTU)
head(tmp$Abundance)
head(tmp$dmn)

my_tbl<-tally(~case+ dmn+publication,data =meta(pseq_prune),format = 'count')
my_tbl
a<-as_tibble(my_tbl)
getwd()

ggballoonplot(data = a, y ="case",x = "dmn", facet.by = "publication",size = "n", fill = "n")+
  scale_fill_viridis_c(option = "C")+
  ggsave(filename = "pub_vs_disease_vs_dmm_dotplot.png",
         device = "png",
         #width = "8",
         #height = "6",
         #units = "in",
         dpi = 600,
         path = "D:/github/microbial/Rdata/GO_term_analysis/Figures/")
my_tbl<-tally(publication ~ dmn,data =meta(pseq_prune),format = 'count')
my_tbl
a<-as_tibble(my_tbl)
ggballoonplot(data = a, y ="publication",x = "dmn", size = "n", fill = "n")+scale_fill_viridis_b(option = "B")

###########################################
###Dont forget to save you shit HERE#######
###########################################
save.image(file = "go_terms_dmm.rdata")

count<-abundances(pseq_prune)
#count
#rowMeans(count,na.rm = T)

select <- order(rowMeans(count),
                decreasing=TRUE)[1:20]
select
#sample_data(pseq_prune)<-sam
dim(sam)
dim(sample_data(pseq_prune))
df<-as.data.frame(sam)
df<-as_tibble(df)
df<-df%>%select(dmn)#,dmn,body_site)
df <-sample_data(pseq_prune)$dmn

df<-as.character(df)
df<-as.data.frame(df)
df$Dataset<-sam$publication

df$sample_type<-sample_data(pseq_prune)$sample_type
select2<-(count)[select,]
colnames(select2) <- colnames(otu_table(pseq_prune))
colnames(select2)
row.names(df)
row.names(df) <- colnames(select2)
ass
mypal <- pal_aaas("default", alpha = 1)(10)
mypal
library("scales")
unique(df)
show_col(mypal)
df
mosaicplot(df)
# Specify colors
ann_colors = list(
  df=c("1"="#3B4992FF","2"="#EE0000FF","3"="#008B45FF","4"="#631879FF"),
  Dataset=c("Chen"="#3B4992FF","Wu"="#EE0000FF","Zhou"="#631879FF",
  "Xiong"="#008280FF", "Shen"="#631879FF","Michalovich"="#BB0021FF",
  "Huang"="#000000","Ren"="#111111"),
  sample_type =c("COVID_19"="#3B4992FF",
                 "Community_acquired_pneumonia"="#EE0000FF",
                 "Healthy"="#008B45FF",
                  "neg_control"="#000000",
                 "Smoker"="#631879FF",
                 "Asthma"= "#008280FF",
                  "Asthma_Smoker"="#BB0021FF",
                 "Asthma_Ex_smoker"="#5F559BFF",
                 "Obese"="#A20056FF",
                  "Obese_Asthma"="#808180FF",
                 "Obese_Smoker"="#1B1919FF",
                 "Obese_Asthma_Smoker"="#1111111",
                 "Unknown"="#222222"))
ann_colors
df_row<-as.data.frame(fitted(best))
colnames(df_row)L-c()
library(RColorBrewer)
library(viridis)
xx <- pheatmap(mat = select2,
               color = viridis(256),
               annotation_col=df,
               annotation_colors = ann_colors,
               clustering_distance_rows = "euclidean",
               clustering_distance_cols = "euclidean",
               annotation_row = df_row)
xx
pheatmap(mat,
         color = colorRampPalette(rev(brewer.pal(n = 7, name ="RdYlBu")))(100),
         kmeans_k = NA,
         breaks = NA,
         border_color = "grey60",
         cellwidth = NA,
         cellheight = NA,
         scale = "none",
         cluster_rows = TRUE,
         cluster_cols = TRUE,
         clustering_distance_rows = "euclidean",
         clustering_distance_cols = "euclidean",
         clustering_method = "complete",
         clustering_callback = identity2,
         cutree_rows = NA,
         cutree_cols = NA,
         treeheight_row = ifelse((class(cluster_rows) == "hclust") || cluster_rows,
                                 50, 0), treeheight_col = ifelse((class(cluster_cols) == "hclust") ||
                                                                   cluster_cols, 50, 0),
         legend = TRUE,
         legend_breaks = NA,
         legend_labels = NA,
         annotation_row = NA,
         annotation_col = NA,
         annotation = NA,
         annotation_colors = NA,
         annotation_legend = TRUE,
         annotation_names_row = TRUE,
         annotation_names_col = TRUE,
         drop_levels = TRUE, show_rownames = T, show_colnames = T, main = NA,
         fontsize = 10, fontsize_row = fontsize, fontsize_col = fontsize,
         angle_col = c("270", "0", "45", "90", "315"), display_numbers = F,
         number_format = "%.2f", number_color = "grey30", fontsize_number = 0.8
         * fontsize, gaps_row = NULL, gaps_col = NULL, labels_row = NULL,
         labels_col = NULL, filename = NA, width = NA, height = NA,
         silent = FALSE, na_col = "#DDDDDD", ...)


## FILE: tasampled-three-models-refactored.r
## EXPERIMENT:  equifinality-5
## PROJECT:  experiment-ctmixtures
## AUTHOR:  Mark E. Madsen
## DATE:  5.20.15

# Purpose:  To take simulated output from the CTMixtures simulation, which is time averaged and sampled,
# and perform gradient boosted classification to measure our ability to distinguish between neutral,
# conformist, and anticonformist cultural transmission given the availability of 26 predictor variables.
# The models are fit using the Caret package to find the optimal model tuning (via 5 repeated of 10-fold CV),
# and the final model assessed using a 20% test hold-out sample.  Test sample results are given by a
# confusion matrix and ROC analysis, which are saved into a set of results objects and saved as binary
# images to the filesystem for later use in paper preparation.
# mmadsenr brings in GBM and other crucial analytic libraries

# In this analysis, we allow the model to use the sample size and assemblage duration as predictors
# See combined-tasampled-duration-hidden.r for the same analysis, but withdrawing the ability of the model
# to use duration (thus combining data from all durations).

library(mmadsenr)
library(caret)
library(doMC)
library(futile.logger)
library(dplyr)
# not sure if the following is necessary anymore
library(ggthemes)

# Overall timing
ptm <- proc.time()

################# Training and Tuning Parameters #############
## Caret training and tuning parameter grid
gbm_grid <- expand.grid(interaction.depth = (1:6)*2,
                        n.trees = (2:10)*50,
                        shrinkage = 0.05,
                        n.minobsinnode = 10)
training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)
# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

##################### Helper Functions ####################

# Subset of the larger data set (usually the training set) with a given sample size and time
# averaging duration
get_tassize_subset_ssize_tadur <- function(df, ssize, tadur) {
  df_tassize_subset <- dplyr::filter(df, sample_size == ssize, ta_duration == tadur)
  df_tassize_subset
}

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

do_model_fit_and_test <- function(comparison,exp_name, ssize, ta_dur, target_label, subset_df, gbm_grid, training_control, exclude_columns) {
  results <- NULL
  model <- train_gbm_classifier(subset_df, training_set_fraction, target_label, gbm_grid, training_control, exclude_columns, verbose=FALSE)
  # use the test data split by the train_randomforest function and calculate tuned model predictions
  # and then get the confusion matrix and fitting metrics
  test_data <- model$test_data
  predictions <- predict(model$tunedmodel, newdata=test_data)
  cm <- confusionMatrix(predictions, test_data[[target_label]])
  stats <- get_parsed_binary_confusion_matrix_stats(cm)
  roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, target_label, exp_name)
  stats$auc <- unlist(roc$auc@y.values)
  stats$sample_size <- ssize
  stats$ta_duration <- ta_dur
  stats$elapsed <- model$elapsed
  stats$experiments <- exp_name
  stats$exp_group <- comparison
  # add the CM, ROC, and other information to the results list
  results$sample_size <- ssize
  results$ta_duration <- ta_dur
  results$cm <- cm
  results$roc <- roc
  results$model <- model
  results$stats <- stats
  results$elapsed <- model$elapsed
  results
}

####################### Main Program #######################
#log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5", filename = "tasampled-classification.log")
log_file <- "/mnt/experiment-ctmixtures/equifinality-5/tasampled-classification.log"
flog.appender(appender.file(log_file), name='cl')
flog.info("================ TA and Sampled Classification Analysis =================", name='cl')
flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

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

# load the input data
clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5", filename = "equifinality-5-tasampled-data.rda")
} else {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5", filename = "equifinality-5-tasampled-data.rda", args = clargs)
}

pop_data_file <- "/mnt/experiment-ctmixtures/equifinality-5/equifinality-5-tasampled-data.rda"
load(pop_data_file)
flog.info("Loaded data file %s with %.0f rows",pop_data_file, nrow(eq5_ta_sampled_df),name='cl')

## To Test, uncomment this
# test_tasampled_indices <- createDataPartition(eq5_ta_sampled_df$model_class_label, p = 0.005, list=FALSE)
# eq5_ta_sampled_df <- eq5_ta_sampled_df[test_tasampled_indices,]
# flog.info("Test downsample to %.0f rows", nrow(eq5_ta_sampled_df), name='cl')

# Prepare data subsets for the three comparisons to be performed for each
eq5_neutral_conformist_df <- subset(eq5_ta_sampled_df, eq5_ta_sampled_df$model_class_label == "neutral" | eq5_ta_sampled_df$model_class_label == "conformist")
eq5_neutral_conformist_df$two_class_label <- factor(eq5_neutral_conformist_df$model_class_label, levels=unique(eq5_neutral_conformist_df$model_class_label))
eq5_neutral_anticonformist_df <- subset(eq5_ta_sampled_df, eq5_ta_sampled_df$model_class_label == "neutral" | eq5_ta_sampled_df$model_class_label == "anticonformist")
eq5_neutral_anticonformist_df$two_class_label <- factor(eq5_neutral_anticonformist_df$model_class_label, levels=unique(eq5_neutral_anticonformist_df$model_class_label))
eq5_ta_sampled_df$two_class_label <- factor(ifelse(eq5_ta_sampled_df$model_class_label == 'neutral', 'neutral', 'biased'))

# get grid of the sample size and TA duration combinations, to tassize_subset the data set
sample_sizes <- unique(eq5_ta_sampled_df$sample_size)
ta_durations <- unique(eq5_ta_sampled_df$ta_dur)
tassize_subsets <- expand.grid(sample_size = sample_sizes, ta_duration = ta_durations)
flog.info("tassize_subsets: number of subset combinations to analyze per experimental comparison: %.0f", nrow(tassize_subsets),name='cl')

################# neutral vs. conformism ##############
flog.info("Starting neutral vs. conformist subsets",name='cl')
tassize_neutral_conformist_results <- data.frame()
tassize_neutral_conformist_roc <- NULL
tassize_neutral_conformist_roc_ssize_20 <- NULL
tassize_neutral_conformist_roc_ssize_10 <- NULL
tassize_neutral_conformist_model <- NULL
tassize_neutral_conformist_cm <- NULL

experiment_names <- get_experiment_names("Neutral vs Conformist", tassize_subsets)
comparison <- "Neutral versus Conformist"

for( i in 1:nrow(tassize_subsets)) {
  exclude_columns <- c("simulation_run_id", "innovation_rate", "model_class_label", "sample_size", "ta_duration")
  target_label <- "two_class_label"
  exp_name <- experiment_names[i]
  ssize <- tassize_subsets[i, "sample_size"]
  ta_dur <- tassize_subsets[i, "ta_duration"]
  subset_df <- get_tassize_subset_ssize_tadur(eq5_neutral_conformist_df,
                                              ssize,
                                              ta_dur)
  result <- do_model_fit_and_test(comparison,experiment_names[i], ssize, ta_dur, target_label, subset_df, gbm_grid, training_control, exclude_columns)
  tassize_neutral_conformist_cm[[exp_name]] <- result$cm
  tassize_neutral_conformist_model[[exp_name]] <- result$model
  tassize_neutral_conformist_roc[[exp_name]] <- result$roc
  tassize_neutral_conformist_results <- rbind(tassize_neutral_conformist_results, result$stats)
  if(ssize == 20) {
    tassize_neutral_conformist_roc_ssize_20[[exp_name]] <- result$roc
  }
  if(ssize == 10) {
    tassize_neutral_conformist_roc_ssize_10[[exp_name]] <- result$roc
  }
  logrow <- sprintf("row %.0f:  sample size: %2.0f  ta duration: %3.0f numrows: %.0f  elapsed: %.4f", i, ssize, ta_dur, nrow(subset_df), result$elapsed)
  flog.info("%s", logrow, name='cl')
}

################# neutral vs. anticonformism ##############
flog.info("Starting neutral vs. anticonformist subsets",name='cl')

tassize_neutral_anticonformist_results <- data.frame()
tassize_neutral_anticonformist_roc <- NULL
tassize_neutral_anticonformist_roc_ssize_20 <- NULL
tassize_neutral_anticonformist_roc_ssize_10 <- NULL
tassize_neutral_anticonformist_model <- NULL
tassize_neutral_anticonformist_cm <- NULL

experiment_names <- get_experiment_names("Neutral vs Anticonformist", tassize_subsets)
comparison <- "Neutral versus Anticonformist"

for( i in 1:nrow(tassize_subsets)) {
  exclude_columns <- c("simulation_run_id", "innovation_rate", "model_class_label", "sample_size", "ta_duration")
  target_label <- "two_class_label"
  exp_name <- experiment_names[i]
  ssize <- tassize_subsets[i, "sample_size"]
  ta_dur <- tassize_subsets[i, "ta_duration"]
  subset_df <- get_tassize_subset_ssize_tadur(eq5_neutral_anticonformist_df,
                                              ssize,
                                              ta_dur)
  result <- do_model_fit_and_test(comparison,experiment_names[i], ssize, ta_dur, target_label, subset_df, gbm_grid, training_control, exclude_columns)
  tassize_neutral_anticonformist_cm[[exp_name]] <- result$cm
  tassize_neutral_anticonformist_model[[exp_name]] <- result$model
  tassize_neutral_anticonformist_roc[[exp_name]] <- result$roc
  tassize_neutral_anticonformist_results <- rbind(tassize_neutral_anticonformist_results, result$stats)
  if(ssize == 20) {
    tassize_neutral_anticonformist_roc_ssize_20[[exp_name]] <- result$roc
  }
  if(ssize == 10) {
    tassize_neutral_anticonformist_roc_ssize_10[[exp_name]] <- result$roc
  }
  logrow <- sprintf("row %.0f:  sample size: %2.0f  ta duration: %3.0f numrows: %.0f  elapsed: %.4f", i, ssize, ta_dur, nrow(subset_df), result$elapsed)
  flog.info("%s", logrow, name='cl')
}

##################### neutral vs. both conformism and anticonformism ##############
flog.info("Starting neutral vs. biased subsets",name='cl')

tassize_neutral_biased_results <- data.frame()
tassize_neutral_biased_roc <- NULL
tassize_neutral_biased_roc_ssize_20 <- NULL
tassize_neutral_biased_roc_ssize_10 <- NULL
tassize_neutral_biased_model <- NULL
tassize_neutral_biased_cm <- NULL

experiment_names <- get_experiment_names("Neutral vs Biased", tassize_subsets)
comparison <- "Neutral versus Combined Biases"

for( i in 1:nrow(tassize_subsets)) {
  exclude_columns <- c("simulation_run_id", "innovation_rate", "model_class_label", "sample_size", "ta_duration")
  target_label <- "two_class_label"
  exp_name <- experiment_names[i]
  ssize <- tassize_subsets[i, "sample_size"]
  ta_dur <- tassize_subsets[i, "ta_duration"]
  subset_df <- get_tassize_subset_ssize_tadur(eq5_ta_sampled_df,
                                              ssize,
                                              ta_dur)
  result <- do_model_fit_and_test(comparison,experiment_names[i], ssize, ta_dur, target_label, subset_df, gbm_grid, training_control, exclude_columns)
  tassize_neutral_biased_cm[[exp_name]] <- result$cm
  tassize_neutral_biased_model[[exp_name]] <- result$model
  tassize_neutral_biased_roc[[exp_name]] <- result$roc
  tassize_neutral_biased_results <- rbind(tassize_neutral_biased_results, result$stats)
  if(ssize == 20) {
    tassize_neutral_biased_roc_ssize_20[[exp_name]] <- result$roc
  }
  if(ssize == 10) {
    tassize_neutral_biased_roc_ssize_10[[exp_name]] <- result$roc
  }
  logrow <- sprintf("row %.0f:  sample size: %2.0f  ta duration: %3.0f numrows: %.0f  elapsed: %.4f", i, ssize, ta_dur, nrow(subset_df), result$elapsed)
  flog.info("%s", logrow, name='cl')
}

################## Save all results #####################
if(length(clargs) == 0) {
  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5",
                              filename = "classification-ta-sampled-results-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5",
                                      filename = "classification-ta-sampled-results-gbm-dfonly.RData")
} else {
  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5",
                              filename = "classification-ta-sampled-results-gbm.RData", args = clargs)
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5",
                                      filename = "classification-ta-sampled-results-gbm-dfonly.RData", args = clargs)
}
flog.info("Saving results of analysis to R environment snapshot: %s", image_file, name='cl')
save(tassize_neutral_conformist_cm,
    tassize_neutral_conformist_results,
    tassize_neutral_conformist_model,
    tassize_neutral_conformist_roc,
    tassize_neutral_conformist_roc_ssize_10,
    tassize_neutral_conformist_roc_ssize_20,
    tassize_neutral_anticonformist_results,
    tassize_neutral_anticonformist_model,
    tassize_neutral_anticonformist_roc,
    tassize_neutral_anticonformist_roc_ssize_20,
    tassize_neutral_anticonformist_roc_ssize_10,
    tassize_neutral_anticonformist_cm,
    tassize_neutral_biased_results,
    tassize_neutral_biased_model,
    tassize_neutral_biased_roc,
    tassize_neutral_biased_roc_ssize_20,
    tassize_neutral_biased_roc_ssize_10,
    tassize_neutral_biased_cm,
    file=image_file)
flog.info("Saving just data frame of results of analysis to R environment snapshot: %s", image_file_results, name='cl')
save(tassize_neutral_conformist_results,tassize_neutral_anticonformist_results,tassize_neutral_biased_results, file=image_file_results)
# End
flog.info("Analysis complete", name='cl')
total_time <- proc.time() - ptm
flog.info("Elapsed time in analysis: %.3f", total_time[3],name='cl')