# Author:    Lerato E. Magosi
# R version: 4.0.3 (2020-10-10)
# Platform:  x86_64-apple-darwin19.6.0 (64-bit)
# Date:      16Mar2021

# Goal: Estimate transmission flows within and between population groups accounting for
#       sampling heterogeneity

# Required libraries ---------------------------

# library(dplyr)     # needed for sorting and merging data.frames
# library(Hmisc)     # needed for capitalizing elements of a character vector
# library(magrittr)  # needed for the pipe function
# library(gtools)    # needed for computing permutations and combinations
# library(stats)     # needed for the following functions: qchisq
# library(utils)     # needed for the following functions: str, head, tail

# Optional libraries ---------------------------

# library(DescTools) # needed for computing simultaneous confidence intervals for a multinomial proportions (Goodman, Sison-Glaz)
# library(ACSWR)     # needed for computing Queensbury Hurst simultaneous confidence intervals
# library(CoinMinD)  # needed for computing Queensbury Hurst simultaneous confidence intervals (narrow CIs)

# Calling globalVariables on the following variables to address
# the note: "no visible binding for global variable" generated by "R CMD check"
utils::globalVariables(c("est", "lwr.ci", "num_linked_pairs_observed", "upr.ci"))

# Strategy ---------------------------

# Estimates of transmisison flows are computed using methods from Carnegie and colleagues.
#     Carnegie NB, Wang R, Novitsky V, De Gruttola V (2014) Linkage of Viral Sequences among
#     HIV-Infected Village Residents in Botswana: Estimation of Linkage Rates in the Presence
#     of Missing Data. PLoS Computational Biology 10(1): e1003430. (PMID: 24415932)

# Note: Methods from Carnegie and colleagues are extended to account for direction of transmission
#       between linked pairs

# Function: estimate_transmission_flows ---------------------------
#
# Goal: use counts of observed directed transmission pairs (obtained via phyloscanner)
#       to estimate transmission flows within and between population groups accounting
#       for sampling heterogeneity
#
# For details on phyloscanner see PMID: 30926780 and PMID: 29186559
#
# parameters:
#
#
#   group_in                  (character) A vector indicating population groups/strata (e.g. communities, age-groups, genders or trial arms) between which transmission flows will be evaluated,
#   individuals_sampled_in    (numeric)   A vector indicating the number of individuals sampled per population group,
#   individuals_population_in (numeric)   A vector of the estimated number of individuals per population group,
#   linkage_counts_in                     A data.frame of counts of linked pairs identified between samples of each population pairing of interest.
#                                         The data.frame should contain the following three fields: H1_group (character), H2_group (character), number_linked_pairs_observed (numeric).
#                                         For a population group pairing, H1_group and H2_group denote population groups 1 and 2 respectively; and number_linked_pairs_observed denotes
#                                         the number of observed directed transmission pairs between samples from population groups 1 and 2.
#   verbose_output            (boolean)   A value to display intermediate output
#   detailed_report           (boolean)   A value to produce detailed output of the analysis
#
# returns: a data.frame containing:
#
#
#     H1_group                         (Factor)  Name of population group 1
#     H2_group                         (Factor)  Name of population group 2
#     number_hosts_sampled_group_1     (numeric) Number of individuals sampled from population group 1
#     number_hosts_sampled_group_2     (numeric) Number of individuals sampled from population group 2
#     number_hosts_population_group_1  (numeric) Estimated number of individuals in population group 1
#     number_hosts_population_group_2  (numeric) Estimated number of individuals in population group 2
#     max_possible_pairs_in_sample     (numeric) Number of distinct possible transmission pairs between individuals sampled from population groups 1 and 2
#     max_possible_pairs_in_population (numeric) Number of distinct possible transmission pairs between individuals in population groups 1 and 2
#     num_linked_pairs_observed        (numeric) Number of observed directed transmission pairs between samples from population groups 1 and 2
#     p_hat                            (numeric) Probability that pathogen sequences from two individuals randomly sampled from their respective population groups are linked
#     est_linkedpairs_in_population    (numeric) Estimated transmission pairs between population groups 1 and 2
#     theta_hat                        (numeric) Estimated transmission flows or relative probability of transmission within and between population groups 1 and 2 adjusted
#                                                for sampling heterogeneity. More precisely, the conditional probability that a pair of pathogen sequences is from a specific population
#                                                group pairing given that the pair is linked.
#     obs_trm_pairs_est_goodman        (numeric) Point estimate, Goodman method Confidence intervals for observed transmission pairs
#     obs_trm_pairs_lwr_ci_goodman     (numeric) Lower bound of Goodman confidence interval
#     obs_trm_pairs_upr_ci_goodman     (numeric) Upper bound of Goodman confidence interval
#     est_goodman                      (numeric) Point estimate, Goodman method Confidence intervals for estimated transmission flows
#     lwr_ci_goodman                   (numeric) Lower bound of Goodman confidence interval
#     upr_ci_goodman                   (numeric) Upper bound of Goodman confidence interval
#
#
# The following additional fields are returned if the detailed_report
#     flag is set
#
#     prob_group_pairing_and_linked    (numeric) Probability that a pair of pathogen sequences is from a specific population group pairing and is linked
#     c_hat                            (numeric) Probability that a randomly selected pathogen sequence in one population group links to at least
#                                                one pathogen sequence in another population group i.e. probability of clustering
#     est_goodman_cc                   (numeric) Point estimate, Goodman method Confidence intervals with continuity correction
#     lwr_ci_goodman_cc                (numeric) Lower bound of Goodman confidence interval
#     upr_ci_goodman_cc                (numeric) Upper bound of Goodman confidence interval
#     est_sisonglaz                    (numeric) Point estimate, Sison-Glaz method Confidence intervals
#     lwr_ci_sisonglaz                 (numeric) Lower bound of Sison-Glaz confidence interval
#     upr_ci_sisonglaz                 (numeric) Upper bound of Sison-Glaz confidence interval
#     est_qhurst_acswr                 (numeric) Point estimate, Queensbury-Hurst method Confidence intervals via ACSWR r package
#     lwr_ci_qhurst_acswr              (numeric) Lower bound of Queensbury-Hurst confidence interval
#     upr_ci_qhurst_acswr              (numeric) Upper bound of Queensbury-Hurst confidence interval
#     est_qhurst_coinmind              (numeric) Point estimate, Queensbury-Hurst method Confidence intervals via CoinMinD r package
#     lwr_ci_qhurst_coinmind           (numeric) Lower bound of Queensbury-Hurst confidence interval
#     upr_ci_qhurst_coinmind           (numeric) Upper bound of Queensbury-Hurst confidence interval
#     lwr_ci_qhurst_adj_coinmind       (numeric) Lower bound of Queensbury-Hurst confidence interval adjusted
#     upr_ci_qhurst_adj_coinmind       (numeric) Upper bound of Queensbury-Hurst confidence interval adjusted
#
# ------------------------------------------------------------------------------------

estimate_transmission_flows <- function(group_in,
                                        individuals_sampled_in,
                                        individuals_population_in,
                                        linkage_counts_in,
                                        detailed_report = FALSE,
                                        verbose_output = FALSE) {

	# Assemble dataset and prepare input to calculate p_hat
	# Reminder! p_hat denotes the probability that pathogen sequences from two individuals randomly sampled from their
	#           respective population groups are linked.

	results_prepare_input_for_get_p_hat <- tryCatch({

	    # Condition: Try and execute function prepare_input_for_get_p_hat() a.k.a prep_p_hat()

	    if (verbose_output) message("Executing function: prep_p_hat(). \n")

		prepare_input_for_get_p_hat(group_in,
								    individuals_sampled_in,
								    individuals_population_in,
								    linkage_counts_in,
								    verbose_output)

	    },

	    # Condition handler: If an error condition occurs:

	    error = function(condition) {

	        message("Execution of function: prep_p_hat() failed. \n")

	        conditionMessage(condition)

	        message("See ?prep_p_hat() to execute step separately for debugging. \n")

	        # Exit function rather than chug-along
	        # return(NULL)
	        stop(condition)

	    },

        # Statements to execute at the end regardless of success or error.

	    finally = NULL

	)

	# Calculate p_hat

	results_get_p_hat <- tryCatch({

	    # Condition: Try and execute function get_p_hat() a.k.a estimate_p_hat()

	    if (verbose_output) message("Executing function: estimate_p_hat(). \n")

        get_p_hat(results_prepare_input_for_get_p_hat)

	    },

	    # Condition handler: If an error condition occurs:

	    error = function(condition) {

	        message("Execution of function: estimate_p_hat() failed. \n")

	        conditionMessage(condition)

	        message("See ?estimate_p_hat() to execute step separately for debugging. \n")

	        # Exit function rather than chug-along
	        # return(NULL)
	        stop(condition)

	    },

        # Statements to execute at the end regardless of success or error.

	    finally = NULL

	)

	if (detailed_report) {

		# Calculate the probability that a pair of pathogen sequences is from a specific
		# population group pairing and is linked

		results_get_prob_group_pairing_and_linked <- tryCatch({

			# Condition: Try and execute function get_prob_group_pairing_and_linked() a.k.a estimate_prob_group_pairing_and_linked()

			if (verbose_output) message("Executing function: estimate_prob_group_pairing_and_linked(). \n")

			get_prob_group_pairing_and_linked(results_get_p_hat, individuals_population_in, verbose_output)

			},

			# Condition handler: If an error condition occurs:

			error = function(condition) {

				message("Execution of function: estimate_prob_group_pairing_and_linked() failed. \n")

				conditionMessage(condition)

				message("See ?estimate_prob_group_pairing_and_linked() to execute step separately for debugging. \n")

				# Exit function rather than chug-along
				# return(NULL)
				stop(condition)

			},

			# Statements to execute at the end regardless of success or error.

			finally = NULL

		)

		# Calculate theta_hat, the probability that a pair of pathogen sequences is from
		# a specific population group pairing given that the pair is linked

		results_get_theta_hat <- tryCatch({

			# Condition: Try and execute function get_theta_hat() a.k.a estimate_theta_hat()

			if (verbose_output) message("Executing function: estimate_theta_hat(). \n")

			get_theta_hat(results_get_prob_group_pairing_and_linked)

			},

			# Condition handler: If an error condition occurs:

			error = function(condition) {

				message("Execution of function: estimate_theta_hat() failed. \n")

				conditionMessage(condition)

				message("See ?estimate_theta_hat() to execute step separately for debugging. \n")

				# Exit function rather than chug-along
				# return(NULL)
				stop(condition)

			},

			# Statements to execute at the end regardless of success or error.

			finally = NULL

		)

		# Calculate c_hat, the probability that a randomly selected pathogen sequence
		# in one population group links to at least one pathogen sequence in another
		# population group i.e. probability of clustering. This excludes linkage to
		# itself when clustering is estimated within populaton groups.

		results_get_c_hat <- tryCatch({

			# Condition: Try and execute function get_c_hat() a.k.a estimate_c_hat()

			if (verbose_output) message("Executing function: estimate_c_hat(). \n")

			get_c_hat(results_get_theta_hat)

			},

			# Condition handler: If an error condition occurs:

			error = function(condition) {

				message("Execution of function: estimate_c_hat() failed. \n")

				conditionMessage(condition)

				message("See ?estimate_c_hat() to execute step separately for debugging. \n")

				# Exit function rather than chug-along
				# return(NULL)
				stop(condition)

			},

			# Statements to execute at the end regardless of success or error.

			finally = NULL

		)

		# Calculate simultaneous confidence intervals at the 5% significance level

		output <- tryCatch({

			# Condition: Try and execute function get_multinomial_proportion_conf_ints_extended() a.k.a estimate_multinom_ci()

			if (verbose_output) message("Executing function: estimate_multinom_ci(). \n")

			get_multinomial_proportion_conf_ints_extended(results_get_c_hat, detailed_report = TRUE)

			},

			# Condition handler: If an error condition occurs:

			error = function(condition) {

				message("Execution of function: estimate_multinom_ci() failed. \n")

				conditionMessage(condition)

				message("See ?estimate_multinom_ci() to execute step separately for debugging. \n")

				# Exit function rather than chug-along
				# return(NULL)
				stop(condition)

			},

			# Statements to execute at the end regardless of success or error.

			finally = NULL

		)

	} else {

		# Calculate theta_hat, the probability that a pair of pathogen sequences is from
		# a specific population group pairing given that the pair is linked

		results_get_theta_hat <- tryCatch({

			# Condition: Try and execute function get_theta_hat() a.k.a estimate_theta_hat()

			if (verbose_output) message("Executing function: estimate_theta_hat(). \n")

			results_get_theta_hat <- get_theta_hat(results_get_p_hat)

			},

			# Condition handler: If an error condition occurs:

			error = function(condition) {

				message("Execution of function: estimate_theta_hat() failed. \n")

				conditionMessage(condition)

				message("See ?estimate_theta_hat() to execute step separately for debugging. \n")

				# Exit function rather than chug-along
				# return(NULL)
				stop(condition)

			},

			# Statements to execute at the end regardless of success or error.

			finally = NULL

		)

		# Calculate simultaneous confidence intervals at the 5% significance level with the Goodman method

		output <- tryCatch({

			# Condition: Try and execute function get_multinomial_proportion_conf_ints_extended() a.k.a estimate_multinom_ci()

			if (verbose_output) message("Executing function: estimate_multinom_ci(). \n")

			get_multinomial_proportion_conf_ints_extended(results_get_theta_hat, detailed_report = FALSE)

			},

			# Condition handler: If an error condition occurs:

			error = function(condition) {

				message("Execution of function: estimate_multinom_ci() failed. \n")

				conditionMessage(condition)

				message("See ?estimate_multinom_ci() to execute step separately for debugging. \n")

				# Exit function rather than chug-along
				# return(NULL)
				stop(condition)

			},

			# Statements to execute at the end regardless of success or error.

			finally = NULL

		)

	}

	# List of items to return
	base::list(flows_dataset = output)

}

# Function: prepare_input_for_get_p_hat ---------------------------
#
# goal: Generate variables required for calculating p_hat
#
# parameters:
#
#
#   group_in                  (character) A vector indicating population groups/strata (e.g. communities, age-groups, genders or trial arms) between which transmission flows will be evaluated,
#   individuals_sampled_in    (numeric)   A vector indicating the number of individuals sampled per population group,
#   individuals_population_in (numeric)   A vector of the estimated number of individuals per population group,
#   linkage_counts_in                     A data.frame of counts of linked pairs identified between samples of each population pairing of interest.
#                                         The data.frame should contain the following three fields: H1_group (character), H2_group (character), number_linked_pairs_observed (numeric).
#                                         For a population group pairing, H1_group and H2_group denote population groups 1 and 2 respectively;
#                                         and number_linked_pairs_observed denotes the number of observed directed transmission pairs between samples from population groups 1 and 2.
#   verbose_output            (boolean)   A value to display intermediate output
#
#
# returns: a data.frame containing:
#
#
#     H1_group                         (Factor)  Name of population group 1
#     H2_group                         (Factor)  Name of population group 2
#     number_hosts_sampled_group_1     (numeric) Number of individuals sampled from population group 1
#     number_hosts_sampled_group_2     (numeric) Number of individuals sampled from population group 2
#     number_hosts_population_group_1  (numeric) Estimated number of individuals in population group 1
#     number_hosts_population_group_2  (numeric) Estimated number of individuals in population group 2
#     max_possible_pairs_in_sample     (numeric) Number of distinct possible transmission pairs between individuals sampled from population groups 1 and 2
#     max_possible_pairs_in_population (numeric) Number of distinct possible transmission pairs between individuals in population groups 1 and 2
#     num_linked_pairs_observed        (numeric) Number of observed directed transmission pairs between samples from population groups 1 and 2
#
# ------------------------------------------------------------------------------------

prepare_input_for_get_p_hat <- function(group_in,
                                        individuals_sampled_in,
                                        individuals_population_in,
                                        linkage_counts_in,
                                        verbose_output = FALSE) {

	# Assemble dataset
	group <- base::factor(group_in)

	individuals_sampled <- base::as.numeric(individuals_sampled_in)

	individuals_population <- base::as.numeric(individuals_population_in)

	m <- base::data.frame(group, individuals_sampled, individuals_population)

    # View dataset structure
	if (verbose_output) utils::str(m)

	# Calculate number of groups
	n_groups <- base::nlevels(m$group)

	# Get all possible group pairings
	group_permutations <- base::data.frame(gtools::permutations(n_groups, 2, base::as.character(m$group), repeats.allowed = TRUE))

	base::names(group_permutations) <- base::c("H1_group", "H2_group")

    # View dataset structure
	if (verbose_output) utils::str(group_permutations)

	get_max_possible_pairs <- function(df_group_permutations, df_number_hosts_per_group) {

        if (verbose_output) {

			base::writeLines("\nstr(df_group_permutations): \n")
			utils::str(df_group_permutations)

			base::writeLines("str(df_number_hosts_per_group): \n")
			utils::str(df_number_hosts_per_group)

        }

		# Calculate max distinct possible pairs in sample for each group pairing

		group_1 <- df_group_permutations[["H1_group"]]
		num_hosts_group_1 <- df_number_hosts_per_group$individuals_sampled[df_number_hosts_per_group$group == group_1]

        if (verbose_output) {

			base::writeLines(paste0("\nNumber of hosts in group 1: ", group_1, "\n"))
			base::print(num_hosts_group_1)

        }

		group_2 <- df_group_permutations[["H2_group"]]
		num_hosts_group_2 <- df_number_hosts_per_group$individuals_sampled[df_number_hosts_per_group$group == group_2]

        if (verbose_output) {

			base::writeLines(paste0("\nNumber of hosts in group 2: ", group_2, "\n"))
			base::print(num_hosts_group_2)

        }

		if (verbose_output) base::writeLines("Max distinct possible linked pairs in sample for current group pairing i.e. individuals_sampled_group_1 * individuals_sampled_group_2: \n")
		if (group_1 == group_2 & !(num_hosts_group_1 == 1)) {

		    max_possible_pairs_in_sample <- (num_hosts_group_1 * (num_hosts_group_1 - 1)) / 2

		} else {

		    max_possible_pairs_in_sample <- num_hosts_group_1 * num_hosts_group_2

		}

		if (verbose_output) base::print(max_possible_pairs_in_sample)

		# Calculate max distinct possible pairs in population for each group pairing

        individuals_population_group_1 <- df_number_hosts_per_group$individuals_population[df_number_hosts_per_group$group == group_1]

		if (verbose_output) {

		    base::writeLines("\nEstimated number of individuals in population group 1: \n")
		    base::print(individuals_population_group_1)
		}

        individuals_population_group_2 <- df_number_hosts_per_group$individuals_population[df_number_hosts_per_group$group == group_2]

		if (verbose_output) {

		    base::writeLines("\nEstimated number of individuals in population group 2: \n")
		    base::print(individuals_population_group_2)
		}

		if (verbose_output) base::writeLines("Max distinct possible linked pairs in population for current group pairing i.e. individuals_population_group_1 * individuals_population_group_2: \n")
		if (group_1 == group_2) {

		    max_possible_pairs_in_population <- (individuals_population_group_1 * (individuals_population_group_1 - 1)) / 2

		} else {

		    max_possible_pairs_in_population <- individuals_population_group_1 * individuals_population_group_2

		}

		if (verbose_output) base::print(max_possible_pairs_in_population)

		output <- data.frame("H1_group" = group_1, "H2_group" = group_2, "number_hosts_sampled_group_1" = num_hosts_group_1, "number_hosts_sampled_group_2" = num_hosts_group_2, "number_hosts_population_group_1" = individuals_population_group_1, "number_hosts_population_group_2" = individuals_population_group_2, max_possible_pairs_in_sample, max_possible_pairs_in_population)

		output

	}

	result_get_max_possible_pairs <- base::apply(group_permutations, 1, get_max_possible_pairs, m)

    # Assemble entries in list: result_get_max_possible_pairs into a data.frame using row bind
	number_hosts_per_group_pairing <- base::data.frame()

	for (item in base::seq_along(result_get_max_possible_pairs)) { number_hosts_per_group_pairing <- base::rbind(number_hosts_per_group_pairing, result_get_max_possible_pairs[[item]]) }

    # Attach counts for the number of highly supported linked pairs observed between each group pairing

	# Important! Number of observed links was set to zero where no linked pairs were detected by phyloscanner
	#     between group pairings

    number_hosts_per_group_pairing <- dplyr::left_join(number_hosts_per_group_pairing, linkage_counts_in, by = c("H1_group", "H2_group"))
    number_hosts_per_group_pairing$num_linked_pairs_observed[is.na(number_hosts_per_group_pairing$num_linked_pairs_observed)] <- 0

	number_hosts_per_group_pairing

}

# Function: get_p_hat ---------------------------
#
# Goal: Compute probability that pathogen sequences from two individuals randomly sampled from their respective
#       population groups (e.g. communities, age-groups, genders or trial arms) are linked.
#
#       Example: For a group pairing (u,v) this would be the fraction of distinct possible
#                pairs between samples from groups u and v that are linked. Note: The number
#                of distinct possible (u,v) pairs in the sample is the product of sampled
#                individuals in groups u and v. If u = v, distinct possible pairs is the
#                number of individuals sampled in population group u choose 2.
#
# parameters:
#
#     df_counts                                  A data.frame returned by the function:
#                                                prepare_input_for_get_p_hat()
#
#
# returns: a data.frame containing:
#
#
#     H1_group                         (Factor)  Name of population group 1
#     H2_group                         (Factor)  Name of population group 2
#     number_hosts_sampled_group_1     (numeric) Number of individuals sampled from population group 1
#     number_hosts_sampled_group_2     (numeric) Number of individuals sampled from population group 2
#     number_hosts_population_group_1  (numeric) Estimated number of individuals in population group 1
#     number_hosts_population_group_2  (numeric) Estimated number of individuals in population group 2
#     max_possible_pairs_in_sample     (numeric) Number of distinct possible transmission pairs between individuals sampled from population groups 1 and 2
#     max_possible_pairs_in_population (numeric) Number of distinct possible transmission pairs between individuals in population groups 1 and 2
#     num_linked_pairs_observed        (numeric) Number of observed directed transmission pairs between samples from population groups 1 and 2
#     p_hat                            (numeric) Probability that pathogen sequences from two individuals randomly sampled from their respective population groups are linked
#
# ------------------------------------------------------------------------------------

get_p_hat <- function(df_counts) {

    df_counts$p_hat <- df_counts$num_linked_pairs_observed / df_counts$max_possible_pairs_in_sample

    df_counts

}

# Function: get_prob_group_pairing_and_linked ---------------------------
#
# Goal: Compute probability that a pair is from a specific population group pairing and is linked.
#       Example: For a group pairing (u,v), prob. that a pair is from (u,v) and linked is:
#                (N_uv / N_choose_2) * p_hat_uv
#       where:
#       N_uv = N_u * N_v i.e. maximum distinct possible (u,v) pairs in population.
#       p_hat_uv = fraction of observed (u,v) pairs between samples from population groups
#                  u and v that are linked.
#       N choose 2 or (N * (N - 1))/2 i.e. all distinct possible pairs in population.
#
# parameters:
#
#     df_counts_and_p_hat                        A data.frame returned by function:
#                                                get_p_hat()
#     individuals_population_in        (numeric) A vector of the estimated number of individuals
#                                                per population group
#     verbose_output                   (boolean) A value to display intermediate output
#
#
# returns: a data.frame containing:
#
#
#     H1_group                         (Factor)  Name of population group 1
#     H2_group                         (Factor)  Name of population group 2
#     number_hosts_sampled_group_1     (numeric) Number of individuals sampled from population group 1
#     number_hosts_sampled_group_2     (numeric) Number of individuals sampled from population group 2
#     number_hosts_population_group_1  (numeric) Estimated number of individuals in population group 1
#     number_hosts_population_group_2  (numeric) Estimated number of individuals in population group 2
#     max_possible_pairs_in_sample     (numeric) Number of distinct possible transmission pairs between individuals sampled from population groups 1 and 2
#     max_possible_pairs_in_population (numeric) Number of distinct possible transmission pairs between individuals in population groups 1 and 2
#     num_linked_pairs_observed        (numeric) Number of observed directed transmission pairs between samples from population groups 1 and 2
#     p_hat                            (numeric) Probability that pathogen sequences from two individuals randomly sampled from their respective population groups are linked
#     prob_group_pairing_and_linked    (numeric) Probability that a pair of pathogen sequences is from a specific population group pairing and is linked
#
# ------------------------------------------------------------------------------------

get_prob_group_pairing_and_linked <- function(df_counts_and_p_hat, individuals_population_in,
                                              verbose_output = FALSE) {

    # View dataset structure
	if (verbose_output) utils::str(df_counts_and_p_hat)

    # Sum up estimated number of individuals in each population group to get total population
	individuals_population <- base::as.numeric(individuals_population_in)
    individuals_population_total <- base::sum(individuals_population)
    if (verbose_output) base::print(individuals_population_total)

    # Get all distinct possible pairs in population
    max_possible_pairs_in_total_population <- (individuals_population_total * (individuals_population_total - 1)) / 2

    df_counts_and_p_hat$prob_group_pairing_and_linked <- (df_counts_and_p_hat$max_possible_pairs_in_population / max_possible_pairs_in_total_population) * df_counts_and_p_hat$p_hat

    df_counts_and_p_hat

}

# Function: get_theta_hat ---------------------------
#
# Goal: Compute the conditional probability that a pair is from a specific population group
#       pairing given the pair is linked.
#       Example: For a group pairing (u,v), theta_hat denotes estimated transmission
#                flows within and between population groups u and v adjusted for sampling
#                heterogeneity.
#
# parameters:
#
#     df_counts_and_p_hat                        A data.frame returned by the function:
#                                                get_p_hat()
#
# returns: a data.frame containing:
#
#
#     H1_group                         (Factor)  Name of population group 1
#     H2_group                         (Factor)  Name of population group 2
#     number_hosts_sampled_group_1     (numeric) Number of individuals sampled from population group 1
#     number_hosts_sampled_group_2     (numeric) Number of individuals sampled from population group 2
#     number_hosts_population_group_1  (numeric) Estimated number of individuals in population group 1
#     number_hosts_population_group_2  (numeric) Estimated number of individuals in population group 2
#     max_possible_pairs_in_sample     (numeric) Number of distinct possible transmission pairs between individuals sampled from population groups 1 and 2
#     max_possible_pairs_in_population (numeric) Number of distinct possible transmission pairs between individuals in population groups 1 and 2
#     num_linked_pairs_observed        (numeric) Number of observed directed transmission pairs between samples from population groups 1 and 2
#     p_hat                            (numeric) Probability that pathogen sequences from two individuals randomly sampled from their respective population groups are linked
#     est_linkedpairs_in_population    (numeric) Estimated transmission pairs between population groups 1 and 2
#     theta_hat                        (numeric) Estimated transmission flows or relative probability of transmission within and between population groups 1 and 2 adjusted
#                                                for sampling heterogeneity. More precisely, the conditional probability that a pair of pathogen sequences is from a specific population
#                                                group pairing given that the pair is linked.
#
# ------------------------------------------------------------------------------------

get_theta_hat <- function(df_counts_and_p_hat) {

	df_counts_and_p_hat$est_linkedpairs_in_population <- df_counts_and_p_hat$max_possible_pairs_in_population * df_counts_and_p_hat$p_hat

	df_counts_and_p_hat$theta_hat <- df_counts_and_p_hat$est_linkedpairs_in_population / base::sum(df_counts_and_p_hat$est_linkedpairs_in_population)

	df_counts_and_p_hat

}

# Function: get_c_hat ---------------------------
#
# Goal: Compute c_hat, for a group pairing (u,v) c_hat is the probability that a pathogen sequence from
#       an individual in population group u links with pathogen sequences from one or more other individuals
#       in population group v (excluding itself if u = v) i.e. probability of clustering.
#
# parameters:
#
#     df_counts_and_p_hat                        A data.frame returned by the function:
#                                                get_p_hat()
#
# returns: a data.frame containing:
#
#
#     H1_group                         (Factor)  Name of population group 1
#     H2_group                         (Factor)  Name of population group 2
#     number_hosts_sampled_group_1     (numeric) Number of individuals sampled from population group 1
#     number_hosts_sampled_group_2     (numeric) Number of individuals sampled from population group 2
#     number_hosts_population_group_1  (numeric) Estimated number of individuals in population group 1
#     number_hosts_population_group_2  (numeric) Estimated number of individuals in population group 2
#     max_possible_pairs_in_sample     (numeric) Number of distinct possible transmission pairs between individuals sampled from population groups 1 and 2
#     max_possible_pairs_in_population (numeric) Number of distinct possible transmission pairs between individuals in population groups 1 and 2
#     num_linked_pairs_observed        (numeric) Number of observed directed transmission pairs between samples from population groups 1 and 2
#     p_hat                            (numeric) Probability that pathogen sequences from two individuals randomly sampled from their respective population groups are linked
#     c_hat                            (numeric) Probability that a randomly selected pathogen sequence in one population group links to at least
#                                                one pathogen sequence in another population group i.e. probability of clustering
#
# ------------------------------------------------------------------------------------

get_c_hat <- function(df_counts_and_p_hat) {

	df_counts_and_p_hat$c_hat <- 1 - ((1 - df_counts_and_p_hat$p_hat) ^ df_counts_and_p_hat$number_hosts_population_group_2)

	df_counts_and_p_hat

}

# Calculate simultaneous confidence intervals for a multinomial proportion
#---------------------------

# Function: get_multinomial_proportion_conf_ints ---------------------------
#
# Goal: Compute simultaneous confidence intervals at the 5% significance level
#
# Reminder: Goodman CIs work for fewer cells with larger counts and Sison-Glaz many cells with smaller counts
#
# parameters:
#
#     df_theta_hat                               A data.frame returned by the function:
#                                                get_theta_hat()
#     detailed_report                  (boolean) A value to produce detailed output of the analysis
#
# returns: a data.frame containing:
#
#
#     H1_group                         (Factor)  Name of population group 1
#     H2_group                         (Factor)  Name of population group 2
#     number_hosts_sampled_group_1     (numeric) Number of individuals sampled from population group 1
#     number_hosts_sampled_group_2     (numeric) Number of individuals sampled from population group 2
#     number_hosts_population_group_1  (numeric) Estimated number of individuals in population group 1
#     number_hosts_population_group_2  (numeric) Estimated number of individuals in population group 2
#     max_possible_pairs_in_sample     (numeric) Number of distinct possible transmission pairs between individuals sampled from population groups 1 and 2
#     max_possible_pairs_in_population (numeric) Number of distinct possible transmission pairs between individuals in population groups 1 and 2
#     num_linked_pairs_observed        (numeric) Number of observed directed transmission pairs between samples from population groups 1 and 2
#     p_hat                            (numeric) Probability that pathogen sequences from two individuals randomly sampled from their respective population groups are linked
#     est_linkedpairs_in_population    (numeric) Estimated transmission pairs between population groups 1 and 2
#     theta_hat                        (numeric) Estimated transmission flows or relative probability of transmission within and between population groups 1 and 2 adjusted
#                                                for sampling heterogeneity. More precisely, the conditional probability that a pair of pathogen sequences is from a specific population
#                                                group pairing given that the pair is linked.
#     obs_trm_pairs_est_goodman        (numeric) Point estimate, Goodman method Confidence intervals for observed transmission pairs
#     obs_trm_pairs_lwr_ci_goodman     (numeric) Lower bound of Goodman confidence interval
#     obs_trm_pairs_upr_ci_goodman     (numeric) Upper bound of Goodman confidence interval
#     est_goodman                      (numeric) Point estimate, Goodman method Confidence intervals for estimated transmission flows
#     lwr_ci_goodman                   (numeric) Lower bound of Goodman confidence interval
#     upr_ci_goodman                   (numeric) Upper bound of Goodman confidence interval
#
#
# The following additional fields are returned if the detailed_report
#     flag is set
#
#     est_goodman_cc                   (numeric) Point estimate, Goodman method Confidence intervals with continuity correction
#     lwr_ci_goodman_cc                (numeric) Lower bound of Goodman confidence interval
#     upr_ci_goodman_cc                (numeric) Upper bound of Goodman confidence interval
#     est_sisonglaz                    (numeric) Point estimate, Sison-Glaz method Confidence intervals
#     lwr_ci_sisonglaz                 (numeric) Lower bound of Sison-Glaz confidence interval
#     upr_ci_sisonglaz                 (numeric) Upper bound of Sison-Glaz confidence interval
#     est_qhurst_acswr                 (numeric) Point estimate, Queensbury-Hurst method Confidence intervals via ACSWR r package
#     lwr_ci_qhurst_acswr              (numeric) Lower bound of Queensbury-Hurst confidence interval
#     upr_ci_qhurst_acswr              (numeric) Upper bound of Queensbury-Hurst confidence interval
#     est_qhurst_coinmind              (numeric) Point estimate, Queensbury-Hurst method Confidence intervals via CoinMinD r package
#     lwr_ci_qhurst_coinmind           (numeric) Lower bound of Queensbury-Hurst confidence interval
#     upr_ci_qhurst_coinmind           (numeric) Upper bound of Queensbury-Hurst confidence interval
#     lwr_ci_qhurst_adj_coinmind       (numeric) Lower bound of Queensbury-Hurst confidence interval adjusted
#     upr_ci_qhurst_adj_coinmind       (numeric) Upper bound of Queensbury-Hurst confidence interval adjusted
#
# ------------------------------------------------------------------------------------

get_multinomial_proportion_conf_ints_extended <- function(df_theta_hat, detailed_report = FALSE) {

    # Extend MultinomCI function in DescTools to compute Goodman confidence intervals
    # with a continuity correction i.e. goodmancc.
    # Acknowledgements:
    # (Steve Cherry, 1996) A Comparison of Confidence Interval Methods for Habitat Use-Availability Studies.
    # The Journal of Wildlife Management, Jul., 1996, Vol. 60, No. 3 (Jul., 1996), pp. 653-658
    # Goodman continuity correction described on pg. 655

	# Define function:
	MultinomCI_mod <- function (x, conf.level = 0.95, sides = c("two.sided", "left",
		"right"), method = c("sisonglaz", "cplus1", "goodman", "goodmancc",
		"wald", "waldcc", "wilson")) {

		.moments <- function(c, lambda) {
			a <- lambda + c
			b <- lambda - c
			if (b < 0)
				b <- 0
			if (b > 0)
				den <- stats::ppois(a, lambda) - stats::ppois(b - 1, lambda)
			if (b == 0)
				den <- stats::ppois(a, lambda)
			mu <- mat.or.vec(4, 1)
			mom <- mat.or.vec(5, 1)
			for (r in 1:4) {
				poisA <- 0
				poisB <- 0
				if ((a - r) >= 0) {
					poisA <- stats::ppois(a, lambda) - stats::ppois(a - r, lambda)
				}
				if ((a - r) < 0) {
					poisA <- stats::ppois(a, lambda)
				}
				if ((b - r - 1) >= 0) {
					poisB <- stats::ppois(b - 1, lambda) - stats::ppois(b - r -
					  1, lambda)
				}
				if ((b - r - 1) < 0 && (b - 1) >= 0) {
					poisB <- stats::ppois(b - 1, lambda)
				}
				if ((b - r - 1) < 0 && (b - 1) < 0) {
					poisB <- 0
				}
				mu[r] <- (lambda^r) * (1 - (poisA - poisB)/den)
			}
			mom[1] <- mu[1]
			mom[2] <- mu[2] + mu[1] - mu[1]^2
			mom[3] <- mu[3] + mu[2] * (3 - 3 * mu[1]) + (mu[1] -
				3 * mu[1]^2 + 2 * mu[1]^3)
			mom[4] <- mu[4] + mu[3] * (6 - 4 * mu[1]) + mu[2] * (7 -
				12 * mu[1] + 6 * mu[1]^2) + mu[1] - 4 * mu[1]^2 +
				6 * mu[1]^3 - 3 * mu[1]^4
			mom[5] <- den
			return(mom)
		}
		.truncpoi <- function(c, x, n, k) {
			m <- matrix(0, k, 5)
			for (i in 1L:k) {
				lambda <- x[i]
				mom <- .moments(c, lambda)
				for (j in 1L:5L) {
					m[i, j] <- mom[j]
				}
			}
			for (i in 1L:k) {
				m[i, 4] <- m[i, 4] - 3 * m[i, 2]^2
			}
			s <- colSums(m)
			s1 <- s[1]
			s2 <- s[2]
			s3 <- s[3]
			s4 <- s[4]
			probn <- 1/(stats::ppois(n, n) - stats::ppois(n - 1, n))
			z <- (n - s1)/sqrt(s2)
			g1 <- s3/(s2^(3/2))
			g2 <- s4/(s2^2)
			poly <- 1 + g1 * (z^3 - 3 * z)/6 + g2 * (z^4 - 6 * z^2 +
				3)/24
			+g1^2 * (z^6 - 15 * z^4 + 45 * z^2 - 15)/72
			f <- poly * exp(-z^2/2)/(sqrt(2) * gamma(0.5))
			probx <- 1
			for (i in 1L:k) {
				probx <- probx * m[i, 5]
			}
			return(probn * probx * f/sqrt(s2))
		}
		n <- sum(x, na.rm = TRUE)
		k <- length(x)
		p <- x/n
		if (missing(method))
			method <- "sisonglaz"
		if (missing(sides))
			sides <- "two.sided"
		sides <- match.arg(sides, choices = c("two.sided", "left",
			"right"), several.ok = FALSE)
		if (sides != "two.sided")
			conf.level <- 1 - 2 * (1 - conf.level)
		method <- match.arg(arg = method, choices = c("sisonglaz",
			"cplus1", "goodman", "goodmancc", "wald", "waldcc", "wilson"))
		if (method == "goodman") {
			q.chi <- stats::qchisq(conf.level, k - 1)
			lci <- (q.chi + 2 * x - sqrt(q.chi * (q.chi + 4 * x *
				(n - x)/n)))/(2 * (n + q.chi))
			uci <- (q.chi + 2 * x + sqrt(q.chi * (q.chi + 4 * x *
				(n - x)/n)))/(2 * (n + q.chi))
			res <- cbind(est = p, lwr.ci = pmax(0, lci), upr.ci = pmin(1,
				uci))
		}
		else if (method == "goodmancc") {
			q.chi <- stats::qchisq(conf.level, k - 1)
			lci <- (q.chi + 2 * (x - 0.5) - sqrt(q.chi * (q.chi + 4 * (x - 0.5) *
				(n - x + 0.5)/n)))/(2 * (n + q.chi))
			uci <- (q.chi + 2 * (x + 0.5) + sqrt(q.chi * (q.chi + 4 * (x + 0.5) *
				(n - x - 0.5)/n)))/(2 * (n + q.chi))
			res <- cbind(est = p, lwr.ci = pmax(0, lci), upr.ci = pmin(1,
				uci))
		}
		else if (method == "wald") {
			q.chi <- stats::qchisq(conf.level, 1)
			lci <- p - sqrt(q.chi * p * (1 - p)/n)
			uci <- p + sqrt(q.chi * p * (1 - p)/n)
			res <- cbind(est = p, lwr.ci = pmax(0, lci), upr.ci = pmin(1,
				uci))
		}
		else if (method == "waldcc") {
			q.chi <- stats::qchisq(conf.level, 1)
			lci <- p - sqrt(q.chi * p * (1 - p)/n) - 1/(2 * n)
			uci <- p + sqrt(q.chi * p * (1 - p)/n) + 1/(2 * n)
			res <- cbind(est = p, lwr.ci = pmax(0, lci), upr.ci = pmin(1,
				uci))
		}
		else if (method == "wilson") {
			q.chi <- stats::qchisq(conf.level, 1)
			lci <- (q.chi + 2 * x - sqrt(q.chi^2 + 4 * x * q.chi *
				(1 - p)))/(2 * (q.chi + n))
			uci <- (q.chi + 2 * x + sqrt(q.chi^2 + 4 * x * q.chi *
				(1 - p)))/(2 * (q.chi + n))
			res <- cbind(est = p, lwr.ci = pmax(0, lci), upr.ci = pmin(1,
				uci))
		}
		else {
			const <- 0
			pold <- 0
			for (cc in 1:n) {
				poi <- .truncpoi(cc, x, n, k)
				if (poi > conf.level && pold < conf.level) {
					const <- cc
					break
				}
				pold <- poi
			}
			delta <- (conf.level - pold)/(poi - pold)
			const <- const - 1
			if (method == "sisonglaz") {
				res <- cbind(est = p, lwr.ci = pmax(0, p - const/n),
					upr.ci = pmin(1, p + const/n + 2 * delta/n))
			}
			else if (method == "cplus1") {
				res <- cbind(est = p, lwr.ci = pmax(0, p - const/n -
					1/n), upr.ci = pmin(1, p + const/n + 1/n))
			}
		}
		if (sides == "left")
			res[3] <- 1
		else if (sides == "right")
			res[2] <- 0
		return(res)
	}

	# Acknowledgments
	# QH (Queensbury-Hurst) confidence intervals function sourced from CoinMinD package and tweaked
	#     to report and store the estimate and confidence intervals.
	# Default behaviour: Print confidence intervals to screen without reporting the estimate.

	# Define function:
	QH_coinmind_mod <- function(inpmat, alpha) {

		k = base::length(inpmat)
		s = base::sum(inpmat)
		chi = stats::qchisq(1 - alpha, df = k - 1)
		pi = inpmat / s
		QH.UL = (chi + 2 * inpmat + sqrt(chi * chi + 4 * inpmat *
			chi * (1 - pi)))/(2 * (chi + s))
		QH.LL = (chi + 2 * inpmat - sqrt(chi * chi + 4 * inpmat *
			chi * (1 - pi)))/(2 * (chi + s))
		LLA = 0
		ULA = 0
		for (r in 1:base::length(inpmat)) {
			if (QH.LL[r] < 0)
				LLA[r] = 0
			else LLA[r] = QH.LL[r]
			if (QH.UL[r] > 1)
				ULA[r] = 1
			else ULA[r] = QH.UL[r]
		}
		diA = ULA - LLA
		VOL = base::round(prod(diA), 8)

		output <- base::cbind("est_qhurst_coinmind" = pi, "lwr_ci_qhurst_coinmind" = QH.LL, "upr_ci_qhurst_coinmind" = QH.UL, "lwr_ci_qhurst_adj_coinmind" = LLA, "upr_ci_qhurst_adj_coinmind" = ULA)

		output

	}

	# Acknowledgments
	# QH (Queensbury-Hurst) confidence intervals function sourced from ACSWR package and tweaked
	#     to report the estimate as well as confidence intervals.
	# Default behaviour: Report confidence intervals without the estimate.

	# Define function:
	QH_CI_acswr_mod <- function(x, alpha) {

	  k <- base::length(x); n <- base::sum(x)

	  QH_est <- x / n

	  QH_lcl <- (1 / (2 * (base::sum(x) + stats::qchisq(1 - alpha / k, k - 1)))) *
		  {
			  stats::qchisq(1 - alpha / k, k - 1) + 2 * x - base::sqrt( stats::qchisq(1 - alpha / k, k - 1) *
			  (stats::qchisq(1 - alpha / k, k - 1) + 4 * x *(base::sum(x) - x) / base::sum(x)))

		  }

	  QH_ucl <- (1 / (2 * (base::sum(x) + stats::qchisq(1 - alpha / k, k - 1)))) *
		  {
			  stats::qchisq(1 - alpha / k, k - 1) + 2 * x + base::sqrt( stats::qchisq(1 - alpha / k, k - 1) *
			  (stats::qchisq(1 - alpha / k, k - 1) + 4 * x * (base::sum(x) - x) / base::sum(x)))
		  }

	  return(base::cbind("est_qhurst_acswr" = QH_est, "lwr_ci_qhurst_acswr" = QH_lcl, "upr_ci_qhurst_acswr" = QH_ucl))

	}

    # compute multi-nomial confidence intervals

    # Note: We scale the estimated transmission pairs in the population such that the sum of the weights
    #       is equal to the observed number of transmission pairs. This is a common approach in survey sampling.
    #       Basically, we express the estimated transmission pairs in the population as proportions then multiply
    #       by the sum of the observed counts
    weighted_est_linkedpairs_in_population <- (df_theta_hat$est_linkedpairs_in_population / base::sum(df_theta_hat$est_linkedpairs_in_population)) * base::sum(df_theta_hat$num_linked_pairs_observed)

    # compute Goodman confidence intervals for observed transmission events
    obs_trm_pairs_ci_goodman <- base::cbind(df_theta_hat, MultinomCI_mod(df_theta_hat$num_linked_pairs_observed, method="goodman"))
    obs_trm_pairs_ci_goodman <- obs_trm_pairs_ci_goodman %>% dplyr::rename(obs_trm_pairs_est_goodman = est, obs_trm_pairs_lwr_ci_goodman = lwr.ci, obs_trm_pairs_upr_ci_goodman = upr.ci)

 	# compute Goodman intervals
    df_theta_hat_goodman <- base::cbind(obs_trm_pairs_ci_goodman, MultinomCI_mod(weighted_est_linkedpairs_in_population, method="goodman"))
    df_theta_hat_goodman <- df_theta_hat_goodman %>% dplyr::rename(est_goodman = est, lwr_ci_goodman = lwr.ci, upr_ci_goodman = upr.ci)

    if (detailed_report) {

		# compute Goodman intervals with a continuity correction
		df_theta_hat_goodman_cc <- base::cbind(df_theta_hat_goodman, MultinomCI_mod(weighted_est_linkedpairs_in_population, method="goodmancc"))
		df_theta_hat_goodman_cc <- df_theta_hat_goodman_cc %>% dplyr::rename(est_goodman_cc = est, lwr_ci_goodman_cc = lwr.ci, upr_ci_goodman_cc = upr.ci)

		# compute Sison-Glaz intervals
		df_theta_hat_goodman_sisonglaz <- base::cbind(df_theta_hat_goodman_cc, MultinomCI_mod(weighted_est_linkedpairs_in_population, method="sisonglaz"))
		df_theta_hat_goodman_sisonglaz <- df_theta_hat_goodman_sisonglaz %>% dplyr::rename(est_sisonglaz = est, lwr_ci_sisonglaz = lwr.ci, upr_ci_sisonglaz = upr.ci)

		# compute Queensbury-Hurst intervals
		df_theta_hat_goodman_sisonglaz_qhurst_acswr <- base::cbind(df_theta_hat_goodman_sisonglaz, QH_CI_acswr_mod(weighted_est_linkedpairs_in_population, 0.05))

		df_theta_hat_goodman_sisonglaz_qhurst_acswr_coinmind <- base::cbind(df_theta_hat_goodman_sisonglaz_qhurst_acswr, QH_coinmind_mod(weighted_est_linkedpairs_in_population, 0.05))

		df_theta_hat_goodman_sisonglaz_qhurst_acswr_coinmind <- df_theta_hat_goodman_sisonglaz_qhurst_acswr_coinmind %>% dplyr::arrange(-num_linked_pairs_observed)

	    output <- df_theta_hat_goodman_sisonglaz_qhurst_acswr_coinmind

	} else {

        output <- df_theta_hat_goodman %>% dplyr::arrange(-num_linked_pairs_observed)

	}

    output

}


k_fold<-function(x,y,input){  # k= no of fold, x = data,y = target
    folds = createFolds(y,k=input$cv)
    acc_matrix = NULL #confusion matrix variable
    c_matrix = as.data.frame(as.data.frame.matrix(confusionMatrix(y,y)$table)) * 0
    if(identical(input$class_algo,"c_svm")){
        for(i in folds){
            model = svm(x[-i,],y[-i],cost=input$cost,kernel=input$kernel,degree=input$degree,coef0 = input$coef0)
            pred = predict(model,x[i,])
            table = confusionMatrix(y[i],pred)
            c_matrix = c_matrix + as.data.frame(as.data.frame.matrix(table$table))
            acc_matrix = rbind(acc_matrix,table$overall[1:2])
        }
    }
    if(identical(input$class_algo,"c_rf")){
        for(i in folds){
            model = randomForest(x[-i,],y[-i],ntree=input$ntree)
            pred = predict(model,x[i,])
            table = confusionMatrix(y[i],pred)
            c_matrix = c_matrix + as.data.frame(as.data.frame.matrix(table$table))
            acc_matrix = rbind(acc_matrix,table$overall[1:2])
        }
    }
    if(identical(input$class_algo,"c_nb")){
        for(i in folds){
            model = naiveBayes(x[-i,],y[-i])
            pred = predict(model,x[i,])
            table = confusionMatrix(y[i],pred)
            c_matrix = c_matrix + as.data.frame(as.data.frame.matrix(table$table))
            acc_matrix = rbind(acc_matrix,table$overall[1:2])
        }
    }
    fold = 1:input$cv
    acc_matrix = cbind(fold,acc_matrix)
    out<-NULL
    out$acc_matrix <- as.data.frame(acc_matrix)
    out$confusion_matrix <- c_matrix
    return(out)
}

train_test<-function(x,y,input){  # k= no of fold, x = data,y = target
    train_index = as.array(createDataPartition(y,p=input$split)$Resample1)
    acc_matrix = NULL #confusion matrix variable
    if(identical(input$class_algo,"c_svm")){
        model = svm(x[train_index,],y[train_index],cost=input$cost,kernel=input$kernel,degree=input$degree,coef0 = input$coef0)
        pred = predict(model,x[-train_index,])
        table = confusionMatrix(y[-train_index],pred)
        acc_matrix = rbind(acc_matrix,table$overall[1:2])
    }
    if(identical(input$class_algo,"c_rf")){
        model = randomForest(x[train_index,],y[train_index],ntree=input$ntree)
        pred = predict(model,x[-train_index,])
        table = confusionMatrix(y[-train_index],pred)
        acc_matrix = rbind(acc_matrix,table$overall[1:2])
    }
    if(identical(input$class_algo,"c_nb")){
        model = naiveBayes(x[train_index,],y[train_index])
        pred = predict(model,x[-train_index,])
        table = confusionMatrix(y[-train_index],pred)
        acc_matrix = rbind(acc_matrix,table$overall[1:2])
    }
    out<-NULL
    out$acc_matrix <- as.data.frame(acc_matrix)
    out$confusion_matrix <- as.data.frame(as.data.frame.matrix(table$table))
    return(out)
}

get_results<-function(input){
    if(input$cv>1){
        k_fold(x,y,input)
    }
    else{
        train_test(x,y,input)
    }
}


library(huge)
library(clime)
library(glasso)
library(Rcpp)
library(clime)
library(parallel)
sourceCpp("./sparseprec.cpp")
set.seed(129488374)
len=20
err<-matrix(0,len,3)
syst=matrix(0,len,3)
sparsity<-matrix(0,len,3)

n<-100
#d=50
dlist<- c(30,50,100,120) #,120,150)
reps=3
sequ=log(rev(seq(from=exp(.06),to=exp(0.4),length.out=len)))
err=syst=sparsity=array(0,dim=c(len,3,length(dlist),reps))
roc=array(0,dim=c(len,3,2,length(dlist),reps))

dnum=0
for(d in dlist){
print(paste("dim : ",d))
dnum=dnum+1
h<-huge.generator(2*n*reps,d,graph="random",.1)
#h<-huge.generator(2*n*reps,d,graph="scale-free")

sequ=log(rev(seq(from=exp(1e-1),to=exp(0.5),length.out=len)))
# if(d>n){
# sequ=log(rev(seq(from=exp(.2),to=exp(0.7),length.out=len)))
# }
x<-h$data
	for(r in 1:reps){
		print(paste("rep number " ,r))
		#x<- matrix(rexp(n*d),n,d)
		x1<-x[((r-1)*n+1) :(r*n),]
		x2<-x[(reps*n+((r-1)*n+1)) : (reps*n+(r*n)),]
		sigma=cor(x1)
		sigma2<-cor(x2)
		spar=h$sparsity*d*(d-1)/2
		k=0
		#for(i in sequ){
		out=mclapply(sequ,function(i){
			k=k+1
			syst=err=sparsity=numeric(3)
			roc=matrix(0,3,2)
			# quasr<-sparseprec(sigma,i)
			# gl<-glasso(sigma,i)$wi
			# clime<-clime(sigma,i)$Omega[[1]]
			syst[1]<-system.time(quasr<-sparseprec(sigma,i))[1]
			syst[2]<-system.time(gl<-glasso(sigma,i)$wi)[1]
			syst[3]<-system.time(clime<-clime(sigma,lambda=i*.8,sigma=T)$Omega[[1]])[1]
			err[1]<- sum(diag(quasr%*%sigma2))-log(det(quasr))
			err[2]<-sum(diag(gl%*%sigma2))-log(det(gl))
			err[3]<-sum(diag(clime%*%sigma2))-log(det(clime))
			#TN
			ind= row(quasr)<=(col(quasr)-1)
			roc[1,1]<-1-sum( (h$theta[ind]!=0) & (quasr[ind]==0) )/spar
			#TP
			roc[1,2]<- 1- sum( (quasr[ind]!=0) & (h$theta[ind]==0) )/(d*(d-1)/2-spar)
			roc[2,1]<-1-sum( (h$theta[ind]!=0) & (gl[ind]==0) )/spar
			roc[2,2]<- 1- sum( (gl[ind]!=0) & (h$theta[ind]==0) )/(d*(d-1)/2-spar)
			roc[3,1]<-1-sum( (h$theta[ind]!=0) & (abs(clime[ind])<1e-2) )/spar
			roc[3,2]<- 1- sum( (abs(clime[ind])>1e-2) & (h$theta[ind]==0) )/(d*(d-1)/2-spar)
			sparsity[1]<-(sum(quasr[ind]!=0))
			sparsity[2]<-(sum(gl[ind]!=0))
			sparsity[3]<-(sum(abs(clime[ind])>1e-2))
		return(list(syst=syst,err=err,roc=roc,sparsity=sparsity))
		},mc.cores=detectCores())
		k=0
		for(ll in 1:length(sequ)){

		k=k+1
		syst[k,1,dnum,r]<-out[[k]]$syst[1]
		syst[k,2,dnum,r]<-out[[k]]$syst[2]
		syst[k,3,dnum,r]<-out[[k]]$syst[3]

		err[k,1,dnum,r]<-out[[k]]$err[1]
		err[k,2,dnum,r]<-out[[k]]$err[2]
		err[k,3,dnum,r]<-out[[k]]$err[3]

		roc[k,1,1,dnum,r]<-out[[k]]$roc[1,1]
		roc[k,1,2,dnum,r]<-out[[k]]$roc[1,2]
		roc[k,2,1,dnum,r]<-out[[k]]$roc[2,1]
		roc[k,2,2,dnum,r]<-out[[k]]$roc[2,2]
		roc[k,3,1,dnum,r]<-out[[k]]$roc[3,1]
		roc[k,3,2,dnum,r]<-out[[k]]$roc[3,2]
		sparsity[k,1,dnum,r]<-out[[k]]$sparsity[1]
		sparsity[k,2,dnum,r]<-out[[k]]$sparsity[2]
		sparsity[k,3,dnum,r]<-out[[k]]$sparsity[3]

		}
			}

}

rocout<-array(0,dim=c(3,2,length(dlist),reps))
sparout<-array(0,dim=c(3,length(dlist),reps))
for(i in 1:3){
	for(j in 1:length(dlist)){
		for(k in 1:reps){
			rocout[i,,j,k]<- roc[apply(err,2:4,which.min)[i,j,k],i,,j,k]
			sparout[i,j,k]<- sparsity[apply(err,2:4,which.min)[i,j,k],i,j,k]
		}
	}
}

roctab<-apply(rocout,1:3,mean)

errtab=apply(apply(err,2:4,min),1:2,mean)
colnames(errtab)<-dlist
rownames(errtab)<-c("quasr","glasso","clime")
write.table(
	x=errtab,
	sep=",",
	file="Error.csv"
)

dplot=3

pdf("roc.pdf")
plot(apply(roc,1:4,mean)[,1,,dplot],type="l",xlim=c(0,1),ylim=c(0,1),col="red")
points(apply(roc,1:4,mean)[,2,,dplot],type="l",col="blue");
points(apply(roc,1:4,mean)[,3,,dplot],type="l",col="purple");

points(t(rocout[1,,dplot,]),col="red")
points(t(rocout[2,,dplot,]),col="blue")
points(t(rocout[3,,dplot,]),col="purple")

legend("bottomleft",c("quasr","glasso"),pch=1,col=c("red","blue"))
dev.off()

pdf("cpu.pdf")
plot(sequ,apply(syst,1:3,mean)[,1,dplot],pch=16,log="y",ylim=range(apply(syst,1:3,mean)[,1:3,dplot]),
ylab="CPU time (seconds (log))",xlab="# of included edges")
points(sequ,apply(syst,1:3,mean)[,2,dplot],pch=2,col="red")
points(sequ,apply(syst,1:3,mean)[,3,dplot],pch=2,col="red")

#points(sparsity[spind3,3],syst[spind3,3],pch=6,col="blue")
#abline(v=h$sparsity*d*(d-1)/2)
legend("topleft",c("new","glasso","clime"),pch=c(16,2,6))
dev.off()

pdf("regpath.pdf")
plot(sparsity[,1,dplot,1],err[,1,dplot,1],pch=10,
	ylim=range(err[,1:3,dplot,1]),
	xlim=range(sparsity[,1:3,dplot,1]+1),
	col="red",log="x",cex=.5)
points(sparsity[,2,dplot,1],err[,2,dplot,1],pch=13,col="blue",cex=.5)
points(sparsity[,3,dplot,1],err[,3,dplot,1],pch=5,col="purple",cex=.5)
abline(v=h$sparsity*dlist[dplot]*(dlist[dplot]-1)/2)
dev.off()

save.image("quasr.rdata")

# plot(sequ,err[,1],pch=10,ylim=range(err))
# points(sequ,err[,2],pch=13)
# abline(v=r)
# legend("topright",c("quasr","glasso"),pch=c(10,13))


# create a 10 die and a 20 sided die
die_10 <- 1:10
die_20 <- 1:20

# create a function to roll 7 of these dice and calculate the sum (use for loop)
roll_7 <- function (die){
  total <- 0
  for(i in 1:7) {
    dice <- sample(die, 1, replace=TRUE)
    total = total + sum(dice)
  }
  print(total)
}

# create a function to calculate how many were > 7 or > 17 (use if statement)
roll_7_count <- function (die, value){
  total <- 0
  count <- 0
  for(i in 1:7) {
    dice <- sample(die, 1, replace=TRUE)
    total = total + sum(dice)
    if (dice > value) count = count + 1
  }
  print(total)
  print(count)
}

# run
roll_7_count(die_10, 7)
roll_7_count(die_20, 17)


permutacao <- function(v0, v1) {
  u0 = sort(v0)
  u1 = sort(v1)
  saoIguais = all(u0 == u1)
  return(saoIguais)
}

if(permutacao(c(1, 2, 3), c(3, 2, 1))) {
  print("Permutação: sim")
} else {
  print("Permutação: não")
}


# Best ARIMA model for barometer difference with KNMI data

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]

  # Filter
  df <- df[PRESSURE_VALUE < 1100,]
  df <- df[PRESSURE_VALUE > 975,]

  # Meta data
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]

  data.table::setkey(df, TIMESTAMP_UTC)
  data.table::setattr(df, 'logger.name', logger.name)

  df
}

# from analysis 04, with  normalization
compare <- function(df1, df2) {
  if (nrow(df1) == 0L || nrow(df2) == 0L) return(data.table::data.table())

  diff.df <- df1[J(df2), .('PRESSURE_DIFF' = x.PRESSURE_VALUE - i.PRESSURE_VALUE,
                           TIMESTAMP_UTC, 'FILE' = x.FILE)][!is.na(PRESSURE_DIFF), ]

  # Normalization: makes sure the AR(1) component is not influenced by
  # differences in height.
  diff.df[, PRESSURE_DIFF := PRESSURE_DIFF - median(PRESSURE_DIFF)]

  data.table::setkey(diff.df, TIMESTAMP_UTC)

  diff.df
}

ref.compare <- function(logger.name, df = read.baro(logger.name)) {
  compare(df, read.baro('KNMI_20200312_hourly'))
}

# all barometers
df <- data.table::rbindlist(lapply(logger.names, ref.compare), use.names = TRUE, fill = TRUE)
data.table::setkey(df, FILE, TIMESTAMP_UTC)
df
ggplot2::ggplot(data = df, ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_DIFF, color = FILE)) +
  ggplot2::geom_line(show.legend = FALSE)
arima(df$PRESSURE_DIFF, order = c(1, 0, 0))
# Here the most impact has the AR(1) model, with relative big impact of AR(2) also.
# The AR(1) coefficient is here 0.83 at 12h intervals with sigma2 = 5.95.

# 65% non-drinfting barometers
analysis_10 <- data.table::fread(file = './drifts/analysis_10/baro_median_errors.csv')
analysis_10 <- analysis_10[order(WISK, decreasing = TRUE),]
dfw <- data.table::rbindlist(
  lapply(analysis_10[WISK <= quantile(WISK, probs = 0.65), FILE], ref.compare),
  use.names = TRUE, fill = TRUE
)
data.table::setkey(dfw, FILE, TIMESTAMP_UTC)
dfw
ggplot2::ggplot(data = dfw, ggplot2::aes(x = TIMESTAMP_UTC, y = PRESSURE_DIFF, color = FILE)) +
  ggplot2::geom_line(show.legend = FALSE)
arima(dfw$PRESSURE_DIFF, order = c(1, 0, 0))
# Here the most impact has the AR(1) model, after that the impact is not large.
# The AR(1) coefficient is here only 0.54 at 12h intervals with sigma2 = 2.13!
# That AR(1) is only 0.54 is not expected. According to theory, it should be the
# same as for the original barometer data, wich is around 0.88 for 12h intervals.

# The peculiar thing is that if I do not normalize the data, the coef is 0.89 with
# sigma2 = 2.625.


WilxTest <- function(dataMatrix, testIndexes, controlIndexes) {

  if (missing(dataMatrix) || missing(testIndexes) || missing(controlIndexes)) {
    cat("\nOne or more parameters are missing!\n")

  }else if(length(testIndexes) != length(controlIndexes)){
    cat("\nThe test and control indexes must be of same size\n")

  }
  else if(any(testIndexes >= (length(dataMatrix) - 1)) || any(testIndexes < 0) ||
          any(controlIndexes >= (length(dataMatrix) - 1) || any(controlIndexes < 0))){
    cat("\nThe test or control indexes point to out of matrix bounds!\n")
  }
  else{
    .Call('wilcoxonTestAdapter', dataMatrix, testIndexes, controlIndexes, PACKAGE = 'RcppWilcoxonTest')
  }
}


# -*- coding: utf-8 -*-

#' Created on Fri Apr 13 15:38:28 2018
#' R version 3.4.3 (2017-11-30)
#'
#' @author: Martins T.
#' @author: Mendes R.
#' @author: Santos R.
#'

# Libs --------------------------------------------------------------------
options(warn=-1)
source("src/packages.r")
include_packs(c("dygraphs","d3heatmap","rockchalk","forcats","rJava",
                "xlsxjars","xlsx","tidyverse","stringi","stringr","ggcorrplot",
                "sm","lubridate","magrittr","ggplot2","openxlsx","RColorBrewer",
                "psych","treemap","data.table","pROC","class",'gmodels','klaR',
                "C50","caret",'gmodels'))

# Load data ---------------------------------------------------------------
#Load normalized data xlsx
source("src/wrangling.r")
normalizedDataset <- xlsx::read.xlsx('datasets/normalizedDataset.xlsx',1, header= TRUE)

#Size - 50 independents variables
dim(normalizedDataset)

# Data Partition ----------------------------------------------------------
set.seed(375); trainingRowIndex <- sample(1:nrow(normalizedDataset),
                                          0.69*nrow(normalizedDataset))
#1000 records
trainData <- normalizedDataset[trainingRowIndex, ]
#remaining 450 records
testData <- normalizedDataset[-trainingRowIndex, ]

#checking propotion of target var
trainData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)
testData$isChurn %>%
  table() %>% prop.table() %>% {. * 100} %>% round(0)

#Save test_labels
test_labels <- as.factor(testData$isChurn)

#drop target from testData, not mandatory
drops <- c("isChurn")
testData <- testData[ , !(names(testData) %in% drops)]

# Logistic Regression -----------------------------------------------------

# Build Logistic Model
logitmod <- glm(isChurn ~. , family = "binomial", data=trainData)

summary(logitmod)

#predict testData
testData$prob <- predict(logitmod, testData, type = "response")

#plot roc and calculate auc
testData$isChurn <- test_labels
g <- roc(isChurn ~ prob, data =testData )
plot(g, col = 3, lty = 3, main = "ROC", xlim=c(1, 0))
print("All Variables");auc(g1)

# Recode factors
y_pred_num <- ifelse(testData$prob > 0.5, 1, 0)
y_pred <- factor(y_pred_num, levels=c(0, 1))

#confusionMatrix(pred, obs, positive = NULL,...), not the inverse
cm <- caret::confusionMatrix(y_pred, test_labels, positive = '1',
                       dnn=c("Pred","Actual"))
draw_confusion_matrix(cm)


./tests.verify: test performed on 2004.03.31

#### Test: ./tests.verify running wave1D_func1.py test_solver1  4 "'scalar'"
test_solver1(4, 'scalar')
CPU time: 0.04
Max value in final u:  8.0902e-01
CPU time of wave1D_func1.py: 0.3 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running wave1D_func1.py test_solver1  4 "'vectorized'"
test_solver1(4, 'vectorized')
CPU time: 0.01
Max value in final u:  8.0902e-01
CPU time of wave1D_func1.py: 0.2 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running wave1D_func1.py test_solver1c 4 "'vectorized'"
test_solver1c(4, 'vectorized')
CPU time: 0.01
Max value in final u:  8.0902e-01
CPU time of wave1D_func1.py: 0.3 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running wave1D_func1.py test_solver2  4 0
test_solver2(4, 0)
CPU time: 0.0
[array([   0.0000e+00,    8.6603e-01,    8.6603e-01,    0.0000e+00,
             -8.6603e-01,  -8.6603e-01,   0.0000e+00]), array([   0.0000e+00,  -4.3301e-01,  -4.3301e-01,    0.0000e+00,
               4.3301e-01,    4.3301e-01,    0.0000e+00]), array([   0.0000e+00,  -4.3301e-01,  -4.3301e-01,    0.0000e+00,
               4.3301e-01,    4.3301e-01,    0.0000e+00]), array([   0.0000e+00,    8.6603e-01,    8.6603e-01,    0.0000e+00,
             -8.6603e-01,  -8.6603e-01,    0.0000e+00]), array([   0.0000e+00,  -4.3301e-01,  -4.3301e-01,   0.0000e+00,
               4.3301e-01,    4.3301e-01,    0.0000e+00]), array([   0.0000e+00,  -4.3301e-01,  -4.3301e-01,    0.0000e+00,
               4.3301e-01,    4.3301e-01,    0.0000e+00]), array([   0.0000e+00,    8.6603e-01,    8.6603e-01,    0.0000e+00,
             -8.6603e-01,  -8.6603e-01,    0.0000e+00])]
CPU time of wave1D_func1.py: 0.2 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running wave1D_func1.py test_solver3 "'vectorized'"
test_solver3('vectorized')
Max error:  0.0000e+00
CPU time of wave1D_func1.py: 0.3 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running wave1D_func1.py test_solver_plug 0 "'vectorized'" 1500
test_solver_plug(0, 'vectorized', 1500)
CPU time: vectorized version = 1.37
error in computations
CPU time of wave1D_func1.py: 1.6 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running wave1D_func2.py test_radial_waves 0 '"vectorized"'
test_radial_waves(0, "vectorized")
CPU time vectorized version: 1.0
v[0] final time: -7.6151e-02
CPU time of wave1D_func2.py: 1.2 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running wave1D_class.py test_WaveEq1_plug 0 '"vectorized"'
test_WaveEq1_plug(0, "vectorized")
registered parameters:

dt
n
safety_factor
scheme_coding
tstop
user_action
bc_0
bc_L
c
f
I
L
registered parameters:

dt
n
safety_factor
scheme_coding
tstop
user_action
bc_0
bc_L
c
f
I
L
c=1 is assigned
bc_0=0 is assigned
f=0 is assigned
I=<function I at 0x410a379c> is assigned
user_action is not registered in
{'c': 1, 'bc_0': 0, 'f': 0, 'I': <function I at 0x410a379c>, 'L': 1, 'bc_L': 0}
user_action=<bound method SolverWithViz.action of <__main__.SolverWithViz instance at 0x410a148c>> is assigned
n is not registered in
{'c': 1, 'bc_0': 0, 'f': 0, 'I': <function I at 0x410a379c>, 'L': 1, 'bc_L': 0}
n=50 is assigned
bc_L=0 is assigned
tstop is not registered in
{'c': 1, 'bc_0': 0, 'f': 0, 'I': <function I at 0x410a379c>, 'L': 1, 'bc_L': 0}
tstop=9.95 is assigned
scheme_coding is not registered in
{'c': 1, 'bc_0': 0, 'f': 0, 'I': <function I at 0x410a379c>, 'L': 1, 'bc_L': 0}
scheme_coding=vectorized is assigned
f=<function <lambda> at 0x410a37d4> is assigned
bc_0 = <py4cs.numpytools.WrapNo2Callable instance at 0x410a15ec>
bc_L = <py4cs.numpytools.WrapNo2Callable instance at 0x410a18cc>
c = <py4cs.numpytools.WrapNo2Callable instance at 0x410a186c>
f = <function <lambda> at 0x410a37d4>
I = <function I at 0x410a379c>
L = 1
dt = 0.02
n = 50
safety_factor = 1.0
scheme_coding = vectorized
tstop = 9.95
user_action = <bound method SolverWithViz.action of <__main__.SolverWithViz instance at 0x410a148c>>
CPU time: 0.09
error in computations
CPU time of wave1D_class.py: 0.4 seconds on hplx30 i686, Linux


#' Drawing a sample from a fitted joint distribution
#'
#' @description
#' This function draws a random sample from an existing fitted Weibull-log-normal
#' (\code{wln}) or Heffernan-Tawn (\code{ht}) model for a given duration.
#'
#' @param jdistr a \code{wln} or \code{ht} joint distribution object, as the output from function \code{\link{fit_wln}}
#' and \code{\link{fit_ht}} respectively.
#'
#' @param sim_year the period of the simulate data in equivalent number of years.
#'
#' @param perturbed_ht_residuals whether or not to the simulation from the Heffernan-Tawn (\code{ht}) model should
#' add a perturbation when sampling from the empirical residual distribution (default value is \code{TRUE}).  This
#' argument is ignored when the input object is a Weibull-log-normal (\code{wln}) distribution.
#'
#' @return The function returns \code{data.table} object with two columns - wave
#' height \code{hs} and wave period and \code{tp}.
#'
#' @examples
#'
#' # Load data
#' data(ww3_pk)
#'
#' # Fit Heffernan-Tawn model with 0.95 marginal and dependence thresholds
#' ht = fit_ht(data = ww3_pk, npy = nrow(ww3_pk)/10, margin_thresh_count = 100, dep_thresh_count = 100)
#'
#' # Draw the equivalent of 100-year of data from the fitted Heffernan-Tawn model with or without perturbed residuals
#' sim_ht1 = sample_jdistr(jdistr = ht, sim_year = 100, perturbed_ht_residuals = FALSE)
#' sim_ht2 = sample_jdistr(jdistr = ht, sim_year = 100)
#' par(mfrow=c(1,2))
#' plot(sim_ht1, pch=20, cex=.5, main="HT without perturbation")
#' plot(sim_ht2, pch=20, cex=.5, main="HT with perturbation")
#'
#' # Fit Weibull-log-normal model
#' wln = fit_wln(data = ww3_pk, npy = nrow(ww3_pk)/10)
#'
#' # Draw the equivalent of 100-year of data from the fitted Weibull-log-normal model
#' sim_wln = sample_jdistr(jdistr = wln, sim_year = 100)
#' plot(sim_wln, pch=20, cex=.5, main="WLN")
#'
#' @seealso \code{\link{fit_ht}}, \code{\link{fit_wln}}
#'
#' @export
sample_jdistr = function(jdistr, sim_year, perturbed_ht_residuals = TRUE){

  if(class(jdistr)=="ht"){
    res = .sample_ht(jdistr, sim_year, perturbed_ht_residuals)
  }else if(class(jdistr)=="wln"){
    res = .sample_wln(jdistr, sim_year)
  }else{
    stop("Input class of distribution not supported.")
  }
  return(res)
}

# Heffernan-Tawn ----------------------------------------------------------
.sample_ht = function(ht, sim_year, perturbed_ht_residuals){

  set.seed(.seed_sampling)
  n_sim = sim_year*ht$npy

  # Sample overall freq
  res = ht$dep$dep_data[sample.int(.N, size = n_sim, replace = T), .(u_hs, u_tp)]
  rot_wb = res[, .N^(-1/6)]
  res[, u_hs:=pnorm(qnorm(u_hs)+rnorm(.N, 0, rot_wb))]
  res[, u_tp:=pnorm(qnorm(u_tp)+rnorm(.N, 0, rot_wb))]
  n_hs = res[u_hs>ht$dep$p_dep_thresh & u_hs>u_tp, .N]
  n_tp = res[u_tp>ht$dep$p_dep_thresh & u_tp>=u_hs, .N]

  # Sample hs & tp extreme in unif
  dep_data_hs = .sample_ht1(n_hs, ht$dep$hs$par, ht$dep$hs$resid, ht$dep$p_dep_thresh, perturbed_ht_residuals)
  res[u_hs>ht$dep$p_dep_thresh & u_hs>u_tp, c("u_hs", "u_tp"):=dep_data_hs[, .(u_cond, u_dep)]]
  dep_data_tp = .sample_ht1(n_tp, ht$dep$tp$par, ht$dep$tp$resid, ht$dep$p_dep_thresh, perturbed_ht_residuals)
  res[u_tp>ht$dep$p_dep_thresh & u_tp>=u_hs, c("u_hs", "u_tp"):=dep_data_tp[, .(u_dep, u_cond)]]

  # Convert to original scale
  n = length(ht$margin$hs$emp)
  res[, hs:=.convert_unif_to_origin(
    unif = u_hs, p_thresh = ht$margin$p_margin_thresh, gpd_par = ht$margin$hs$par, emp = ht$margin$hs$emp)]
  res[, tp:=.convert_unif_to_origin(
    unif = u_tp, p_thresh = ht$margin$p_margin_thresh, gpd_par = ht$margin$tp$par, emp = ht$margin$tp$emp)]

  return(res[, .(hs, tp)])
}

.sample_ht1 = function(n_sim, par, resid, p_dep_thresh, perturbed_ht_residuals){
  set.seed(.seed_sampling)
  a = par[1]
  b = par[2]
  sim_data = data.table(u_cond=runif(n_sim, p_dep_thresh, 1))
  sim_data[, l_cond:=.convert_unif_to_lap(u_cond)]
  resid_max = sim_data[, (1-a)*l_cond^(1-b)]
  if(perturbed_ht_residuals){
    resid_bw = bw.SJ(resid)
    extended_resid = resid+rnorm(length(resid)*100, 0, resid_bw)
  }else{
    extended_resid = resid
  }
  resid_sample = sapply(resid_max, function(x)sample(extended_resid[extended_resid<x],1))
  sim_data[, l_dep:=resid_sample*l_cond^b+a*l_cond]
  sim_data[, u_dep:=.convert_lap_to_unif(l_dep)]
  return(sim_data[, .(u_cond, u_dep)])
}

.sample_ht_is = function(ht, target_rp){

  # Common
  n_sim = round(ht$npy*target_rp*.target_rp_ub)
  tail_prob = 1/(target_rp*.target_rp_lb*ht$npy)
  min_r = qnorm(1-tail_prob)
  n_tail = n_sim*exp(-min_r^2/2)

  # Generate importance samples outside the Rosenblatt transformed contour of tail_rtrp
  set.seed(.seed_sampling)
  calc = data.table(ur2 = runif(n_tail, min=pchisq(q = min_r^2,df = 2)))
  calc[, r:=sqrt(qchisq(p=ur2, df = 2))]
  calc[, dir:=runif(.N, min=0, max=2*pi)]

  # Generate by Tp|Hs model
  calc_hs = calc[, .(u_hs=pnorm(cos(dir)*r), u_tp_hs=pnorm(sin(dir)*r))]
  calc_hs[, lap_hs:=.convert_unif_to_lap(u_hs)]
  calc_hs[u_hs>=ht$dep$p_dep_thresh,lap_tp:=
            lap_hs*ht$dep$hs$par[["a"]]+lap_hs^ht$dep$hs$par[["b"]]*quantile(ht$dep$hs$resid, u_tp_hs)]
  calc_hs[u_hs>=ht$dep$p_dep_thresh, u_tp:=.convert_lap_to_unif(lap_tp)]
  calc_hs = calc_hs[u_hs>ht$dep$p_dep_thresh][u_hs>u_tp]
  calc_hs[, dir:=atan2(qnorm(u_hs), qnorm(u_tp))]

  # Generate by Tp|Hs model
  calc_tp = calc[, .(u_hs_tp=pnorm(cos(dir)*r), u_tp=pnorm(sin(dir)*r))]
  calc_tp[, lap_tp:=.convert_unif_to_lap(u_tp)]
  calc_tp[u_tp>=ht$dep$p_dep_thresh,lap_hs:=
            lap_tp*ht$dep$tp$par[["a"]]+lap_tp^ht$dep$tp$par[["b"]]*quantile(ht$dep$tp$resid, u_hs_tp)]
  calc_tp[u_tp>=ht$dep$p_dep_thresh, u_hs:=.convert_lap_to_unif(lap_hs)]
  calc_tp = calc_tp[u_tp>ht$dep$p_dep_thresh][u_tp>u_hs]
  calc_tp[, dir:=atan2(qnorm(u_hs), qnorm(u_tp))]

  # Generate low/low corner
  n_ll = calc[, .N]-calc_hs[, .N]-calc_tp[, .N]
  set.seed(.seed_sampling)
  res = ht$dep$dep_data[sample.int(.N, size = calc[, .N]/.target_rp_lb, replace = T), .(u_hs, u_tp)]
  # print(res[, .N])
  rot_wb = res[, .N^(-1/6)]
  res[, u_hs:=pnorm(qnorm(u_hs)+rnorm(.N, 0, rot_wb))]
  res[, u_tp:=pnorm(qnorm(u_tp)+rnorm(.N, 0, rot_wb))]
  res[, r:=sqrt(qnorm(u_hs)^2+qnorm(u_tp)^2)]
  res[, dir:=atan2(qnorm(u_hs), qnorm(u_tp))]
  res_ll = res[dir>max(calc_hs$dir) | dir<min(calc_tp$dir)]
  res_ll[, dir_grp:=round(dir, 3)]
  calc_ll = res_ll[, .SD[r>quantile(r, 1-n_ll/res_ll[,.N])], .(dir_grp)]

  # Merge
  out = rbind(calc_hs[, .(u_hs, u_tp)], calc_tp[, .(u_hs, u_tp)], calc_ll[, .(u_hs, u_tp)])
  out[, hs:=.convert_unif_to_origin(
    unif = u_hs, p_thresh = ht$margin$p_margin_thresh,
    gpd_par = ht$margin$hs$par, emp = ht$margin$hs$emp)]
  out[, tp:=.convert_unif_to_origin(
    unif = u_tp, p_thresh = ht$margin$p_margin_thresh,
    gpd_par = ht$margin$tp$par, emp = ht$margin$tp$emp)]

  return(out[, .(hs, tp)])
}

# Weibull log-normal ------------------------------------------------------
.sample_wln = function(wln, sim_year){
  set.seed(.seed_sampling)
  n_sim = round(wln$npy*sim_year)

  # Sample hs
  hs = rweibull(n_sim, shape = wln$hs$par["shape"], scale = wln$hs$par["scale"]) + wln$hs$par["loc"]

  # sample tp cond on hs
  tp_norm_mean = wln$tp$par[1] + wln$tp$par[2] * (hs ^ wln$tp$par[3])
  # tp_norm_sd = wln$tp$par[4] + wln$tp$par[5] * exp(wln$tp$par[6] * hs)
  tp_norm_sd = pmax(.limit_zero, wln$tp$par[4] + wln$tp$par[5] * exp(wln$tp$par[6] * hs))
  tp = exp(rnorm(n_sim, tp_norm_mean, tp_norm_sd))

  res = data.table(hs, tp)
  return(res)
}

.sample_wln_is = function(wln, target_rp){

  n_sim = round(wln$npy*target_rp*.target_rp_ub)
  tail_prob = 1/(target_rp*.target_rp_lb*wln$npy)
  min_r = qnorm(1-tail_prob)
  n_tail = n_sim*exp(-min_r^2/2)

  # Generate importance samples outside the Rosenblatt transformed contour of tail_rtrp
  set.seed(.seed_sampling)
  calc = data.table(ur2 = runif(n_tail, min=pchisq(q = min_r^2,df = 2)))
  calc[, r:=sqrt(qchisq(p=ur2, df = 2))]
  calc[, dir:=runif(.N, min=0, max=2*pi)]
  calc[, u_hs:=pnorm(cos(dir)*r)]
  calc[, u_tp:=pnorm(sin(dir)*r)]

  # Sample hs
  calc[, hs:= qweibull(u_hs, shape = wln$hs$par["shape"], scale = wln$hs$par["scale"]) + wln$hs$par["loc"]]

  # sample tp cond on hs
  calc[, tp_norm_mean:= wln$tp$par[1] + wln$tp$par[2] * (hs ^ wln$tp$par[3])]
  # calc[, tp_norm_sd:= wln$tp$par[4] + wln$tp$par[5] * exp(wln$tp$par[6] * hs)]
  calc[, tp_norm_sd:= pmax(.limit_zero, wln$tp$par[4] + wln$tp$par[5] * exp(wln$tp$par[6] * hs))]
  calc[, tp:= exp(qnorm(u_tp, tp_norm_mean, tp_norm_sd))]

  # Return
  return(calc[, .(hs, tp)])
}