R/mateNetworks.R

In princeew/PFFindR: Identify, evaluate, and visualize enriched Prix Fixe subnetworks

#' Mate a pair of PrixFixe Networks
#'
#' Given a scored population of PrixFixeNetworks, randomly select two networks
#' (with replacement) based on probabilities reflecting fitness for mating and
#' generate a new PrixFixeNetwork by randomly selecting loci from each parent network.
#'
#' @param population a list of \code{PrixFixeNetwork} objects
#' @param pf_data a \code{PFData} object generated by \code{PFDataLoader}
#' @param num_matings integer for how many matings to perform
#' @param mutation_rate float value of percent with which to mutate the network nodes
#' @return A \code{PrixFixeNetwork} object

mateNetworks <- function(population, pf_data, num_matings, mutation_rate) {
  mating_iterations <- as.list(1:num_matings)
  new_population <- lapply(mating_iterations, .mateNetworks, population = population,
                           pf_data = pf_data, mutation_rate = mutation_rate)
  return(new_population)
}

.mateNetworks <- function(mating_iteration, population, pf_data, mutation_rate) {
  # Helper function for mateNetworks

  # Collect densities and convert to s_i_star
  network_scores <- getNetworkDensity(population, return_mean = FALSE) ** 3

  # This code is for testing purposed, with small populations there are often not
  # enough networks to mate.
  if (length(network_scores[network_scores > 0]) <= 2) {
    network_scores <- network_scores + 1
  }

  # Determine probabilities for sampling
  probs <- network_scores / sum(network_scores)
  mates <- sample(population, 2, prob = probs, replace = T)

  # Maybe mutate the mates
  mates <- mutateNetworks(mates, pf_data, mutation_rate)
  gene_options <- lapply(mates, .get_gene_options)
  offspring_genes <- apply(as.data.frame(gene_options), 1, .select_genes)

  # Construct offpsring PrixFixeNetwork
  offspring <- new(
    "PrixFixeNetwork",
    "loci" = pf_data@loci_dataframe$locusID,
    "genes" = offspring_genes)
  return(calculateAdjacencyMatrix(offspring, pf_data))
}

.get_gene_options <- function(network) {
  return(network@genes)
}

.select_genes <- function(gene_option_row) {
  return(sample(unlist(gene_option_row), 1))
}