R/new.base.generation.R

In MoBPS: Modular Breeding Program Simulator

'#
  Authors
Torsten Pook, torsten.pook@uni-goettingen.de

Copyright (C) 2017 -- 2020  Torsten Pook

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 3
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
'#

#' Set new base generation
#'
#' Function to set a new base generation for the population
#' @param population Population list
#' @param base.gen Vector containing all new base generations
#' @param delete.previous.gen Delete all data before base.gen (default: FALSE)
#' @param delete.breeding.totals Delete all breeding totals before base.gen (default: FALSE)
#' @param delete.bve.data Deleta all previous bve data (default: FALSE)
#' @param add.chromosome.ends Add chromosome ends as recombination points
#' @examples
#' data(ex_pop)
#' ex_pop <- new.base.generation(ex_pop, base.gen=2)
#' @return Population-List with mutated marker for the selected individual
#' @export

new.base.generation <- function(population, base.gen=NULL, delete.previous.gen=FALSE, delete.breeding.totals=FALSE,
                                delete.bve.data=FALSE, add.chromosome.ends=TRUE){

  if (requireNamespace("miraculix", quietly = TRUE)) {
    codeOriginsU <- miraculix::codeOrigins
    decodeOriginsU <- miraculix::decodeOrigins
  } else{
    codeOriginsU <- codeOriginsR
    decodeOriginsU <- decodeOriginsR
  }
  if(length(population$info$miraculix)>0 && population$info$miraculix){
    miraculix <- TRUE
  } else{
    miraculix <- FALSE
  }

  if(length(base.gen)==0){
    base.gen <- length(population$breeding)
  }

  take <- which(population$info$origin.gen==base.gen)
  if(length(take)==1){
    origin_code <- population$info$origin.gen[take]
  } else{
    if(population$info$miraculix){
      if(length(population$info$origin.gen)<64){
        population$info$origin.gen <- c(population$info$origin.gen, as.integer(base.gen))
        origin_code <- length(population$info$origin.gen)
      } else{
        warning("To many origin generation!")
        warning("Delete second lowest origin.gen")
        switch_gen <- sort(population$info$origin.gen, index.return=TRUE)$ix[2]
        population$info$origin.gen[switch_gen] <- as.integer(base.gen)
        origin_code <- switch_gen
      }
    } else{
      if(length(population$info$origin.gen)<32){
        population$info$origin.gen <- c(population$info$origin.gen, as.integer(base.gen))
        origin_code <- length(population$info$origin.gen)
      } else{
        warning("To many origin generation!")
        warning("Delete second lowest origin.gen")
        switch_gen <- sort(population$info$origin.gen, index.return=TRUE)$ix[2]
        population$info$origin.gen[switch_gen] <- as.integer(base.gen)
        origin_code <- switch_gen
      }
    }
  }



  for(gen in base.gen){
    for(sex in 1:2){
      if(length(population$breeding[[gen]][[sex]])>0){
        for(nr in 1:length(population$breeding[[gen]][[sex]])){
          if(miraculix){
            population$breeding[[gen]][[sex]][[nr]][[9]] <- miraculix::computeSNPS(population, gen, sex, nr, what="haplo", output_compressed=TRUE)
          } else{
            snps <- compute.snps(population, gen, sex, nr, decodeOriginsU=decodeOriginsU)
            population$breeding[[gen]][[sex]][[nr]][[9]] <- snps[1,]
            population$breeding[[gen]][[sex]][[nr]][[10]] <- snps[2,]
          }

          population$breeding[[gen]][[sex]][[nr]][[1]] <- c(0, sum(population$info$length))
          population$breeding[[gen]][[sex]][[nr]][[2]] <- c(0, sum(population$info$length))
          if(add.chromosome.ends==TRUE){
            population$breeding[[gen]][[sex]][[nr]][[1]] <- population$info$length.total
            population$breeding[[gen]][[sex]][[nr]][[2]] <- population$info$length.total
          }
          population$breeding[[gen]][[sex]][[nr]][[3]] <- numeric(0)
          population$breeding[[gen]][[sex]][[nr]][[4]] <- numeric(0)
          population$breeding[[gen]][[sex]][[nr]][[5]] <- codeOriginsU(matrix(c(origin_code, sex, nr, 1),nrow=(length(population$breeding[[gen]][[sex]][[nr]][[1]])-1), ncol=4, byrow=TRUE))

          population$breeding[[gen]][[sex]][[nr]][[6]] <- codeOriginsU(matrix(c(origin_code, sex, nr, 2),nrow=(length(population$breeding[[gen]][[sex]][[nr]][[2]])-1), ncol=4, byrow=TRUE))
        }

      }

    }
  }
  if(delete.previous.gen){
    for(index in 1:(min(base.gen)-1)){
      population$breeding[[index]] <- "deleted"
    }
  }
  if(delete.breeding.totals){
    population$info$breeding.totals <- NULL
  }
  if(delete.bve.data){
    population$info$bve.data <- NULL
  }
  return(population)
}